From 671211e62d60c8bc1ca8d7a7feb61c58205f364e Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Wed, 5 Jan 2022 23:18:43 -0500 Subject: [PATCH 01/43] convert to contravariant logging style part 1, uses additional hardcoded log file to see it side by side with original logging --- exe/Main.hs | 48 ++++-- exe/Plugins.hs | 14 +- ghcide/src/Development/IDE/Core/Service.hs | 14 +- ghcide/src/Development/IDE/Core/Shake.hs | 58 ++++++-- .../src/Development/IDE/LSP/Notifications.hs | 16 +- ghcide/src/Development/IDE/Main.hs | 101 ++++++++----- ghcide/src/Development/IDE/Main/HeapStats.hs | 46 +++--- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 11 +- ghcide/src/Development/IDE/Types/Logger.hs | 138 +++++++++++++++++- src/Ide/Main.hs | 48 +++--- 10 files changed, 378 insertions(+), 116 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index e5ba2cb6a7..7e81143554 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,21 +1,47 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Main(main) where -import Ide.Arguments (Arguments (..), GhcideArguments (..), - getArguments) -import Ide.Main (defaultMain) -import Plugins +import Data.Function ((&)) +import Data.Text (Text) +import qualified Data.Text as Text +import Development.IDE.Types.Logger (Priority (Debug, Info), + WithPriority (WithPriority, priority), + cfilter, cmap, + withDefaultTextWithPriorityRecorder) +import Ide.Arguments (Arguments (..), + GhcideArguments (..), + getArguments) +import Ide.Main (defaultMain) +import qualified Ide.Main as IdeMain +import qualified Plugins + + +data Log + = LogIdeMain IdeMain.Log + | LogPlugins Plugins.Log + deriving Show + +logToTextWithPriority :: Log -> WithPriority Text +logToTextWithPriority = WithPriority Info . Text.pack . show main :: IO () main = do - args <- getArguments "haskell-language-server" (idePlugins False) + args <- getArguments "haskell-language-server" (Plugins.idePlugins undefined False) + + let (minPriority, logFilePath, includeExamplePlugins) = + case args of + Ghcide GhcideArguments{ argsTesting, argsDebugOn, argsLogFile, argsExamplePlugin } -> + let minPriority = if argsDebugOn || argsTesting then Debug else Info + in (minPriority, argsLogFile, argsExamplePlugin) + _ -> (Info, Nothing, False) - let withExamples = - case args of - Ghcide GhcideArguments{..} -> argsExamplePlugin - _ -> False + withDefaultTextWithPriorityRecorder (Just "/home/jon/bls.log") $ \textWithPriorityRecorder -> do + let recorder = + textWithPriorityRecorder + & cfilter (\WithPriority{ priority } -> priority >= minPriority) + & cmap logToTextWithPriority - defaultMain args (idePlugins withExamples) + defaultMain (cmap LogIdeMain recorder) args (Plugins.idePlugins (cmap LogPlugins recorder) includeExamplePlugins) diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 4974677877..69d062d186 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -7,7 +7,7 @@ import Ide.Types (IdePlugins) -- fixed plugins import Development.IDE (IdeState) -import Development.IDE.Plugin.HLS.GhcIde as GhcIde +import Development.IDE.Plugin.HLS.GhcIde as GhcIde hiding (Log) import Ide.Plugin.Example as Example import Ide.Plugin.Example2 as Example2 @@ -91,9 +91,15 @@ import Ide.Plugin.StylishHaskell as StylishHaskell #endif #if brittany +import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide +import Development.IDE.Types.Logger (Recorder, cmap) import Ide.Plugin.Brittany as Brittany #endif +data Log + = LogGhcide Ghcide.Log + deriving Show + -- --------------------------------------------------------------------- -- | The plugins configured for use in this instance of the language @@ -101,8 +107,8 @@ import Ide.Plugin.Brittany as Brittany -- These can be freely added or removed to tailor the available -- features of the server. -idePlugins :: Bool -> IdePlugins IdeState -idePlugins includeExamples = pluginDescToIdePlugins allPlugins +idePlugins :: Recorder Log -> Bool -> IdePlugins IdeState +idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins where allPlugins = if includeExamples then basePlugins ++ examplePlugins @@ -170,7 +176,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins #endif -- The ghcide descriptors should come last so that the notification handlers -- (which restart the Shake build) run after everything else - GhcIde.descriptors + GhcIde.descriptors (cmap LogGhcide recorder) examplePlugins = [Example.descriptor "eg" ,Example2.descriptor "eg2" diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index a98f80bfb4..ed6b03e008 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -15,6 +15,7 @@ module Development.IDE.Core.Service( getDiagnostics, ideLogger, updatePositionMapping, + Log ) where import Control.Applicative ((<|>)) @@ -29,16 +30,22 @@ import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP import Control.Monad -import Development.IDE.Core.Shake +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Shake (WithHieDb) import System.Environment (lookupEnv) +data Log + = LogShake Shake.Log + deriving Show + ------------------------------------------------------------ -- Exposed API -- | Initialise the Compiler Service. -initialise :: Config +initialise :: Recorder Log + -> Config -> Rules () -> Maybe (LSP.LanguageContextEnv Config) -> Logger @@ -48,12 +55,13 @@ initialise :: Config -> WithHieDb -> IndexQueue -> IO IdeState -initialise defaultConfig mainRule lspEnv logger debouncer options vfs withHieDb hiedbChan = do +initialise recorder defaultConfig mainRule lspEnv logger debouncer options vfs withHieDb hiedbChan = do shakeProfiling <- do let fromConf = optShakeProfiling options fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING" return $ fromConf <|> fromEnv shakeOpen + (cmap LogShake recorder) lspEnv defaultConfig logger diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 1d807beeb1..b8d2f76aab 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -77,6 +77,7 @@ module Development.IDE.Core.Shake( addPersistentRule, garbageCollectDirtyKeys, garbageCollectDirtyKeysOlderThan, + Log ) where import Control.Concurrent.Async @@ -149,6 +150,7 @@ import Language.LSP.Types.Capabilities import OpenTelemetry.Eventlog import Control.Concurrent.STM.Stats (atomicallyNamed) +import Control.Exception.Base (SomeException (SomeException)) import Control.Exception.Extra hiding (bracket_) import Data.Aeson (toJSON) import qualified Data.ByteString.Char8 as BS8 @@ -160,6 +162,7 @@ import qualified Data.HashSet as HSet import Data.String (fromString) import Data.Text (pack) import Debug.Trace.Flags (userTracingEnabled) +import Development.IDE.Types.Action (DelayedActionInternal) import qualified Development.IDE.Types.Exports as ExportsMap import qualified Focus import HieDb.Types @@ -169,6 +172,16 @@ import Ide.Types (PluginId) import qualified "list-t" ListT import qualified StmContainers.Map as STM +data Log + = LogCreateHieDbExportsMapStart + -- logDebug logger "Initializing exports map from hiedb" + | LogCreateHieDbExportsMapFinish !Int + -- logDebug logger $ "Done initializing exports map from hiedb (" <> pack(show (ExportsMap.size em)) <> ")" + | LogBuildSessionRestart !String ![DelayedActionInternal] !(HashSet Key) !Seconds !(Maybe FilePath) + | LogDelayedAction !(DelayedAction ()) !Seconds + | LogBuildSessionFinish !(Maybe SomeException) + deriving Show + -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by -- a worker thread. @@ -494,7 +507,8 @@ seqValue val = case val of Failed _ -> val -- | Open a 'IdeState', should be shut using 'shakeShut'. -shakeOpen :: Maybe (LSP.LanguageContextEnv Config) +shakeOpen :: Recorder Log + -> Maybe (LSP.LanguageContextEnv Config) -> Config -> Logger -> Debouncer NormalizedUri @@ -507,8 +521,10 @@ shakeOpen :: Maybe (LSP.LanguageContextEnv Config) -> ShakeOptions -> Rules () -> IO IdeState -shakeOpen lspEnv defaultConfig logger debouncer +shakeOpen recorder lspEnv defaultConfig logger debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue vfs opts rules = mdo + let log :: Log -> IO () + log = logWith recorder us <- mkSplitUniqSupply 'r' ideNc <- newIORef (initNameCache us knownKeyNames) @@ -520,7 +536,7 @@ shakeOpen lspEnv defaultConfig logger debouncer publishedDiagnostics <- STM.newIO positionMapping <- STM.newIO knownTargetsVar <- newTVarIO $ hashed HMap.empty - let restartShakeSession = shakeRestart ideState + let restartShakeSession = shakeRestart recorder ideState persistentKeys <- newTVarIO HMap.empty indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 @@ -528,11 +544,12 @@ shakeOpen lspEnv defaultConfig logger debouncer let hiedbWriter = HieDbWriter{..} exportsMap <- newTVarIO mempty -- lazily initialize the exports map with the contents of the hiedb + -- TODO: exceptions can be swallowed here? _ <- async $ do - logDebug logger "Initializing exports map from hiedb" + log LogCreateHieDbExportsMapStart em <- createExportsMapHieDb withHieDb atomically $ modifyTVar' exportsMap (<> em) - logDebug logger $ "Done initializing exports map from hiedb (" <> pack(show (ExportsMap.size em)) <> ")" + log $ LogCreateHieDbExportsMapFinish (ExportsMap.size em) progress <- do let (before, after) = if testing then (0,0.1) else (0.1,0.1) @@ -584,9 +601,9 @@ startTelemetry db extras@ShakeExtras{..} -- | Must be called in the 'Initialized' handler and only once -shakeSessionInit :: IdeState -> IO () -shakeSessionInit ide@IdeState{..} = do - initSession <- newSession shakeExtras shakeDb [] "shakeSessionInit" +shakeSessionInit :: Recorder Log -> IdeState -> IO () +shakeSessionInit recorder ide@IdeState{..} = do + initSession <- newSession recorder shakeExtras shakeDb [] "shakeSessionInit" putMVar shakeSession initSession logDebug (ideLogger ide) "Shake session initialized" @@ -626,15 +643,19 @@ delayedAction a = do -- | Restart the current 'ShakeSession' with the given system actions. -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued. -shakeRestart :: IdeState -> String -> [DelayedAction ()] -> IO () -shakeRestart IdeState{..} reason acts = +shakeRestart :: Recorder Log -> IdeState -> String -> [DelayedAction ()] -> IO () +shakeRestart recorder IdeState{..} reason acts = withMVar' shakeSession (\runner -> do + let log = logWith recorder (stopTime,()) <- duration (cancelShakeSession runner) res <- shakeDatabaseProfile shakeDb backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras + + log $ LogBuildSessionRestart reason queue backlog stopTime res + let profile = case res of Just fp -> ", profile saved at " <> fp _ -> "" @@ -643,14 +664,13 @@ shakeRestart IdeState{..} reason acts = queueMsg = " with queue " ++ show (map actionName queue) keysMsg = " for keys " ++ show (HSet.toList backlog) ++ " " abortMsg = "(aborting the previous one took " ++ showDuration stopTime ++ profile ++ ")" - logDebug (logger shakeExtras) msg notifyTestingLogMessage shakeExtras msg ) -- It is crucial to be masked here, otherwise we can get killed -- between spawning the new thread and updating shakeSession. -- See https://github.com/haskell/ghcide/issues/79 (\() -> do - (,()) <$> newSession shakeExtras shakeDb acts reason) + (,()) <$> newSession recorder shakeExtras shakeDb acts reason) notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO () notifyTestingLogMessage extras msg = do @@ -684,12 +704,13 @@ shakeEnqueue ShakeExtras{actionQueue, logger} act = do -- | Set up a new 'ShakeSession' with a set of initial actions -- Will crash if there is an existing 'ShakeSession' running. newSession - :: ShakeExtras + :: Recorder Log + -> ShakeExtras -> ShakeDatabase -> [DelayedActionInternal] -> String -> IO ShakeSession -newSession extras@ShakeExtras{..} shakeDb acts reason = do +newSession recorder extras@ShakeExtras{..} shakeDb acts reason = do IdeOptions{optRunSubset} <- getIdeOptionsIO extras reenqueued <- atomicallyNamed "actionQueue - peek" $ peekInProgress actionQueue allPendingKeys <- @@ -712,7 +733,7 @@ newSession extras@ShakeExtras{..} shakeDb acts reason = do let msg = T.pack $ "finish: " ++ actionName d ++ " (took " ++ showDuration runTime ++ ")" liftIO $ do - logPriority logger (actionPriority d) msg + logWith recorder $ LogDelayedAction d runTime notifyTestingLogMessage extras msg -- The inferred type signature doesn't work in ghc >= 9.0.1 @@ -729,7 +750,11 @@ newSession extras@ShakeExtras{..} shakeDb acts reason = do Right _ -> "completed" let msg = T.pack $ "Finishing build session(" ++ res' ++ ")" return $ do - logDebug logger msg + let exception = + case res of + Left e -> Just e + _ -> Nothing + logWith recorder $ LogBuildSessionFinish exception notifyTestingLogMessage extras msg -- Do the work in a background thread @@ -737,6 +762,7 @@ newSession extras@ShakeExtras{..} shakeDb acts reason = do -- run the wrap up in a separate thread since it contains interruptible -- commands (and we are not using uninterruptible mask) + -- TODO: can possibly swallow exceptions? _ <- async $ join $ wait workThread -- Cancelling is required to flush the Shake database when either diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 49dab15015..77f810f565 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -9,6 +9,7 @@ module Development.IDE.LSP.Notifications ( whenUriFile , descriptor + , Log ) where import Language.LSP.Types @@ -29,18 +30,23 @@ import Development.IDE.Core.FileStore (registerFileWatches, import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.OfInterest import Development.IDE.Core.RuleTypes (GetClientSettings (..)) -import Development.IDE.Core.Service -import Development.IDE.Core.Shake +import Development.IDE.Core.Service hiding (Log) +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Shake (toKey) import Ide.Types +data Log + = LogShake Shake.Log + deriving Show + whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = mconcat +descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = mconcat [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \ide _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do atomically $ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List []) @@ -112,7 +118,7 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ -> do --------- Initialize Shake session -------------------------------------------------------------------- - liftIO $ shakeSessionInit ide + liftIO $ shakeSessionInit (cmap LogShake recorder) ide --------- Set up file watchers ------------------------------------------------------------------------ opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 74929b3673..778803a181 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -8,13 +8,14 @@ module Development.IDE.Main ,isLSP ,commandP ,defaultMain -,testing) where +,testing +,Log) where import Control.Concurrent.Extra (newLock, withLock, withNumCapabilities) import Control.Concurrent.STM.Stats (atomically, dumpSTMStats) import Control.Exception.Safe (Exception (displayException), - catchAny) + SomeException, catchAny) import Control.Monad.Extra (concatMapM, unless, when) import qualified Data.Aeson.Encode.Pretty as A @@ -51,13 +52,16 @@ import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCo import Development.IDE.Core.Rules (GhcSessionIO (GhcSessionIO), mainRule) import Development.IDE.Core.Service (initialise, runAction) +import qualified Development.IDE.Core.Service as Service import Development.IDE.Core.Shake (IdeState (shakeExtras), ShakeExtras (state), shakeSessionInit, uses) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Core.Tracing (measureMemory) import Development.IDE.Graph (action) import Development.IDE.LSP.LanguageServer (runLanguageServer) import Development.IDE.Main.HeapStats (withHeapStats) +import qualified Development.IDE.Main.HeapStats as HeapStats import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) import Development.IDE.Plugin.HLS (asGhcIdePlugin) import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide @@ -72,7 +76,9 @@ import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath') import Development.IDE.Types.Logger (Logger (Logger), Priority (Info), - logDebug, logInfo) + Recorder (Recorder), + cmap, logDebug, logInfo, + logWith) import Development.IDE.Types.Options (IdeGhcSession, IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), IdeTesting (IdeTesting), @@ -118,7 +124,7 @@ import System.IO (BufferMode (LineBufferin hSetEncoding, stderr, stdin, stdout, utf8) import System.Random (newStdGen) -import System.Time.Extra (offsetTime, +import System.Time.Extra (Seconds, offsetTime, showDuration) import Text.Printf (printf) @@ -187,18 +193,18 @@ data Arguments = Arguments , argsThreads :: Maybe Natural } -instance Default Arguments where - def = defaultArguments Info +-- instance Default Arguments where +-- def = defaultArguments Info -defaultArguments :: Priority -> Arguments -defaultArguments priority = Arguments +defaultArguments :: Recorder Log -> Priority -> Arguments +defaultArguments recorder priority = Arguments { argsProjectRoot = Nothing , argsOTMemoryProfiling = False , argCommand = LSP , argsLogger = stderrLogger priority , argsRules = mainRule def >> action kick , argsGhcidePlugin = mempty - , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors + , argsHlsPlugins = pluginDescToIdePlugins (Ghcide.descriptors (cmap LogGhcide recorder)) , argsSessionLoadingOptions = def , argsIdeOptions = \config ghcSession -> (defaultIdeOptions ghcSession) { optCheckProject = pure $ checkProject config @@ -226,17 +232,20 @@ defaultArguments priority = Arguments return newStdout } -testing :: Arguments -testing = (defaultArguments Debug) { - argsHlsPlugins = pluginDescToIdePlugins $ - idePluginsToPluginDesc (argsHlsPlugins def) - ++ [Test.blockCommandDescriptor "block-command", Test.plugin], - argsIdeOptions = \config sessionLoader -> - let defOptions = argsIdeOptions def config sessionLoader - in defOptions { - optTesting = IdeTesting True - } -} +testing :: Recorder Log -> Arguments +testing recorder = + let arguments = defaultArguments recorder Debug + in + arguments { + argsHlsPlugins = pluginDescToIdePlugins $ + idePluginsToPluginDesc (argsHlsPlugins arguments) + ++ [Test.blockCommandDescriptor "block-command", Test.plugin], + argsIdeOptions = \config sessionLoader -> + let defOptions = argsIdeOptions arguments config sessionLoader + in defOptions { + optTesting = IdeTesting True + } + } -- | Cheap stderr logger that relies on LineBuffering stderrLogger :: Priority -> IO Logger @@ -245,9 +254,32 @@ stderrLogger logLevel = do return $ Logger $ \p m -> when (p >= logLevel) $ withLock lock $ T.hPutStrLn stderr $ "[" <> T.pack (show p) <> "] " <> m -defaultMain :: Arguments -> IO () -defaultMain Arguments{..} = flip withHeapStats fun =<< argsLogger +data Log + = LogHeapStats !HeapStats.Log + | LogLspStart + -- logInfo logger "Starting LSP server..." + -- logInfo logger "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!" + | LogLspStartDuration !Seconds + -- logInfo logger $ T.pack $ "Started LSP server in " ++ showDuration t + | LogShouldRunSubset !Bool + -- logDebug logger $ T.pack $ "runSubset: " <> show runSubset + | LogOnlyPartialGhc9Support + -- hPutStrLn stderr $ + -- "Currently, HLS supports GHC 9 only partially. " + -- <> "See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail." + | LogSetInitialDynFlagsException !SomeException + -- (logDebug logger $ T.pack $ "setInitialDynFlags: " ++ displayException e) + | LogService Service.Log + | LogShake Shake.Log + | LogGhcide Ghcide.Log + deriving Show + +defaultMain :: Recorder Log -> Arguments -> IO () +defaultMain recorder Arguments{..} = withHeapStats (cmap LogHeapStats recorder) fun where + log :: Log -> IO () + log = logWith recorder + fun = do setLocaleEncoding utf8 pid <- T.pack . show <$> getProcessID @@ -274,12 +306,12 @@ defaultMain Arguments{..} = flip withHeapStats fun =<< argsLogger LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins LSP -> withNumCapabilities (maybe (numProcessors `div` 2) fromIntegral argsThreads) $ do t <- offsetTime - logInfo logger "Starting LSP server..." - logInfo logger "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!" + log LogLspStart + runLanguageServer options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath withHieDb hieChan -> do traverse_ IO.setCurrentDirectory rootPath t <- t - logInfo logger $ T.pack $ "Started LSP server in " ++ showDuration t + log $ LogLspStartDuration t dir <- maybe IO.getCurrentDirectory return rootPath @@ -287,8 +319,8 @@ defaultMain Arguments{..} = flip withHeapStats fun =<< argsLogger -- `unsafeGlobalDynFlags` even before the project is configured _mlibdir <- setInitialDynFlags logger dir argsSessionLoadingOptions - `catchAny` (\e -> (logDebug logger $ T.pack $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing) - + -- TODO: should probably catch/log/rethrow at top level instead + `catchAny` (\e -> log (LogSetInitialDynFlagsException e) >> pure Nothing) sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir config <- LSP.runLspT env LSP.getConfig @@ -296,7 +328,7 @@ defaultMain Arguments{..} = flip withHeapStats fun =<< argsLogger -- disable runSubset if the client doesn't support watched files runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported - logDebug logger $ T.pack $ "runSubset: " <> show runSubset + log $ LogShouldRunSubset runSubset let options = def_options { optReportProgress = clientSupportsProgress caps @@ -306,10 +338,9 @@ defaultMain Arguments{..} = flip withHeapStats fun =<< argsLogger caps = LSP.resClientCapabilities env -- FIXME: Remove this after GHC 9 gets fully supported when (ghcVersion == GHC90) $ - hPutStrLn stderr $ - "Currently, HLS supports GHC 9 only partially. " - <> "See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail." + log LogOnlyPartialGhc9Support initialise + (cmap LogService recorder) argsDefaultHlsConfig rules (Just env) @@ -352,8 +383,8 @@ defaultMain Arguments{..} = flip withHeapStats fun =<< argsLogger , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan - shakeSessionInit ide + ide <- initialise (cmap LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan + shakeSessionInit (cmap LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) putStrLn "\nStep 4/4: Type checking the files" @@ -406,8 +437,8 @@ defaultMain Arguments{..} = flip withHeapStats fun =<< argsLogger , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan - shakeSessionInit ide + ide <- initialise (cmap LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan + shakeSessionInit (cmap LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide diff --git a/ghcide/src/Development/IDE/Main/HeapStats.hs b/ghcide/src/Development/IDE/Main/HeapStats.hs index de45fa6c38..b52b18e5ef 100644 --- a/ghcide/src/Development/IDE/Main/HeapStats.hs +++ b/ghcide/src/Development/IDE/Main/HeapStats.hs @@ -1,22 +1,37 @@ {-# LANGUAGE NumericUnderscores #-} -- | Logging utilities for reporting heap statistics -module Development.IDE.Main.HeapStats ( withHeapStats ) where +module Development.IDE.Main.HeapStats ( withHeapStats, Log ) where -import GHC.Stats -import Development.IDE.Types.Logger (Logger, logInfo) +import Control.Concurrent import Control.Concurrent.Async -import qualified Data.Text as T -import Data.Word import Control.Monad -import Control.Concurrent -import Text.Printf (printf) +import qualified Data.Text as T +import Data.Word +import Development.IDE.Types.Logger (Logger, Recorder, logInfo, + logWith) +import GHC.Stats +import Text.Printf (printf) + +data Log + = LogHeapStatsPeriod !Int + -- logInfo l ("Logging heap statistics every " + -- <> T.pack (printf "%.2fs" (fromIntegral @Int @Double heapStatsInterval / 1e6))) + | LogHeapStatsDisabled + -- logInfo l "Heap statistics are not enabled (RTS option -T is needed)" + | LogHeapStats !Word64 !Word64 + -- format :: Word64 -> T.Text + -- format m = T.pack (printf "%.2fMB" (fromIntegral @Word64 @Double m / 1e6)) + -- message = "Live bytes: " <> format live_bytes <> " " <> + -- "Heap size: " <> format heap_size + -- logInfo l message + deriving Show -- | Interval at which to report the latest heap statistics. heapStatsInterval :: Int heapStatsInterval = 60_000_000 -- 60s -- | Report the live bytes and heap size at the last major collection. -logHeapStats :: Logger -> IO () +logHeapStats :: Recorder Log -> IO () logHeapStats l = do stats <- getRTSStats -- live_bytes is the total amount of live memory in a program @@ -25,14 +40,10 @@ logHeapStats l = do -- heap_size is the total amount of memory the RTS is using -- this corresponds closer to OS memory usage heap_size = gcdetails_mem_in_use_bytes (gc stats) - format :: Word64 -> T.Text - format m = T.pack (printf "%.2fMB" (fromIntegral @Word64 @Double m / 1e6)) - message = "Live bytes: " <> format live_bytes <> " " <> - "Heap size: " <> format heap_size - logInfo l message + logWith l $ LogHeapStats live_bytes heap_size -- | An action which logs heap statistics at the 'heapStatsInterval' -heapStatsThread :: Logger -> IO r +heapStatsThread :: Recorder Log -> IO r heapStatsThread l = forever $ do threadDelay heapStatsInterval logHeapStats l @@ -40,14 +51,13 @@ heapStatsThread l = forever $ do -- | A helper function which lauches the 'heapStatsThread' and kills it -- appropiately when the inner action finishes. It also checks to see -- if `-T` is enabled. -withHeapStats :: Logger -> IO r -> IO r +withHeapStats :: Recorder Log -> IO r -> IO r withHeapStats l k = do enabled <- getRTSStatsEnabled if enabled then do - logInfo l ("Logging heap statistics every " - <> T.pack (printf "%.2fs" (fromIntegral @Int @Double heapStatsInterval / 1e6))) + logWith l $ LogHeapStatsPeriod heapStatsInterval withAsync (heapStatsThread l) (const k) else do - logInfo l "Heap statistics are not enabled (RTS option -T is needed)" + logWith l LogHeapStatsDisabled k diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index c854330d9c..eaf51bf861 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -5,6 +5,7 @@ module Development.IDE.Plugin.HLS.GhcIde ( descriptors + , Log ) where import Control.Monad.IO.Class import Development.IDE @@ -19,8 +20,12 @@ import Language.LSP.Server (LspM) import Language.LSP.Types import Text.Regex.TDFA.Text () -descriptors :: [PluginDescriptor IdeState] -descriptors = +data Log + = LogNotifications Notifications.Log + deriving Show + +descriptors :: Recorder Log -> [PluginDescriptor IdeState] +descriptors recorder = [ descriptor "ghcide-hover-and-symbols", CodeAction.iePluginDescriptor "ghcide-code-actions-imports-exports", CodeAction.typeSigsPluginDescriptor "ghcide-code-actions-type-signatures", @@ -28,7 +33,7 @@ descriptors = CodeAction.fillHolePluginDescriptor "ghcide-code-actions-fill-holes", Completions.descriptor "ghcide-completions", TypeLenses.descriptor "ghcide-type-lenses", - Notifications.descriptor "ghcide-core" + Notifications.descriptor (cmap LogNotifications recorder) "ghcide-core" ] -- --------------------------------------------------------------------- diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index c40ef36e54..22c663ec88 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -8,11 +8,29 @@ module Development.IDE.Types.Logger ( Priority(..) , Logger(..) + , Recorder(..) , logError, logWarning, logInfo, logDebug, logTelemetry , noLogging - ) where + , WithPriority(..) + , logWith, cmap, cmapIO, cfilter, withDefaultTextWithPriorityRecorder) where -import qualified Data.Text as T +import Control.Concurrent (myThreadId) +import Control.Concurrent.Extra (newLock, withLock) +import Control.Monad (when, (>=>)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Functor.Contravariant (Contravariant (contramap)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Time (defaultTimeLocale, formatTime, + getCurrentTime) +import GHC.Stack (HasCallStack, + SrcLoc (SrcLoc, srcLocModule, srcLocStartLine), + getCallStack, withFrozenCallStack) +import System.IO (Handle, IOMode (AppendMode), + hFlush, stderr) +import UnliftIO (MonadUnliftIO, withFile) data Priority @@ -57,3 +75,119 @@ logTelemetry x = logPriority x Telemetry noLogging :: Logger noLogging = Logger $ \_ _ -> return () + +data WithPriority a = WithPriority { priority :: Priority, payload :: a } deriving Functor + +-- | Note that this is logging actions _of the program_, not of the user. +-- You shouldn't call warning/error if the user has caused an error, only +-- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). +data Recorder msg = Recorder + { logger_ :: forall m. (HasCallStack, MonadIO m) => msg -> m () + } + +logWith :: (HasCallStack, MonadIO m) => Recorder msg -> msg -> m () +logWith recorder msg = withFrozenCallStack $ logger_ recorder msg + +instance Semigroup (Recorder msg) where + (<>) Recorder{ logger_ = logger_1 } Recorder{ logger_ = logger_2 } = + Recorder + { logger_ = \msg -> logger_1 msg >> logger_2 msg + } + +instance Monoid (Recorder msg) where + mempty = + Recorder + { logger_ = \_ -> pure () + } + +instance Contravariant Recorder where + contramap f Recorder{ logger_ } = + Recorder + { logger_ = logger_ . f + } + +cmap :: (a -> b) -> Recorder b -> Recorder a +cmap = contramap + +cmapIO :: (a -> IO b) -> Recorder b -> Recorder a +cmapIO f Recorder{ logger_ } = + Recorder + { logger_ = (liftIO . f) >=> logger_ + } + +cfilter :: (a -> Bool) -> Recorder a -> Recorder a +cfilter p Recorder{ logger_ } = + Recorder + { logger_ = \msg -> when (p msg) (logger_ msg) + } + +textHandleRecorder :: Handle -> Recorder Text +textHandleRecorder handle = + Recorder + { logger_ = \text -> liftIO $ Text.hPutStrLn handle text *> hFlush handle + } + +textStderrRecorder :: Recorder Text +textStderrRecorder = textHandleRecorder stderr + +-- | Cheap stderr logger_ that relies on LineBuffering +threadSafeTextStderrRecorder :: IO (Recorder Text) +threadSafeTextStderrRecorder = do + lock <- newLock + let Recorder{ logger_ } = textStderrRecorder + pure $ Recorder + { logger_ = \msg -> liftIO $ withLock lock (logger_ msg) + } + +makeThreadSafeTextStderrRecorder :: MonadIO m => m (Recorder Text) +makeThreadSafeTextStderrRecorder = liftIO threadSafeTextStderrRecorder + +withTextFileRecorder :: MonadUnliftIO m => FilePath -> (Recorder Text -> m a) -> m a +withTextFileRecorder path action = withFile path AppendMode $ \handle -> + action (textHandleRecorder handle) + +-- | if no file path given use stderr, else use stderr and file +withDefaultTextRecorder :: MonadUnliftIO m => Maybe FilePath -> (Recorder Text -> m a) -> m a +withDefaultTextRecorder path action = do + textStderrRecorder <- makeThreadSafeTextStderrRecorder + case path of + Nothing -> action textStderrRecorder + Just path -> withTextFileRecorder path $ \textFileRecorder -> + action (textStderrRecorder <> textFileRecorder) + +withDefaultTextWithPriorityRecorder :: MonadUnliftIO m => Maybe FilePath -> (Recorder (WithPriority Text) -> m a) -> m a +withDefaultTextWithPriorityRecorder path action = do + withDefaultTextRecorder path $ \textRecorder -> + action (cmapIO textWithPriorityToText textRecorder) + +textWithPriorityToText :: WithPriority Text -> IO Text +textWithPriorityToText = \case + WithPriority{ priority, payload } -> do + threadId <- myThreadId + utcTime <- getCurrentTime + pure $ Text.intercalate " | " + [ utcTimeToText utcTime + -- , callStackToLocationText callStack + , threadIdToText threadId + -- , priorityToText priority + , payload ] + where + utcTimeToText utcTime = Text.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime + + threadIdToText = Text.pack . show + + callStackToLocationText callStack = srcLocText + where + srcLocText = + case getCallStack callStack of + [] -> "unknown" + [(_name, srcLoc)] -> srcLocToText srcLoc + (_, srcLoc) : (_callerName, _) : _ -> srcLocToText srcLoc + + srcLocToText SrcLoc{srcLocModule, srcLocStartLine} = + Text.pack srcLocModule <> ":" <> Text.pack (show srcLocStartLine) + + priorityToText :: Priority -> Text + priorityToText = Text.pack . show + + diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index e4b7cec41e..71f6ad9b9b 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -7,7 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -module Ide.Main(defaultMain, runLspMode) where +module Ide.Main(defaultMain, runLspMode, Log) where import Control.Monad.Extra import qualified Data.Aeson.Encode.Pretty as A @@ -19,7 +19,7 @@ import Development.IDE.Core.Rules import Development.IDE.Core.Tracing (withTelemetryLogger) import Development.IDE.Graph (ShakeOptions (shakeThreads)) import Development.IDE.Main (isLSP) -import qualified Development.IDE.Main as Main +import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Session as Session import Development.IDE.Types.Logger as G import qualified Development.IDE.Types.Options as Ghcide @@ -35,8 +35,19 @@ import qualified System.Directory.Extra as IO import System.IO import qualified System.Log.Logger as L -defaultMain :: Arguments -> IdePlugins IdeState -> IO () -defaultMain args idePlugins = do +data Log + = LogVersion !String + | LogDirectory !FilePath + | LogLsp !GhcideArguments ![PluginId] + -- hPutStrLn stderr "Starting (haskell-language-server)LSP server..." + -- hPutStrLn stderr $ " with arguments: " <> show ghcideArgs + -- hPutStrLn stderr $ " with plugins: " <> show (map fst $ ipMap idePlugins) + -- hPutStrLn stderr $ " in directory: " <> dir + | LogIDEMain IDEMain.Log + deriving Show + +defaultMain :: Recorder Log -> Arguments -> IdePlugins IdeState -> IO () +defaultMain recorder args idePlugins = do -- WARNING: If you write to stdout before runLanguageServer -- then the language server will not work @@ -68,8 +79,8 @@ defaultMain args idePlugins = do Ghcide ghcideArgs -> do {- see WARNING above -} - hPutStrLn stderr hlsVer - runLspMode ghcideArgs idePlugins + logWith recorder $ LogVersion hlsVer + runLspMode recorder ghcideArgs idePlugins VSCodeExtensionSchemaMode -> do LBS.putStrLn $ A.encodePretty $ pluginsToVSCodeExtensionSchema idePlugins @@ -90,25 +101,24 @@ hlsLogger = G.Logger $ \pri txt -> -- --------------------------------------------------------------------- -runLspMode :: GhcideArguments -> IdePlugins IdeState -> IO () -runLspMode ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLogger $ \telemetryLogger -> do +runLspMode :: Recorder Log -> GhcideArguments -> IdePlugins IdeState -> IO () +runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLogger $ \telemetryLogger -> do + let log = logWith recorder whenJust argsCwd IO.setCurrentDirectory dir <- IO.getCurrentDirectory + log $ LogDirectory dir LSP.setupLogger argsLogFile ["hls", "hie-bios"] $ if argsDebugOn then L.DEBUG else L.INFO when (isLSP argsCommand) $ do - hPutStrLn stderr "Starting (haskell-language-server)LSP server..." - hPutStrLn stderr $ " with arguments: " <> show ghcideArgs - hPutStrLn stderr $ " with plugins: " <> show (map fst $ ipMap idePlugins) - hPutStrLn stderr $ " in directory: " <> dir - - Main.defaultMain def - { Main.argCommand = argsCommand - , Main.argsHlsPlugins = idePlugins - , Main.argsLogger = pure hlsLogger <> pure telemetryLogger - , Main.argsThreads = if argsThreads == 0 then Nothing else Just $ fromIntegral argsThreads - , Main.argsIdeOptions = \_config sessionLoader -> + log $ LogLsp ghcideArgs (map fst $ ipMap idePlugins) + + IDEMain.defaultMain (cmap LogIDEMain recorder) (IDEMain.defaultArguments (cmap LogIDEMain recorder) Info) + { IDEMain.argCommand = argsCommand + , IDEMain.argsHlsPlugins = idePlugins + , IDEMain.argsLogger = pure hlsLogger <> pure telemetryLogger + , IDEMain.argsThreads = if argsThreads == 0 then Nothing else Just $ fromIntegral argsThreads + , IDEMain.argsIdeOptions = \_config sessionLoader -> let defOptions = Ghcide.defaultIdeOptions sessionLoader in defOptions { Ghcide.optShakeProfiling = argsShakeProfiling From bb2c6a23d4cb17463ca4c842575893b69fa37901 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Thu, 6 Jan 2022 01:44:13 -0500 Subject: [PATCH 02/43] convert Session to contravariant logging style --- .../session-loader/Development/IDE/Session.hs | 190 +++++++++++------- .../src/Development/IDE/LSP/LanguageServer.hs | 44 ++-- ghcide/src/Development/IDE/Main.hs | 27 +-- 3 files changed, 165 insertions(+), 96 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index bf93c060cc..01a1b85fd9 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} {-| The logic for setting up a ghcide session by tapping into hie-bios. @@ -14,6 +15,7 @@ module Development.IDE.Session ,runWithDb ,retryOnSqliteBusy ,retryOnException + ,Log ) where -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses @@ -44,7 +46,7 @@ import qualified Data.Text as T import Data.Time.Clock import Data.Version import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake hiding (withHieDb) +import Development.IDE.Core.Shake hiding (Log, withHieDb) import qualified Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile, TargetModule, @@ -60,7 +62,8 @@ import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq, newHscEnvEqPreserveImportPaths) import Development.IDE.Types.Location -import Development.IDE.Types.Logger +import Development.IDE.Types.Logger (Priority (Debug), + Recorder, logWith) import Development.IDE.Types.Options import GHC.Check import qualified HIE.Bios as HieBios @@ -82,6 +85,8 @@ import Control.Concurrent.STM.Stats (atomically, modifyTVar', readTVar, writeTVar) import Control.Concurrent.STM.TQueue import Data.Foldable (for_) +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) import qualified Data.HashSet as Set import Database.SQLite.Simple import Development.IDE.Core.Tracing (withTrace) @@ -92,6 +97,57 @@ import HieDb.Utils import System.Random (RandomGen) import qualified System.Random as Random +data Log + = LogSetInitialDynFlags !(Cradle Void) + -- logDebug logger $ T.pack $ "setInitialDynFlags cradle: " ++ show cradle + | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void) + -- hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,rootDir,hieYaml,cradle) + | LogGetInitialGhcLibDirDefaultCradleNone + -- hPutStrLn stderr "Couldn't load cradle (CradleNone)" + | LogHieDbRetry !Int !Int !Int !SomeException + -- logWarning logger $ "Retrying - " <> makeLogMsgComponentsText (Right delay) newMaxRetryCount e + | LogHieDbRetriesExhausted !Int !Int !Int !SomeException + -- logWarning logger $ "Retries exhausted - " <> makeLogMsgComponentsText (Left baseDelay) maxRetryCount e + -- -- e.g. delay: 1010102, maximumDelay: 12010, maxRetryCount: 9, exception: SQLError { ... } + -- makeLogMsgComponentsText delay newMaxRetryCount e = + -- let + -- logMsgComponents = + -- [ either + -- (("base delay: " <>) . T.pack . show) + -- (("delay: " <>) . T.pack . show) + -- delay + -- , "maximumDelay: " <> T.pack (show maxDelay) + -- , "maxRetryCount: " <> T.pack (show newMaxRetryCount) + -- , "exception: " <> T.pack (show e)] + -- in + -- T.intercalate ", " logMsgComponents + | LogWorkerSQLiteError !SQLError + -- logDebug logger $ T.pack $ "SQLite error in worker, ignoring: " ++ show e + | LogWorkerException !SomeException + -- logDebug logger $ T.pack $ "Uncaught error in database worker, ignoring: " ++ show e + | LogInterfaceFilesCacheDir !FilePath + -- liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack (fromMaybe cacheDir hiCacheDir) + | LogKnownFilesUpdated !(HashMap Target (HashSet FilePath)) + -- logDebug logger $ "Known files updated: " <> + -- T.pack(show $ (HM.map . Set.map) fromNormalizedFilePath x) + | LogUnitIdsBeforeNewHscEnv ![UnitId] + -- logInfo logger (T.pack ("Making new HscEnv" ++ show inplace)) + | LogDLLLoadError !String + -- logDebug logger $ T.pack $ + -- "Error dynamically loading libm.so.6:\n" <> err + | LogConsultCradlePath !FilePath + -- logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp) + | LogCradleNotFound !FilePath + -- logWarning logger $ implicitCradleWarning lfp + | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath)) + -- logDebug logger $ T.pack ("Session loading result: " <> show eopts) + | forall a. Show a => LogCradle !(Cradle a) + -- logDebug logger $ T.pack $ "Output from setting up the cradle " <> show cradle + | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) + -- logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res)) + +deriving instance Show Log + -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String hiedbDataVersion = "1" @@ -110,7 +166,7 @@ data SessionLoadingOptions = SessionLoadingOptions -- or 'Nothing' to respect the cradle setting , getCacheDirs :: String -> [String] -> IO CacheDirs -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' - , getInitialGhcLibDir :: Logger -> FilePath -> IO (Maybe LibDir) + , getInitialGhcLibDir :: Recorder Log -> FilePath -> IO (Maybe LibDir) , fakeUid :: UnitId -- ^ unit id used to tag the internal component built by ghcide -- To reuse external interface files the unit ids must match, @@ -119,7 +175,7 @@ data SessionLoadingOptions = SessionLoadingOptions } instance Default SessionLoadingOptions where - def = SessionLoadingOptions + def = SessionLoadingOptions {findCradle = HieBios.findCradle ,loadCradle = loadWithImplicitCradle ,getCacheDirs = getCacheDirsDefault @@ -148,25 +204,26 @@ loadWithImplicitCradle mHieYaml rootDir = do Just yaml -> HieBios.loadCradle yaml Nothing -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir -getInitialGhcLibDirDefault :: Logger -> FilePath -> IO (Maybe LibDir) -getInitialGhcLibDirDefault logger rootDir = do +getInitialGhcLibDirDefault :: Recorder Log -> FilePath -> IO (Maybe LibDir) +getInitialGhcLibDirDefault recorder rootDir = do + let log = logWith recorder hieYaml <- findCradle def rootDir cradle <- loadCradle def hieYaml rootDir - logDebug logger $ T.pack $ "setInitialDynFlags cradle: " ++ show cradle + log $ LogSetInitialDynFlags cradle libDirRes <- getRuntimeGhcLibDir cradle case libDirRes of CradleSuccess libdir -> pure $ Just $ LibDir libdir CradleFail err -> do - hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,rootDir,hieYaml,cradle) + log $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle pure Nothing CradleNone -> do - hPutStrLn stderr "Couldn't load cradle (CradleNone)" + log LogGetInitialGhcLibDirDefaultCradleNone pure Nothing -- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir -setInitialDynFlags :: Logger -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir) -setInitialDynFlags logger rootDir SessionLoadingOptions{..} = do - libdir <- getInitialGhcLibDir logger rootDir +setInitialDynFlags :: Recorder Log -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir) +setInitialDynFlags recorder rootDir SessionLoadingOptions{..} = do + libdir <- getInitialGhcLibDir recorder rootDir dynFlags <- mapM dynFlagsForPrinting libdir mapM_ setUnsafeGlobalDynFlags dynFlags pure libdir @@ -180,14 +237,14 @@ setInitialDynFlags logger rootDir SessionLoadingOptions{..} = do retryOnException :: (MonadIO m, MonadCatch m, RandomGen g, Exception e) => (e -> Maybe e) -- ^ only retry on exception if this predicate returns Just - -> Logger + -> Recorder Log -> Int -- ^ maximum backoff delay in microseconds -> Int -- ^ base backoff delay in microseconds -> Int -- ^ maximum number of times to retry -> g -- ^ random number generator -> m a -- ^ action that may throw exception -> m a -retryOnException exceptionPred logger maxDelay !baseDelay !maxRetryCount rng action = do +retryOnException exceptionPred recorder maxDelay !baseDelay !maxRetryCount rng action = do result <- tryJust exceptionPred action case result of Left e @@ -197,30 +254,18 @@ retryOnException exceptionPred logger maxDelay !baseDelay !maxRetryCount rng act let (delay, newRng) = Random.randomR (0, newBaseDelay) rng let newMaxRetryCount = maxRetryCount - 1 liftIO $ do - logWarning logger $ "Retrying - " <> makeLogMsgComponentsText (Right delay) newMaxRetryCount e + log $ LogHieDbRetry delay maxDelay newMaxRetryCount (toException e) threadDelay delay - retryOnException exceptionPred logger maxDelay newBaseDelay newMaxRetryCount newRng action + retryOnException exceptionPred recorder maxDelay newBaseDelay newMaxRetryCount newRng action | otherwise -> do liftIO $ do - logWarning logger $ "Retries exhausted - " <> makeLogMsgComponentsText (Left baseDelay) maxRetryCount e + log $ LogHieDbRetriesExhausted baseDelay maxDelay maxRetryCount (toException e) throwIO e Right b -> pure b where - -- e.g. delay: 1010102, maximumDelay: 12010, maxRetryCount: 9, exception: SQLError { ... } - makeLogMsgComponentsText delay newMaxRetryCount e = - let - logMsgComponents = - [ either - (("base delay: " <>) . T.pack . show) - (("delay: " <>) . T.pack . show) - delay - , "maximumDelay: " <> T.pack (show maxDelay) - , "maxRetryCount: " <> T.pack (show newMaxRetryCount) - , "exception: " <> T.pack (show e)] - in - T.intercalate ", " logMsgComponents + log = logWith recorder -- | in microseconds oneSecond :: Int @@ -235,30 +280,30 @@ maxRetryCount :: Int maxRetryCount = 10 retryOnSqliteBusy :: (MonadIO m, MonadCatch m, RandomGen g) - => Logger -> g -> m a -> m a -retryOnSqliteBusy logger rng action = + => Recorder Log -> g -> m a -> m a +retryOnSqliteBusy recorder rng action = let isErrorBusy e | SQLError{ sqlError = ErrorBusy } <- e = Just e | otherwise = Nothing in - retryOnException isErrorBusy logger oneSecond oneMillisecond maxRetryCount rng action + retryOnException isErrorBusy recorder oneSecond oneMillisecond maxRetryCount rng action -makeWithHieDbRetryable :: RandomGen g => Logger -> g -> HieDb -> WithHieDb -makeWithHieDbRetryable logger rng hieDb f = - retryOnSqliteBusy logger rng (f hieDb) +makeWithHieDbRetryable :: RandomGen g => Recorder Log -> g -> HieDb -> WithHieDb +makeWithHieDbRetryable recorder rng hieDb f = + retryOnSqliteBusy recorder rng (f hieDb) -- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for -- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial -- by a worker thread using a dedicated database connection. -- This is done in order to serialize writes to the database, or else SQLite becomes unhappy -runWithDb :: Logger -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO () -runWithDb logger fp k = do +runWithDb :: Recorder Log -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO () +runWithDb recorder fp k = do -- use non-deterministic seed because maybe multiple HLS start at same time -- and send bursts of requests rng <- Random.newStdGen -- Delete the database if it has an incompatible schema version retryOnSqliteBusy - logger + recorder rng (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp) @@ -267,14 +312,16 @@ runWithDb logger fp k = do -- e.g. `withWriteDbRetrable initConn` without type signature will -- instantiate tyvar `a` to `()` let withWriteDbRetryable :: WithHieDb - withWriteDbRetryable = makeWithHieDbRetryable logger rng writedb + withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb withWriteDbRetryable initConn chan <- newTQueueIO withAsync (writerThread withWriteDbRetryable chan) $ \_ -> do - withHieDb fp (\readDb -> k (makeWithHieDbRetryable logger rng readDb) chan) + withHieDb fp (\readDb -> k (makeWithHieDbRetryable recorder rng readDb) chan) where + log = logWith recorder + writerThread :: WithHieDb -> IndexQueue -> IO () writerThread withHieDbRetryable chan = do -- Clear the index of any files that might have been deleted since the last run @@ -282,11 +329,12 @@ runWithDb logger fp k = do _ <- withHieDbRetryable garbageCollectTypeNames forever $ do k <- atomically $ readTQueue chan + -- TODO: probably should let exceptions be caught/logged/handled by top level handler k withHieDbRetryable `Safe.catch` \e@SQLError{} -> do - logDebug logger $ T.pack $ "SQLite error in worker, ignoring: " ++ show e + log $ LogWorkerSQLiteError e `Safe.catchAny` \e -> do - logDebug logger $ T.pack $ "Uncaught error in database worker, ignoring: " ++ show e + log $ LogWorkerException e getHieDbLoc :: FilePath -> IO FilePath @@ -310,11 +358,11 @@ getHieDbLoc dir = do -- This is the key function which implements multi-component support. All -- components mapping to the same hie.yaml file are mapped to the same -- HscEnv which is updated as new components are discovered. -loadSession :: FilePath -> IO (Action IdeGhcSession) -loadSession = loadSessionWithOptions def +loadSession :: Recorder Log -> FilePath -> IO (Action IdeGhcSession) +loadSession recorder = loadSessionWithOptions recorder def -loadSessionWithOptions :: SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) -loadSessionWithOptions SessionLoadingOptions{..} dir = do +loadSessionWithOptions :: Recorder Log -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) +loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) -- Mapping from a Filepath to HscEnv @@ -371,8 +419,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do logDirtyKeys <- recordDirtyKeys extras GetKnownTargets [emptyFilePath] return (logDirtyKeys >> pure hasUpdate) for_ hasUpdate $ \x -> - logDebug logger $ "Known files updated: " <> - T.pack(show $ (HM.map . Set.map) fromNormalizedFilePath x) + logWith recorder $ LogKnownFilesUpdated ((HM.map . Set.map) fromNormalizedFilePath x) -- Create a new HscEnv from a hieYaml root and a set of options -- If the hieYaml file already has an HscEnv, the new component is @@ -412,7 +459,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do let hscComponents = sort $ map show uids cacheDirOpts = hscComponents ++ componentOptions opts cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts - processed_df <- setCacheDirs logger cacheDirs df2 + processed_df <- setCacheDirs recorder cacheDirs df2 -- The final component information, mostly the same but the DynFlags don't -- contain any packages which are also loaded -- into the same component. @@ -427,7 +474,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do -- scratch again (for now) -- It's important to keep the same NameCache though for reasons -- that I do not fully understand - logInfo logger (T.pack ("Making new HscEnv" ++ show inplace)) + log $ LogUnitIdsBeforeNewHscEnv inplace hscEnv <- emptyHscEnv ideNc libDir newHscEnv <- -- Add the options for the current component to the HscEnv @@ -463,9 +510,9 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do initObjLinker hscEnv res <- loadDLL hscEnv "libm.so.6" case res of - Nothing -> pure () - Just err -> logDebug logger $ T.pack $ - "Error dynamically loading libm.so.6:\n" <> err + Nothing -> pure () + Just err -> log $ LogDLLLoadError err + -- Make a map from unit-id to DynFlags, this is used when trying to -- resolve imports. (especially PackageImports) @@ -476,7 +523,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do -- New HscEnv for the component in question, returns the new HscEnvEq and -- a mapping from FilePath to the newly created HscEnvEq. - let new_cache = newComponentCache logger optExtensions hieYaml _cfp hscEnv uids + let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv uids (cs, res) <- new_cache new -- Modified cache targets for everything else in the hie.yaml file -- which now uses the same EPS and so on @@ -513,10 +560,10 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do lfp <- flip makeRelative cfp <$> getCurrentDirectory - logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp) + log $ LogConsultCradlePath lfp when (isNothing hieYaml) $ - logWarning logger $ implicitCradleWarning lfp + log $ LogCradleNotFound lfp cradle <- loadCradle hieYaml dir lfp <- flip makeRelative cfp <$> getCurrentDirectory @@ -530,12 +577,11 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfp - res <- cradleToOptsAndLibDir logger cradle cfp + res <- cradleToOptsAndLibDir recorder cradle cfp addTag "result" (show res) return res - - logDebug logger $ T.pack ("Session loading result: " <> show eopts) + log $ LogSessionLoadingResult eopts case eopts of -- The cradle gave us some options so get to work turning them -- into and HscEnv. @@ -598,16 +644,18 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do as <- async $ getOptions file return (as, wait as) pure opts + where + log = logWith recorder -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the -- GHC options/dynflags needed for the session and the GHC library directory -cradleToOptsAndLibDir :: Show a => Logger -> Cradle a -> FilePath +cradleToOptsAndLibDir :: Show a => Recorder Log -> Cradle a -> FilePath -> IO (Either [CradleError] (ComponentOptions, FilePath)) -cradleToOptsAndLibDir logger cradle file = do +cradleToOptsAndLibDir recorder cradle file = do -- Start off by getting the session options - logDebug logger $ T.pack $ "Output from setting up the cradle " <> show cradle + logWith recorder $ LogCradle cradle cradleRes <- HieBios.getCompilerOptions file cradle case cradleRes of CradleSuccess r -> do @@ -672,7 +720,7 @@ setNameCache nc hsc = hsc { hsc_NC = nc } -- | Create a mapping from FilePaths to HscEnvEqs newComponentCache - :: Logger + :: Recorder Log -> [String] -- File extensions to consider -> Maybe FilePath -- Path to cradle -> NormalizedFilePath -- Path to file that caused the creation of this component @@ -680,7 +728,7 @@ newComponentCache -> [(UnitId, DynFlags)] -> ComponentInfo -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo)) -newComponentCache logger exts cradlePath cfp hsc_env uids ci = do +newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do let df = componentDynFlags ci let hscEnv' = hscSetFlags df hsc_env { hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } @@ -690,7 +738,7 @@ newComponentCache logger exts cradlePath cfp hsc_env uids ci = do let targetEnv = ([], Just henv) targetDepends = componentDependencyInfo ci res = (targetEnv, targetDepends) - logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res)) + logWith recorder $ LogNewComponentCache res let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends ctargets <- concatMapM mk (componentTargets ci) @@ -758,9 +806,9 @@ should be filtered out, such that we dont have to re-compile everything. -- | Set the cache-directory based on the ComponentOptions and a list of -- internal packages. -- For the exact reason, see Note [Avoiding bad interface files]. -setCacheDirs :: MonadIO m => Logger -> CacheDirs -> DynFlags -> m DynFlags -setCacheDirs logger CacheDirs{..} dflags = do - liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack (fromMaybe cacheDir hiCacheDir) +setCacheDirs :: MonadIO m => Recorder Log -> CacheDirs -> DynFlags -> m DynFlags +setCacheDirs recorder CacheDirs{..} dflags = do + logWith recorder $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir) pure $ dflags & maybe id setHiDir hiCacheDir & maybe id setHieDir hieCacheDir diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index f3e4f4d9e8..73a746c92a 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -10,6 +10,7 @@ -- This version removes the daml: handling module Development.IDE.LSP.LanguageServer ( runLanguageServer + , Log ) where import Control.Concurrent.STM @@ -33,15 +34,32 @@ import UnliftIO.Exception import Development.IDE.Core.FileStore import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.Shake +import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing import Development.IDE.LSP.HoverDefinition import Development.IDE.Types.Logger import Control.Monad.IO.Unlift (MonadUnliftIO) +import qualified Development.IDE.Session as Session import Development.IDE.Types.Shake (WithHieDb) import System.IO.Unsafe (unsafeInterleaveIO) +data Log + = LogRegisterIdeConfig !IdeConfiguration + -- logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig + | LogHandleServerException !SomeException + -- logError logger $ T.pack $ "Fatal error in server thread: " <> show e + | LogExceptionInHandler !SomeException + -- logError logger $ T.pack $ + -- "Unexpected exception, please report!\n" ++ + -- "Exception: " ++ show e + | LogReactorThreadStopped + -- logInfo logger "Reactor thread stopped" + | LogCancelledRequest !SomeLspId + -- logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id + | LogSession Session.Log + deriving Show + issueTrackerUrl :: T.Text issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues" @@ -50,7 +68,8 @@ newtype WithHieDbShield = WithHieDbShield WithHieDb runLanguageServer :: forall config. (Show config) - => LSP.Options + => Recorder Log + -> LSP.Options -> Handle -- input -> Handle -- output -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project @@ -59,7 +78,7 @@ runLanguageServer -> LSP.Handlers (ServerM config) -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) -> IO () -runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do +runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do -- This MVar becomes full when the server thread exits or we receive exit message from client. -- LSP server will be canceled when it's full. @@ -128,6 +147,9 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan serverDefinition where + log :: Log -> IO () + log = logWith recorder + handleInit :: MVar () -> IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) @@ -145,12 +167,12 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan ide <- getIdeState env (makeLSPVFSHandle env) root withHieDb hieChan let initConfig = parseConfiguration params - logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig + + log $ LogRegisterIdeConfig initConfig registerIdeConfiguration (shakeExtras ide) initConfig let handleServerException (Left e) = do - logError logger $ - T.pack $ "Fatal error in server thread: " <> show e + log $ LogHandleServerException e sendErrorMessage e exitClientMsg handleServerException (Right _) = pure () @@ -163,9 +185,7 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan ] exceptionInHandler e = do - logError logger $ T.pack $ - "Unexpected exception, please report!\n" ++ - "Exception: " ++ show e + log $ LogExceptionInHandler e sendErrorMessage e logger = ideLogger ide @@ -180,14 +200,14 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan cancelOrRes <- race (waitForCancel _id) act case cancelOrRes of Left () -> do - logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id + log $ LogCancelledRequest _id k $ ResponseError RequestCancelled "" Nothing Right res -> pure res ) $ \(e :: SomeException) -> do exceptionInHandler e k $ ResponseError InternalError (T.pack $ show e) Nothing _ <- flip forkFinally handleServerException $ do - untilMVar lifetime $ runWithDb logger dbLoc $ \withHieDb hieChan -> do + untilMVar lifetime $ runWithDb (cmap LogSession recorder) dbLoc $ \withHieDb hieChan -> do putMVar dbMVar (WithHieDbShield withHieDb,hieChan) forever $ do msg <- readChan clientMsgChan @@ -196,7 +216,7 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan case msg of ReactorNotification act -> handle exceptionInHandler act ReactorRequest _id act k -> void $ async $ checkCancelled _id act k - logInfo logger "Reactor thread stopped" + log LogReactorThreadStopped pure $ Right (env,ide) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 778803a181..d49a1c4df8 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -60,6 +60,7 @@ import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Core.Tracing (measureMemory) import Development.IDE.Graph (action) import Development.IDE.LSP.LanguageServer (runLanguageServer) +import qualified Development.IDE.LSP.LanguageServer as LanguageServer import Development.IDE.Main.HeapStats (withHeapStats) import qualified Development.IDE.Main.HeapStats as HeapStats import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) @@ -72,13 +73,11 @@ import Development.IDE.Session (SessionLoadingOptions, retryOnSqliteBusy, runWithDb, setInitialDynFlags) +import qualified Development.IDE.Session as Session import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath') import Development.IDE.Types.Logger (Logger (Logger), - Priority (Info), - Recorder (Recorder), - cmap, logDebug, logInfo, - logWith) + Recorder, cmap, logWith) import Development.IDE.Types.Options (IdeGhcSession, IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), IdeTesting (IdeTesting), @@ -272,6 +271,8 @@ data Log | LogService Service.Log | LogShake Shake.Log | LogGhcide Ghcide.Log + | LogLanguageServer LanguageServer.Log + | LogSession Session.Log deriving Show defaultMain :: Recorder Log -> Arguments -> IO () @@ -308,7 +309,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmap LogHeapStats recorder) t <- offsetTime log LogLspStart - runLanguageServer options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath withHieDb hieChan -> do + runLanguageServer (cmap LogLanguageServer recorder) options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath withHieDb hieChan -> do traverse_ IO.setCurrentDirectory rootPath t <- t log $ LogLspStartDuration t @@ -318,11 +319,11 @@ defaultMain recorder Arguments{..} = withHeapStats (cmap LogHeapStats recorder) -- We want to set the global DynFlags right now, so that we can use -- `unsafeGlobalDynFlags` even before the project is configured _mlibdir <- - setInitialDynFlags logger dir argsSessionLoadingOptions + setInitialDynFlags (cmap LogSession recorder) dir argsSessionLoadingOptions -- TODO: should probably catch/log/rethrow at top level instead `catchAny` (\e -> log (LogSetInitialDynFlagsException e) >> pure Nothing) - sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir + sessionLoader <- loadSessionWithOptions (cmap LogSession recorder) argsSessionLoadingOptions dir config <- LSP.runLspT env LSP.getConfig let def_options = argsIdeOptions config sessionLoader @@ -354,7 +355,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmap LogHeapStats recorder) Check argFiles -> do dir <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc dir - runWithDb logger dbLoc $ \hiedb hieChan -> do + runWithDb (cmap LogSession recorder) dbLoc $ \hiedb hieChan -> do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error hSetEncoding stdout utf8 hSetEncoding stderr utf8 @@ -376,7 +377,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmap LogHeapStats recorder) when (n > 0) $ putStrLn $ " (" ++ intercalate ", " (catMaybes ucradles) ++ ")" putStrLn "\nStep 3/4: Initializing the IDE" vfs <- makeVFSHandle - sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir + sessionLoader <- loadSessionWithOptions (cmap LogSession recorder) argsSessionLoadingOptions dir let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader options = def_options { optCheckParents = pure NeverCheck @@ -419,18 +420,18 @@ defaultMain recorder Arguments{..} = withHeapStats (cmap LogHeapStats recorder) root <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc root hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc - mlibdir <- setInitialDynFlags logger root def + mlibdir <- setInitialDynFlags (cmap LogSession recorder) root def rng <- newStdGen case mlibdir of Nothing -> exitWith $ ExitFailure 1 - Just libdir -> retryOnSqliteBusy logger rng (HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd) + Just libdir -> retryOnSqliteBusy (cmap LogSession recorder) rng (HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd) Custom (IdeCommand c) -> do root <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc root - runWithDb logger dbLoc $ \hiedb hieChan -> do + runWithDb (cmap LogSession recorder) dbLoc $ \hiedb hieChan -> do vfs <- makeVFSHandle - sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "." + sessionLoader <- loadSessionWithOptions (cmap LogSession recorder) argsSessionLoadingOptions "." let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader options = def_options { optCheckParents = pure NeverCheck From 235b87d44a2892000aee7324064dc7c1a6a43a95 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Thu, 6 Jan 2022 02:18:55 -0500 Subject: [PATCH 03/43] convert Plugin/HLS and FireStore to contravariant logging style --- ghcide/src/Development/IDE/Core/FileStore.hs | 41 ++++++++++++------- .../src/Development/IDE/LSP/LanguageServer.hs | 4 +- .../src/Development/IDE/LSP/Notifications.hs | 8 ++-- ghcide/src/Development/IDE/Main.hs | 4 +- ghcide/src/Development/IDE/Plugin/HLS.hs | 20 +++++---- 5 files changed, 48 insertions(+), 29 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index f6f93d3c02..a9ca0aba4d 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -21,7 +21,8 @@ module Development.IDE.Core.FileStore( getFileContentsImpl, getModTime, isWatchSupported, - registerFileWatches + registerFileWatches, + Log ) where import Control.Concurrent.STM.Stats (STM, atomically, @@ -40,7 +41,7 @@ import qualified Data.Text as T import Data.Time import Data.Time.Clock.POSIX import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake +import Development.IDE.Core.Shake hiding (Log) import Development.IDE.GHC.Orphans () import Development.IDE.Graph import Development.IDE.Import.DependencyInformation @@ -67,6 +68,8 @@ import qualified Data.HashSet as HSet import Data.List (foldl') import qualified Data.Text as Text import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) +import Development.IDE.Types.Logger (Recorder, + logWith) import Language.LSP.Server hiding (getVirtualFile) import qualified Language.LSP.Server as LSP @@ -80,6 +83,15 @@ import qualified Language.LSP.Types.Capabilities as LSP import Language.LSP.VFS import System.FilePath +data Log + = LogCouldNotIdentifyReverseDeps !NormalizedFilePath + -- log = L.logInfo logger . T.pack + -- liftIO $ log $ "Could not identify reverse dependencies for " ++ show nfp + | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath]) + -- liftIO $ (log $ "Typechecking reverse dependencies for " ++ show nfp ++ ": " ++ show revs) + -- `catch` \(e :: SomeException) -> log (show e) + deriving Show + makeVFSHandle :: IO VFSHandle makeVFSHandle = do vfsVar <- newVar (1, Map.empty) @@ -249,11 +261,12 @@ fileStoreRules vfs isWatched = do -- | Note that some buffer for a specific file has been modified but not -- with what changes. -setFileModified :: IdeState +setFileModified :: Recorder Log + -> IdeState -> Bool -- ^ Was the file saved? -> NormalizedFilePath -> IO () -setFileModified state saved nfp = do +setFileModified recorder state saved nfp = do ideOptions <- getIdeOptionsIO $ shakeExtras state doCheckParents <- optCheckParents ideOptions let checkParents = case doCheckParents of @@ -266,22 +279,20 @@ setFileModified state saved nfp = do join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp] restartShakeSession (shakeExtras state) (fromNormalizedFilePath nfp ++ " (modified)") [] when checkParents $ - typecheckParents state nfp + typecheckParents recorder state nfp -typecheckParents :: IdeState -> NormalizedFilePath -> IO () -typecheckParents state nfp = void $ shakeEnqueue (shakeExtras state) parents - where parents = mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction nfp) +typecheckParents :: Recorder Log -> IdeState -> NormalizedFilePath -> IO () +typecheckParents recorder state nfp = void $ shakeEnqueue (shakeExtras state) parents + where parents = mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) -typecheckParentsAction :: NormalizedFilePath -> Action () -typecheckParentsAction nfp = do +typecheckParentsAction :: Recorder Log -> NormalizedFilePath -> Action () +typecheckParentsAction recorder nfp = do revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph - logger <- logger <$> getShakeExtras - let log = L.logInfo logger . T.pack + let log = logWith recorder case revs of - Nothing -> liftIO $ log $ "Could not identify reverse dependencies for " ++ show nfp + Nothing -> log $ LogCouldNotIdentifyReverseDeps nfp Just rs -> do - liftIO $ (log $ "Typechecking reverse dependencies for " ++ show nfp ++ ": " ++ show revs) - `catch` \(e :: SomeException) -> log (show e) + log $ LogTypeCheckingReverseDeps nfp revs void $ uses GetModIface rs -- | Note that some keys have been modified and restart the session diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 73a746c92a..76360e3b05 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -32,7 +32,7 @@ import UnliftIO.Concurrent import UnliftIO.Directory import UnliftIO.Exception -import Development.IDE.Core.FileStore +import Development.IDE.Core.FileStore hiding (Log) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing @@ -188,8 +188,6 @@ runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigur log $ LogExceptionInHandler e sendErrorMessage e - logger = ideLogger ide - checkCancelled _id act k = flip finally (clearReqId _id) $ catch (do diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 77f810f565..01d5d888a2 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -27,6 +27,7 @@ import Development.IDE.Core.FileStore (registerFileWatches, resetFileStore, setFileModified, setSomethingModified) +import qualified Development.IDE.Core.FileStore as FileStore import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.OfInterest import Development.IDE.Core.RuleTypes (GetClientSettings (..)) @@ -40,6 +41,7 @@ import Ide.Types data Log = LogShake Shake.Log + | LogFileStore FileStore.Log deriving Show whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () @@ -54,7 +56,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHa -- We don't know if the file actually exists, or if the contents match those on disk -- For example, vscode restores previously unsaved contents on open addFileOfInterest ide file Modified{firstOpen=True} - setFileModified ide False file + setFileModified (cmap LogFileStore recorder) ide False file logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri , mkPluginNotificationHandler LSP.STextDocumentDidChange $ @@ -62,14 +64,14 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHa atomically $ updatePositionMapping ide identifier changes whenUriFile _uri $ \file -> do addFileOfInterest ide file Modified{firstOpen=False} - setFileModified ide False file + setFileModified (cmap LogFileStore recorder) ide False file logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri , mkPluginNotificationHandler LSP.STextDocumentDidSave $ \ide _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do addFileOfInterest ide file OnDisk - setFileModified ide True file + setFileModified (cmap LogFileStore recorder) ide True file logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri , mkPluginNotificationHandler LSP.STextDocumentDidClose $ diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index d49a1c4df8..a914f53c61 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -65,6 +65,7 @@ import Development.IDE.Main.HeapStats (withHeapStats) import qualified Development.IDE.Main.HeapStats as HeapStats import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) import Development.IDE.Plugin.HLS (asGhcIdePlugin) +import qualified Development.IDE.Plugin.HLS as PluginHLS import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Session (SessionLoadingOptions, @@ -273,6 +274,7 @@ data Log | LogGhcide Ghcide.Log | LogLanguageServer LanguageServer.Log | LogSession Session.Log + | LogPluginHLS PluginHLS.Log deriving Show defaultMain :: Recorder Log -> Arguments -> IO () @@ -287,7 +289,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmap LogHeapStats recorder) logger <- argsLogger hSetBuffering stderr LineBuffering - let hlsPlugin = asGhcIdePlugin argsHlsPlugins + let hlsPlugin = asGhcIdePlugin (cmap LogPluginHLS recorder) argsHlsPlugins hlsCommands = allLspCmdIds' pid argsHlsPlugins plugins = hlsPlugin <> argsGhcidePlugin options = argsLspOptions { LSP.executeCommandCommands = LSP.executeCommandCommands argsLspOptions <> Just hlsCommands } diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 842b69b530..7ebd9ce8e7 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -6,6 +6,7 @@ module Development.IDE.Plugin.HLS ( asGhcIdePlugin + , Log ) where import Control.Exception (SomeException) @@ -22,7 +23,7 @@ import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) import qualified Data.Map as Map import Data.String import qualified Data.Text as T -import Development.IDE.Core.Shake +import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing import Development.IDE.Graph (Rules) import Development.IDE.LSP.Server @@ -43,13 +44,18 @@ import UnliftIO.Exception (catchAny) -- --------------------------------------------------------------------- -- +data Log + = LogNoEnabledPlugins + -- liftIO $ logInfo (ideLogger ide) "extensibleNotificationPlugins no enabled plugins" + deriving Show + -- | Map a set of plugins to the underlying ghcide engine. -asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config -asGhcIdePlugin (IdePlugins ls) = +asGhcIdePlugin :: Recorder Log -> IdePlugins IdeState -> Plugin Config +asGhcIdePlugin recorder (IdePlugins ls) = mkPlugin rulesPlugins HLS.pluginRules <> mkPlugin executeCommandPlugins HLS.pluginCommands <> mkPlugin extensiblePlugins HLS.pluginHandlers <> - mkPlugin extensibleNotificationPlugins HLS.pluginNotificationHandlers <> + mkPlugin (extensibleNotificationPlugins recorder) HLS.pluginNotificationHandlers <> mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags where @@ -171,8 +177,8 @@ extensiblePlugins xs = mempty { P.pluginHandlers = handlers } pure $ Right $ combineResponses m config caps params xs -- --------------------------------------------------------------------- -extensibleNotificationPlugins :: [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config -extensibleNotificationPlugins xs = mempty { P.pluginHandlers = handlers } +extensibleNotificationPlugins :: Recorder Log -> [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config +extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers } where IdeNotificationHandlers handlers' = foldMap bakePluginId xs bakePluginId :: (PluginId, PluginNotificationHandlers IdeState) -> IdeNotificationHandlers @@ -186,7 +192,7 @@ extensibleNotificationPlugins xs = mempty { P.pluginHandlers = handlers } let fs = filter (\(pid,_) -> plcGlobalOn $ configForPlugin config pid) fs' case nonEmpty fs of Nothing -> do - liftIO $ logInfo (ideLogger ide) "extensibleNotificationPlugins no enabled plugins" + logWith recorder LogNoEnabledPlugins pure () Just fs -> do -- We run the notifications in order, so the core ghcide provider From b4ebdd7eff50ae7277d6749fb78717033551c144 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Thu, 6 Jan 2022 14:53:20 -0500 Subject: [PATCH 04/43] convert Rules (and most of the universe) to contravariant logging style --- exe/Plugins.hs | 70 +++--- ghcide/src/Development/IDE/Core/FileExists.hs | 35 ++- ghcide/src/Development/IDE/Core/FileStore.hs | 26 +- ghcide/src/Development/IDE/Core/OfInterest.hs | 17 +- ghcide/src/Development/IDE/Core/Rules.hs | 223 ++++++++++-------- ghcide/src/Development/IDE/Core/Service.hs | 10 +- ghcide/src/Development/IDE/Core/Shake.hs | 55 +++-- ghcide/src/Development/IDE/GHC/ExactPrint.hs | 11 +- .../src/Development/IDE/LSP/Notifications.hs | 2 +- ghcide/src/Development/IDE/Main.hs | 4 +- .../src/Development/IDE/Plugin/Completions.hs | 23 +- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 6 +- .../src/Development/IDE/Plugin/TypeLenses.hs | 17 +- plugins/default/src/Ide/Plugin/Example.hs | 16 +- plugins/default/src/Ide/Plugin/Example2.hs | 18 +- .../src/Ide/Plugin/AlternateNumberFormat.hs | 15 +- .../hls-eval-plugin/src/Ide/Plugin/Eval.hs | 23 +- .../src/Ide/Plugin/Eval/Rules.hs | 21 +- .../src/Ide/Plugin/ExplicitImports.hs | 21 +- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 20 +- .../src/Ide/Plugin/RefineImports.hs | 15 +- .../src/Ide/Plugin/Tactic.hs | 2 +- .../src/Wingman/LanguageServer.hs | 16 +- .../hls-tactics-plugin/src/Wingman/Plugin.hs | 13 +- src/Ide/Main.hs | 2 +- 25 files changed, 399 insertions(+), 282 deletions(-) diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 69d062d186..703d305b04 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -7,97 +7,105 @@ import Ide.Types (IdePlugins) -- fixed plugins import Development.IDE (IdeState) -import Development.IDE.Plugin.HLS.GhcIde as GhcIde hiding (Log) -import Ide.Plugin.Example as Example -import Ide.Plugin.Example2 as Example2 +import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde +import qualified Ide.Plugin.Example as Example +import qualified Ide.Plugin.Example2 as Example2 -- haskell-language-server optional plugins #if qualifyImportedNames -import Ide.Plugin.QualifyImportedNames as QualifyImportedNames +import qualified Ide.Plugin.QualifyImportedNames as QualifyImportedNames #endif #if callHierarchy -import Ide.Plugin.CallHierarchy as CallHierarchy +import qualified Ide.Plugin.CallHierarchy as CallHierarchy #endif #if class -import Ide.Plugin.Class as Class +import qualified Ide.Plugin.Class as Class #endif #if haddockComments -import Ide.Plugin.HaddockComments as HaddockComments +import qualified Ide.Plugin.HaddockComments as HaddockComments #endif #if eval -import Ide.Plugin.Eval as Eval +import qualified Ide.Plugin.Eval as Eval #endif #if importLens -import Ide.Plugin.ExplicitImports as ExplicitImports +import qualified Ide.Plugin.ExplicitImports as ExplicitImports #endif #if refineImports -import Ide.Plugin.RefineImports as RefineImports +import qualified Ide.Plugin.RefineImports as RefineImports #endif #if rename -import Ide.Plugin.Rename as Rename +import qualified Ide.Plugin.Rename as Rename #endif #if retrie -import Ide.Plugin.Retrie as Retrie +import qualified Ide.Plugin.Retrie as Retrie #endif #if tactic -import Ide.Plugin.Tactic as Tactic +import qualified Ide.Plugin.Tactic as Tactic #endif #if hlint -import Ide.Plugin.Hlint as Hlint +import qualified Ide.Plugin.Hlint as Hlint #endif #if moduleName -import Ide.Plugin.ModuleName as ModuleName +import qualified Ide.Plugin.ModuleName as ModuleName #endif #if pragmas -import Ide.Plugin.Pragmas as Pragmas +import qualified Ide.Plugin.Pragmas as Pragmas #endif #if splice -import Ide.Plugin.Splice as Splice +import qualified Ide.Plugin.Splice as Splice #endif #if alternateNumberFormat -import Ide.Plugin.AlternateNumberFormat as AlternateNumberFormat +import qualified Ide.Plugin.AlternateNumberFormat as AlternateNumberFormat #endif -- formatters #if floskell -import Ide.Plugin.Floskell as Floskell +import qualified Ide.Plugin.Floskell as Floskell #endif #if fourmolu -import Ide.Plugin.Fourmolu as Fourmolu +import qualified Ide.Plugin.Fourmolu as Fourmolu #endif #if ormolu -import Ide.Plugin.Ormolu as Ormolu +import qualified Ide.Plugin.Ormolu as Ormolu #endif #if stylishHaskell -import Ide.Plugin.StylishHaskell as StylishHaskell +import qualified Ide.Plugin.StylishHaskell as StylishHaskell #endif #if brittany import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide import Development.IDE.Types.Logger (Recorder, cmap) -import Ide.Plugin.Brittany as Brittany +import qualified Ide.Plugin.Brittany as Brittany #endif data Log = LogGhcide Ghcide.Log + | LogExample Example.Log + | LogExample2 Example2.Log + | LogTactic Tactic.Log + | LogEval Eval.Log + | LogExplicitImports ExplicitImports.Log + | LogRefineImports RefineImports.Log + | LogHlint Hlint.Log + | LogAlternateNumberFormat AlternateNumberFormat.Log deriving Show -- --------------------------------------------------------------------- @@ -124,7 +132,7 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins Fourmolu.descriptor "fourmolu" : #endif #if tactic - Tactic.descriptor "tactics" : + Tactic.descriptor (cmap LogTactic recorder) "tactics" : #endif #if ormolu Ormolu.descriptor "ormolu" : @@ -151,33 +159,33 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins HaddockComments.descriptor "haddockComments" : #endif #if eval - Eval.descriptor "eval" : + Eval.descriptor (cmap LogEval recorder) "eval" : #endif #if importLens - ExplicitImports.descriptor "importLens" : + ExplicitImports.descriptor (cmap LogExplicitImports recorder) "importLens" : #endif #if qualifyImportedNames QualifyImportedNames.descriptor "qualifyImportedNames" : #endif #if refineImports - RefineImports.descriptor "refineImports" : + RefineImports.descriptor (cmap LogRefineImports recorder) "refineImports" : #endif #if moduleName ModuleName.descriptor "moduleName" : #endif #if hlint - Hlint.descriptor "hlint" : + Hlint.descriptor (cmap LogHlint recorder) "hlint" : #endif #if splice Splice.descriptor "splice" : #endif #if alternateNumberFormat - AlternateNumberFormat.descriptor "alternateNumberFormat" : + AlternateNumberFormat.descriptor (cmap LogAlternateNumberFormat recorder) "alternateNumberFormat" : #endif -- The ghcide descriptors should come last so that the notification handlers -- (which restart the Shake build) run after everything else GhcIde.descriptors (cmap LogGhcide recorder) examplePlugins = - [Example.descriptor "eg" - ,Example2.descriptor "eg2" + [Example.descriptor (cmap LogExample recorder) "eg" + ,Example2.descriptor (cmap LogExample2 recorder) "eg2" ] diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 15cddd821e..899ff5049b 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -7,6 +7,7 @@ module Development.IDE.Core.FileExists , getFileExists , watchedGlobs , GetFileExists(..) + , Log ) where @@ -18,12 +19,15 @@ import Control.Monad.IO.Class import qualified Data.ByteString as BS import Data.List (partition) import Data.Maybe -import Development.IDE.Core.FileStore +import Development.IDE.Core.FileStore hiding (Log) +import qualified Development.IDE.Core.FileStore as FileStore import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph import Development.IDE.Types.Location +import Development.IDE.Types.Logger (Recorder, cmap) import Development.IDE.Types.Options import qualified Focus import Ide.Plugin.Config (Config) @@ -82,6 +86,11 @@ newtype FileExistsMapVar = FileExistsMapVar FileExistsMap instance IsIdeGlobal FileExistsMapVar +data Log + = LogFileStore FileStore.Log + | LogShake Shake.Log + deriving Show + -- | Grab the current global value of 'FileExistsMap' without acquiring a dependency getFileExistsMapUntracked :: Action FileExistsMap getFileExistsMapUntracked = do @@ -157,8 +166,8 @@ allExtensions opts = [extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext -- | Installs the 'getFileExists' rules. -- Provides a fast implementation if client supports dynamic watched files. -- Creates a global state as a side effect in that case. -fileExistsRules :: Maybe (LanguageContextEnv Config) -> VFSHandle -> Rules () -fileExistsRules lspEnv vfs = do +fileExistsRules :: Recorder Log -> Maybe (LanguageContextEnv Config) -> VFSHandle -> Rules () +fileExistsRules recorder lspEnv vfs = do supportsWatchedFiles <- case lspEnv of Nothing -> pure False Just lspEnv' -> liftIO $ runLspT lspEnv' isWatchSupported @@ -179,15 +188,15 @@ fileExistsRules lspEnv vfs = do else const $ pure False if supportsWatchedFiles - then fileExistsRulesFast isWatched vfs - else fileExistsRulesSlow vfs + then fileExistsRulesFast recorder isWatched vfs + else fileExistsRulesSlow recorder vfs - fileStoreRules vfs isWatched + fileStoreRules (cmap LogFileStore recorder) vfs isWatched -- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked. -fileExistsRulesFast :: (NormalizedFilePath -> Action Bool) -> VFSHandle -> Rules () -fileExistsRulesFast isWatched vfs = - defineEarlyCutoff $ RuleNoDiagnostics $ \GetFileExists file -> do +fileExistsRulesFast :: Recorder Log -> (NormalizedFilePath -> Action Bool) -> VFSHandle -> Rules () +fileExistsRulesFast recorder isWatched vfs = + defineEarlyCutoff (cmap LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> do isWF <- isWatched file if isWF then fileExistsFast vfs file @@ -225,9 +234,9 @@ fileExistsFast vfs file = do summarizeExists :: Bool -> Maybe BS.ByteString summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty -fileExistsRulesSlow :: VFSHandle -> Rules () -fileExistsRulesSlow vfs = - defineEarlyCutoff $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow vfs file +fileExistsRulesSlow :: Recorder Log -> VFSHandle -> Rules () +fileExistsRulesSlow recorder vfs = + defineEarlyCutoff (cmap LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow vfs file fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool) fileExistsSlow vfs file = do diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index a9ca0aba4d..8e8fc38e2d 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -68,7 +68,8 @@ import qualified Data.HashSet as HSet import Data.List (foldl') import qualified Data.Text as Text import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) -import Development.IDE.Types.Logger (Recorder, +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Types.Logger (Recorder, cmap, logWith) import Language.LSP.Server hiding (getVirtualFile) @@ -90,6 +91,7 @@ data Log | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath]) -- liftIO $ (log $ "Typechecking reverse dependencies for " ++ show nfp ++ ": " ++ show revs) -- `catch` \(e :: SomeException) -> log (show e) + | LogShake Shake.Log deriving Show makeVFSHandle :: IO VFSHandle @@ -113,8 +115,8 @@ makeLSPVFSHandle lspEnv = VFSHandle , setVirtualFileContents = Nothing } -addWatchedFileRule :: (NormalizedFilePath -> Action Bool) -> Rules () -addWatchedFileRule isWatched = defineNoDiagnostics $ \AddWatchedFile f -> do +addWatchedFileRule :: Recorder Log -> (NormalizedFilePath -> Action Bool) -> Rules () +addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmap LogShake recorder) $ \AddWatchedFile f -> do isAlreadyWatched <- isWatched f isWp <- isWorkspaceFile f if isAlreadyWatched then pure (Just True) else @@ -126,8 +128,8 @@ addWatchedFileRule isWatched = defineNoDiagnostics $ \AddWatchedFile f -> do Nothing -> pure $ Just False -getModificationTimeRule :: VFSHandle -> Rules () -getModificationTimeRule vfs = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file -> +getModificationTimeRule :: Recorder Log -> VFSHandle -> Rules () +getModificationTimeRule recorder vfs = defineEarlyCutoff (cmap LogShake recorder) $ Rule $ \(GetModificationTime_ missingFileDiags) file -> getModificationTimeImpl vfs missingFileDiags file getModificationTimeImpl :: VFSHandle @@ -213,8 +215,8 @@ modificationTime :: FileVersion -> Maybe UTCTime modificationTime VFSVersion{} = Nothing modificationTime (ModificationTime posix) = Just $ posixSecondsToUTCTime posix -getFileContentsRule :: VFSHandle -> Rules () -getFileContentsRule vfs = define $ \GetFileContents file -> getFileContentsImpl vfs file +getFileContentsRule :: Recorder Log -> VFSHandle -> Rules () +getFileContentsRule recorder vfs = define (cmap LogShake recorder) $ \GetFileContents file -> getFileContentsImpl vfs file getFileContentsImpl :: VFSHandle @@ -252,12 +254,12 @@ getFileContents f = do pure $ posixSecondsToUTCTime posix return (modTime, txt) -fileStoreRules :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules () -fileStoreRules vfs isWatched = do +fileStoreRules :: Recorder Log -> VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules () +fileStoreRules recorder vfs isWatched = do addIdeGlobal vfs - getModificationTimeRule vfs - getFileContentsRule vfs - addWatchedFileRule isWatched + getModificationTimeRule recorder vfs + getFileContentsRule recorder vfs + addWatchedFileRule recorder isWatched -- | Note that some buffer for a specific file has been modified but not -- with what changes. diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 8f31856098..7af9c6566b 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -14,8 +14,9 @@ module Development.IDE.Core.OfInterest( deleteFileOfInterest, setFilesOfInterest, kick, FileOfInterestStatus(..), - OfInterestVar(..) - ,scheduleGarbageCollection) where + OfInterestVar(..), + scheduleGarbageCollection, + Log) where import Control.Concurrent.Strict import Control.Monad @@ -32,7 +33,8 @@ import qualified Data.ByteString as BS import Data.Maybe (catMaybes) import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Plugin.Completions.Types import Development.IDE.Types.Exports import Development.IDE.Types.Location @@ -41,15 +43,18 @@ import Development.IDE.Types.Options (IdeTesting (..)) import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP +data Log = LogShake Shake.Log + deriving Show + newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) instance IsIdeGlobal OfInterestVar -- | The rule that initialises the files of interest state. -ofInterestRules :: Rules () -ofInterestRules = do +ofInterestRules :: Recorder Log -> Rules () +ofInterestRules recorder = do addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty) addIdeGlobal . GarbageCollectVar =<< liftIO (newVar False) - defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do + defineEarlyCutoff (cmap LogShake recorder) $ RuleNoDiagnostics $ \IsFileOfInterest f -> do alwaysRerun filesOfInterest <- getFilesOfInterestUntracked let foi = maybe NotFOI IsFOI $ f `HashMap.lookup` filesOfInterest diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 5ce7017713..6a972e5dd2 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -57,6 +57,7 @@ module Development.IDE.Core.Rules( getParsedModuleDefinition, typeCheckRuleDefinition, GhcSessionDepsConfig(..), + Log ) where #if !MIN_VERSION_ghc(8,8,0) @@ -96,16 +97,16 @@ import qualified Data.Text.Encoding as T import Data.Time (UTCTime (..)) import Data.Tuple.Extra import Development.IDE.Core.Compile -import Development.IDE.Core.FileExists +import Development.IDE.Core.FileExists hiding (Log) import Development.IDE.Core.FileStore (getFileContents, modificationTime, resetInterfaceStore) import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.OfInterest +import Development.IDE.Core.OfInterest hiding (Log) import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service -import Development.IDE.Core.Shake +import Development.IDE.Core.Service hiding (Log) +import Development.IDE.Core.Shake hiding (Log) import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat.Core hiding (parseModule, @@ -115,7 +116,7 @@ import Development.IDE.GHC.Compat.Core hiding import qualified Development.IDE.GHC.Compat as Compat import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error -import Development.IDE.GHC.ExactPrint +import Development.IDE.GHC.ExactPrint hiding (Log) import Development.IDE.GHC.Util hiding (modifyDynFlags) import Development.IDE.Graph @@ -128,7 +129,6 @@ import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Diagnostics as Diag import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Location -import qualified Development.IDE.Types.Logger as L import Development.IDE.Types.Options import GHC.Generics (Generic) import GHC.IO.Encoding @@ -152,6 +152,24 @@ import Control.Concurrent.STM.Stats (atomically) import Language.LSP.Server (LspT) import System.Info.Extra (isMac) import HIE.Bios.Ghc.Gap (hostIsDynamic) +import Development.IDE.Types.Logger (Recorder, cmap, logWith) +import qualified Development.IDE.Core.Shake as Shake +import qualified Development.IDE.GHC.ExactPrint as ExactPrint + +data Log + = LogShake Shake.Log + | LogReindexingHieFile !NormalizedFilePath + -- L.logDebug (logger se) $ "Re-indexing hie file for" <> T.pack (fromNormalizedFilePath f) + | LogLoadingHieFile !NormalizedFilePath + -- log <- asks $ L.logDebug . logger + -- liftIO $ log $ "LOADING HIE FILE :" <> T.pack (show file) + | LogLoadingHieFileFail !FilePath !SomeException + | LogLoadingHieFileSuccess !FilePath + -- liftIO . log $ either (const $ "FAILED LOADING HIE FILE FOR:" <> T.pack (show hie_loc)) + -- (const $ "SUCCEEDED LOADING HIE FILE FOR:" <> T.pack (show hie_loc)) + -- res + | LogExactPrint ExactPrint.Log + deriving Show templateHaskellInstructions :: T.Text templateHaskellInstructions = "https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html#support-for-template-haskell" @@ -209,10 +227,10 @@ priorityFilesOfInterest = Priority (-2) -- See https://github.com/haskell/ghcide/pull/350#discussion_r370878197 -- and https://github.com/mpickering/ghcide/pull/22#issuecomment-625070490 -- GHC wiki about: https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations -getParsedModuleRule :: Rules () -getParsedModuleRule = +getParsedModuleRule :: Recorder Log -> Rules () +getParsedModuleRule recorder = -- this rule does not have early cutoff since all its dependencies already have it - define $ \GetParsedModule file -> do + define (cmap LogShake recorder) $ \GetParsedModule file -> do ModSummaryResult{msrModSummary = ms'} <- use_ GetModSummary file sess <- use_ GhcSession file let hsc = hscEnv sess @@ -282,11 +300,11 @@ mergeParseErrorsHaddock normal haddock = normal ++ -- | This rule provides a ParsedModule preserving all annotations, -- including keywords, punctuation and comments. -- So it is suitable for use cases where you need a perfect edit. -getParsedModuleWithCommentsRule :: Rules () -getParsedModuleWithCommentsRule = +getParsedModuleWithCommentsRule :: Recorder Log -> Rules () +getParsedModuleWithCommentsRule recorder = -- The parse diagnostics are owned by the GetParsedModule rule -- For this reason, this rule does not produce any diagnostics - defineNoDiagnostics $ \GetParsedModuleWithComments file -> do + defineNoDiagnostics (cmap LogShake recorder) $ \GetParsedModuleWithComments file -> do ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file sess <- use_ GhcSession file opt <- getIdeOptions @@ -317,9 +335,9 @@ getParsedModuleDefinition packageState opt file ms = do Nothing -> pure (diag, Nothing) Just modu -> pure (diag, Just modu) -getLocatedImportsRule :: Rules () -getLocatedImportsRule = - define $ \GetLocatedImports file -> do +getLocatedImportsRule :: Recorder Log -> Rules () +getLocatedImportsRule recorder = + define (cmap LogShake recorder) $ \GetLocatedImports file -> do ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file targets <- useNoFile_ GetKnownTargets let targetsMap = HM.mapWithKey const targets @@ -476,15 +494,15 @@ rawDependencyInformation fs = do dropBootSuffix :: FilePath -> FilePath dropBootSuffix hs_src = reverse . drop (length @[] "-boot") . reverse $ hs_src -getDependencyInformationRule :: Rules () -getDependencyInformationRule = - define $ \GetDependencyInformation file -> do +getDependencyInformationRule :: Recorder Log -> Rules () +getDependencyInformationRule recorder = + define (cmap LogShake recorder) $ \GetDependencyInformation file -> do rawDepInfo <- rawDependencyInformation [file] pure ([], Just $ processDependencyInformation rawDepInfo) -reportImportCyclesRule :: Rules () -reportImportCyclesRule = - define $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do +reportImportCyclesRule :: Recorder Log -> Rules () +reportImportCyclesRule recorder = + define (cmap LogShake recorder) $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do DependencyInformation{..} <- use_ GetDependencyInformation file let fileId = pathToId depPathIdMap file case IntMap.lookup (getFilePathId fileId) depErrorNodes of @@ -516,16 +534,16 @@ reportImportCyclesRule = pure (moduleNameString . moduleName . ms_mod $ ms) showCycle mods = T.intercalate ", " (map T.pack mods) -getHieAstsRule :: Rules () -getHieAstsRule = - define $ \GetHieAst f -> do +getHieAstsRule :: Recorder Log -> Rules () +getHieAstsRule recorder = + define (cmap LogShake recorder) $ \GetHieAst f -> do tmr <- use_ TypeCheck f hsc <- hscEnv <$> use_ GhcSession f getHieAstRuleDefinition f hsc tmr -persistentHieFileRule :: Rules () -persistentHieFileRule = addPersistentRule GetHieAst $ \file -> runMaybeT $ do - res <- readHieFileForSrcFromDisk file +persistentHieFileRule :: Recorder Log -> Rules () +persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybeT $ do + res <- readHieFileForSrcFromDisk recorder file vfs <- asks vfs encoding <- liftIO getLocaleEncoding (currentSource,ver) <- liftIO $ do @@ -560,8 +578,8 @@ getHieAstRuleDefinition f hsc tmr = do typemap = AtPoint.computeTypeReferences . Compat.getAsts <$> masts pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> typemap <*> pure HieFresh) -getImportMapRule :: Rules () -getImportMapRule = define $ \GetImportMap f -> do +getImportMapRule :: Recorder Log -> Rules () +getImportMapRule recorder = define (cmap LogShake recorder) $ \GetImportMap f -> do im <- use GetLocatedImports f let mkImports fileImports = M.fromList $ mapMaybe (\(m, mfp) -> (unLoc m,) . artifactFilePath <$> mfp) fileImports pure ([], ImportMap . mkImports <$> im) @@ -570,17 +588,17 @@ getImportMapRule = define $ \GetImportMap f -> do persistentImportMapRule :: Rules () persistentImportMapRule = addPersistentRule GetImportMap $ \_ -> pure $ Just (ImportMap mempty, idDelta, Nothing) -getBindingsRule :: Rules () -getBindingsRule = - define $ \GetBindings f -> do +getBindingsRule :: Recorder Log -> Rules () +getBindingsRule recorder = + define (cmap LogShake recorder) $ \GetBindings f -> do HAR{hieKind=kind, refMap=rm} <- use_ GetHieAst f case kind of HieFresh -> pure ([], Just $ bindings rm) HieFromDisk _ -> pure ([], Nothing) -getDocMapRule :: Rules () -getDocMapRule = - define $ \GetDocMap file -> do +getDocMapRule :: Recorder Log -> Rules () +getDocMapRule recorder = + define (cmap LogShake recorder) $ \GetDocMap file -> do -- Stale data for the scenario where a broken module has previously typechecked -- but we never generated a DocMap for it (tmrTypechecked -> tc, _) <- useWithStale_ TypeCheck file @@ -594,40 +612,39 @@ getDocMapRule = persistentDocMapRule :: Rules () persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty, idDelta, Nothing) -readHieFileForSrcFromDisk :: NormalizedFilePath -> MaybeT IdeAction Compat.HieFile -readHieFileForSrcFromDisk file = do +readHieFileForSrcFromDisk :: Recorder Log -> NormalizedFilePath -> MaybeT IdeAction Compat.HieFile +readHieFileForSrcFromDisk recorder file = do ShakeExtras{withHieDb} <- ask - log <- asks $ L.logDebug . logger row <- MaybeT $ liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb $ fromNormalizedFilePath file) let hie_loc = HieDb.hieModuleHieFile row - liftIO $ log $ "LOADING HIE FILE :" <> T.pack (show file) - exceptToMaybeT $ readHieFileFromDisk hie_loc + logWith recorder $ LogLoadingHieFile file + exceptToMaybeT $ readHieFileFromDisk recorder hie_loc -readHieFileFromDisk :: FilePath -> ExceptT SomeException IdeAction Compat.HieFile -readHieFileFromDisk hie_loc = do +readHieFileFromDisk :: Recorder Log -> FilePath -> ExceptT SomeException IdeAction Compat.HieFile +readHieFileFromDisk recorder hie_loc = do nc <- asks ideNc - log <- asks $ L.logDebug . logger res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc - liftIO . log $ either (const $ "FAILED LOADING HIE FILE FOR:" <> T.pack (show hie_loc)) - (const $ "SUCCEEDED LOADING HIE FILE FOR:" <> T.pack (show hie_loc)) - res + let log = logWith recorder + case res of + Left e -> log $ LogLoadingHieFileFail hie_loc e + Right _ -> log $ LogLoadingHieFileSuccess hie_loc except res -- | Typechecks a module. -typeCheckRule :: Rules () -typeCheckRule = define $ \TypeCheck file -> do +typeCheckRule :: Recorder Log -> Rules () +typeCheckRule recorder = define (cmap LogShake recorder) $ \TypeCheck file -> do pm <- use_ GetParsedModule file hsc <- hscEnv <$> use_ GhcSessionDeps file typeCheckRuleDefinition hsc pm -knownFilesRule :: Rules () -knownFilesRule = defineEarlyCutOffNoFile $ \GetKnownTargets -> do +knownFilesRule :: Recorder Log -> Rules () +knownFilesRule recorder = defineEarlyCutOffNoFile (cmap LogShake recorder) $ \GetKnownTargets -> do alwaysRerun fs <- knownTargets pure (LBS.toStrict $ B.encode $ hash fs, unhashed fs) -getModuleGraphRule :: Rules () -getModuleGraphRule = defineNoFile $ \GetModuleGraph -> do +getModuleGraphRule :: Recorder Log -> Rules () +getModuleGraphRule recorder = defineNoFile (cmap LogShake recorder) $ \GetModuleGraph -> do fs <- toKnownFiles <$> useNoFile_ GetKnownTargets rawDepInfo <- rawDependencyInformation (HashSet.toList fs) pure $ processDependencyInformation rawDepInfo @@ -666,11 +683,11 @@ currentLinkables = do where go (mod, time) = LM time mod [] -loadGhcSession :: GhcSessionDepsConfig -> Rules () -loadGhcSession ghcSessionDepsConfig = do +loadGhcSession :: Recorder Log -> GhcSessionDepsConfig -> Rules () +loadGhcSession recorder ghcSessionDepsConfig = do -- This function should always be rerun because it tracks changes -- to the version of the collection of HscEnv's. - defineEarlyCutOffNoFile $ \GhcSessionIO -> do + defineEarlyCutOffNoFile (cmap LogShake recorder) $ \GhcSessionIO -> do alwaysRerun opts <- getIdeOptions res <- optGhcSession opts @@ -678,7 +695,7 @@ loadGhcSession ghcSessionDepsConfig = do let fingerprint = LBS.toStrict $ B.encode $ hash (sessionVersion res) return (fingerprint, res) - defineEarlyCutoff $ Rule $ \GhcSession file -> do + defineEarlyCutoff (cmap LogShake recorder) $ Rule $ \GhcSession file -> do IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file @@ -703,7 +720,7 @@ loadGhcSession ghcSessionDepsConfig = do Nothing -> LBS.toStrict $ B.encode (hash (snd val)) return (Just cutoffHash, val) - defineNoDiagnostics $ \(GhcSessionDeps_ fullModSummary) file -> do + defineNoDiagnostics (cmap LogShake recorder) $ \(GhcSessionDeps_ fullModSummary) file -> do env <- use_ GhcSession file ghcSessionDepsDefinition fullModSummary ghcSessionDepsConfig env file @@ -741,8 +758,8 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do -- | Load a iface from disk, or generate it if there isn't one or it is out of date -- This rule also ensures that the `.hie` and `.o` (if needed) files are written out. -getModIfaceFromDiskRule :: Rules () -getModIfaceFromDiskRule = defineEarlyCutoff $ Rule $ \GetModIfaceFromDisk f -> do +getModIfaceFromDiskRule :: Recorder Log -> Rules () +getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmap LogShake recorder) $ Rule $ \GetModIfaceFromDisk f -> do ms <- msrModSummary <$> use_ GetModSummary f mb_session <- use GhcSessionDeps f case mb_session of @@ -765,10 +782,10 @@ getModIfaceFromDiskRule = defineEarlyCutoff $ Rule $ \GetModIfaceFromDisk f -> d -- `.hie` file. There should be an up2date `.hie` file on -- disk since we are careful to write out the `.hie` file before writing the -- `.hi` file -getModIfaceFromDiskAndIndexRule :: Rules () -getModIfaceFromDiskAndIndexRule = +getModIfaceFromDiskAndIndexRule :: Recorder Log -> Rules () +getModIfaceFromDiskAndIndexRule recorder = -- doesn't need early cutoff since all its dependencies already have it - defineNoDiagnostics $ \GetModIfaceFromDiskAndIndex f -> do + defineNoDiagnostics (cmap LogShake recorder) $ \GetModIfaceFromDiskAndIndex f -> do x <- use_ GetModIfaceFromDisk f se@ShakeExtras{withHieDb} <- getShakeExtras @@ -790,19 +807,19 @@ getModIfaceFromDiskAndIndexRule = -- Not in db, must re-index _ -> do ehf <- liftIO $ runIdeAction "GetModIfaceFromDiskAndIndex" se $ runExceptT $ - readHieFileFromDisk hie_loc + readHieFileFromDisk recorder hie_loc case ehf of -- Uh oh, we failed to read the file for some reason, need to regenerate it Left err -> fail $ "failed to read .hie file " ++ show hie_loc ++ ": " ++ displayException err -- can just re-index the file we read from disk Right hf -> liftIO $ do - L.logDebug (logger se) $ "Re-indexing hie file for" <> T.pack (fromNormalizedFilePath f) + logWith recorder $ LogReindexingHieFile f indexHieFile se ms f hash hf return (Just x) -isHiFileStableRule :: Rules () -isHiFileStableRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsHiFileStable f -> do +isHiFileStableRule :: Recorder Log -> Rules () +isHiFileStableRule recorder = defineEarlyCutoff (cmap LogShake recorder) $ RuleNoDiagnostics $ \IsHiFileStable f -> do ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps f let hiFile = toNormalizedFilePath' $ Compat.ml_hi_file $ ms_location ms @@ -840,13 +857,13 @@ displayTHWarning newtype DisplayTHWarning = DisplayTHWarning (IO ()) instance IsIdeGlobal DisplayTHWarning -getModSummaryRule :: Rules () -getModSummaryRule = do +getModSummaryRule :: Recorder Log -> Rules () +getModSummaryRule recorder = do env <- lspEnv <$> getShakeExtrasRules displayItOnce <- liftIO $ once $ LSP.runLspT (fromJust env) displayTHWarning addIdeGlobal (DisplayTHWarning displayItOnce) - defineEarlyCutoff $ Rule $ \GetModSummary f -> do + defineEarlyCutoff (cmap LogShake recorder) $ Rule $ \GetModSummary f -> do session' <- hscEnv <$> use_ GhcSession f modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal let session = hscSetFlags (modify_dflags $ hsc_dflags session') session' @@ -867,7 +884,7 @@ getModSummaryRule = do return ( Just (fingerprintToBS fingerPrint) , ([], Just res)) Left diags -> return (Nothing, (diags, Nothing)) - defineEarlyCutoff $ RuleNoDiagnostics $ \GetModSummaryWithoutTimestamps f -> do + defineEarlyCutoff (cmap LogShake recorder) $ RuleNoDiagnostics $ \GetModSummaryWithoutTimestamps f -> do ms <- use GetModSummary f case ms of Just res@ModSummaryResult{..} -> do @@ -886,12 +903,12 @@ generateCore runSimplifier file = do setPriority priorityGenerateCore liftIO $ compileModule runSimplifier packageState (tmrModSummary tm) (tmrTypechecked tm) -generateCoreRule :: Rules () -generateCoreRule = - define $ \GenerateCore -> generateCore (RunSimplifier True) +generateCoreRule :: Recorder Log -> Rules () +generateCoreRule recorder = + define (cmap LogShake recorder) $ \GenerateCore -> generateCore (RunSimplifier True) -getModIfaceRule :: Rules () -getModIfaceRule = defineEarlyCutoff $ Rule $ \GetModIface f -> do +getModIfaceRule :: Recorder Log -> Rules () +getModIfaceRule recorder = defineEarlyCutoff (cmap LogShake recorder) $ Rule $ \GetModIface f -> do fileOfInterest <- use_ IsFileOfInterest f res@(_,(_,mhmi)) <- case fileOfInterest of IsFOI status -> do @@ -994,8 +1011,8 @@ compileToObjCodeIfNeeded hsc (Just linkableType) getGuts tmr = do (diags', !res) <- liftIO $ mkHiFileResultCompile hsc tmr guts linkableType pure (diags++diags', res) -getClientSettingsRule :: Rules () -getClientSettingsRule = defineEarlyCutOffNoFile $ \GetClientSettings -> do +getClientSettingsRule :: Recorder Log -> Rules () +getClientSettingsRule recorder = defineEarlyCutOffNoFile (cmap LogShake recorder) $ \GetClientSettings -> do alwaysRerun settings <- clientSettings <$> getIdeConfiguration return (LBS.toStrict $ B.encode $ hash settings, settings) @@ -1105,28 +1122,28 @@ data RulesConfig = RulesConfig instance Default RulesConfig where def = RulesConfig True True -- | A rule that wires per-file rules together -mainRule :: RulesConfig -> Rules () -mainRule RulesConfig{..} = do +mainRule :: Recorder Log -> RulesConfig -> Rules () +mainRule recorder RulesConfig{..} = do linkables <- liftIO $ newVar emptyModuleEnv addIdeGlobal $ CompiledLinkables linkables - getParsedModuleRule - getParsedModuleWithCommentsRule - getLocatedImportsRule - getDependencyInformationRule - reportImportCyclesRule - typeCheckRule - getDocMapRule - loadGhcSession def{checkForImportCycles} - getModIfaceFromDiskRule - getModIfaceFromDiskAndIndexRule - getModIfaceRule - getModSummaryRule - isHiFileStableRule - getModuleGraphRule - knownFilesRule - getClientSettingsRule - getHieAstsRule - getBindingsRule + getParsedModuleRule recorder + getParsedModuleWithCommentsRule recorder + getLocatedImportsRule recorder + getDependencyInformationRule recorder + reportImportCyclesRule recorder + typeCheckRule recorder + getDocMapRule recorder + loadGhcSession recorder def{checkForImportCycles} + getModIfaceFromDiskRule recorder + getModIfaceFromDiskAndIndexRule recorder + getModIfaceRule recorder + getModSummaryRule recorder + isHiFileStableRule recorder + getModuleGraphRule recorder + knownFilesRule recorder + getClientSettingsRule recorder + getHieAstsRule recorder + getBindingsRule recorder -- This rule uses a custom newness check that relies on the encoding -- produced by 'encodeLinkable'. This works as follows: -- * -> @@ -1134,13 +1151,13 @@ mainRule RulesConfig{..} = do -- * Object/BCO -> NoLinkable : the prev linkable can be ignored, signal "no change" -- * otherwise : the prev linkable cannot be reused, signal "value has changed" if enableTemplateHaskell - then defineEarlyCutoff $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation file -> + then defineEarlyCutoff (cmap LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation file -> needsCompilationRule file - else defineNoDiagnostics $ \NeedsCompilation _ -> return $ Just Nothing - generateCoreRule - getImportMapRule - getAnnotatedParsedSourceRule - persistentHieFileRule + else defineNoDiagnostics (cmap LogShake recorder) $ \NeedsCompilation _ -> return $ Just Nothing + generateCoreRule recorder + getImportMapRule recorder + getAnnotatedParsedSourceRule (cmap LogExactPrint recorder) + persistentHieFileRule recorder persistentDocMapRule persistentImportMapRule diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index ed6b03e008..304eb28606 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -21,7 +21,7 @@ module Development.IDE.Core.Service( import Control.Applicative ((<|>)) import Development.IDE.Core.Debouncer import Development.IDE.Core.FileExists (fileExistsRules) -import Development.IDE.Core.OfInterest +import Development.IDE.Core.OfInterest hiding (Log) import Development.IDE.Graph import Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options (IdeOptions (..)) @@ -30,6 +30,8 @@ import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP import Control.Monad +import qualified Development.IDE.Core.FileExists as FileExists +import qualified Development.IDE.Core.OfInterest as OfInterest import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Shake (WithHieDb) @@ -38,6 +40,8 @@ import System.Environment (lookupEnv) data Log = LogShake Shake.Log + | LogOfInterest OfInterest.Log + | LogFileExists FileExists.Log deriving Show ------------------------------------------------------------ @@ -75,8 +79,8 @@ initialise recorder defaultConfig mainRule lspEnv logger debouncer options vfs w (optShakeOptions options) $ do addIdeGlobal $ GlobalIdeOptions options - ofInterestRules - fileExistsRules lspEnv vfs + ofInterestRules (cmap LogOfInterest recorder) + fileExistsRules (cmap LogFileExists recorder) lspEnv vfs mainRule -- | Shutdown the Compiler Service. diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index b8d2f76aab..e4732e420f 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -180,6 +180,12 @@ data Log | LogBuildSessionRestart !String ![DelayedActionInternal] !(HashSet Key) !Seconds !(Maybe FilePath) | LogDelayedAction !(DelayedAction ()) !Seconds | LogBuildSessionFinish !(Maybe SomeException) + | LogDiagsDiffButNoLspEnv ![FileDiagnostic] + -- logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags + | LogDefineEarlyCutoffRuleNoDiagDiags ![FileDiagnostic] + -- RuleNoDiagnostics mapM_ (\d -> liftIO $ logWarning logger $ showDiagnosticsColored [d]) diags + | LogDefineEarlyCutoffRuleCustomNewnessDiags ![FileDiagnostic] + -- RuleWithCustomNewnessCheck mapM_ (\d -> liftIO $ logWarning logger $ showDiagnosticsColored [d]) diags deriving Show -- | We need to serialize writes to the database, so we send any function that @@ -870,13 +876,13 @@ preservedKeys checkParents = HSet.fromList $ -- | Define a new Rule without early cutoff define :: IdeRule k v - => (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules () -define op = defineEarlyCutoff $ Rule $ \k v -> (Nothing,) <$> op k v + => Recorder Log -> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules () +define recorder op = defineEarlyCutoff recorder $ Rule $ \k v -> (Nothing,) <$> op k v defineNoDiagnostics :: IdeRule k v - => (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules () -defineNoDiagnostics op = defineEarlyCutoff $ RuleNoDiagnostics $ \k v -> (Nothing,) <$> op k v + => Recorder Log -> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules () +defineNoDiagnostics recorder op = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k v -> (Nothing,) <$> op k v -- | Request a Rule result if available use :: IdeRule k v @@ -998,37 +1004,36 @@ data RuleBody k v -- | Define a new Rule with early cutoff defineEarlyCutoff :: IdeRule k v - => RuleBody k v + => Recorder Log + -> RuleBody k v -> Rules () -defineEarlyCutoff (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do +defineEarlyCutoff recorder (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do extras <- getShakeExtras let diagnostics diags = do traceDiagnostics diags - updateFileDiagnostics file (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags + updateFileDiagnostics recorder file (Key key) extras . map (\(_,y,z) -> (y,z)) $ diags defineEarlyCutoff' diagnostics (==) key file old mode $ op key file -defineEarlyCutoff (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do - ShakeExtras{logger} <- getShakeExtras +defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do let diagnostics diags = do traceDiagnostics diags - mapM_ (\d -> liftIO $ logWarning logger $ showDiagnosticsColored [d]) diags + logWith recorder $ LogDefineEarlyCutoffRuleNoDiagDiags diags defineEarlyCutoff' diagnostics (==) key file old mode $ second (mempty,) <$> op key file -defineEarlyCutoff RuleWithCustomNewnessCheck{..} = +defineEarlyCutoff recorder RuleWithCustomNewnessCheck{..} = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \ traceDiagnostics -> do - ShakeExtras{logger} <- getShakeExtras let diagnostics diags = do - mapM_ (\d -> liftIO $ logWarning logger $ showDiagnosticsColored [d]) diags + logWith recorder $ LogDefineEarlyCutoffRuleCustomNewnessDiags diags traceDiagnostics diags defineEarlyCutoff' diagnostics newnessCheck key file old mode $ second (mempty,) <$> build key file -defineNoFile :: IdeRule k v => (k -> Action v) -> Rules () -defineNoFile f = defineNoDiagnostics $ \k file -> do +defineNoFile :: IdeRule k v => Recorder Log -> (k -> Action v) -> Rules () +defineNoFile recorder f = defineNoDiagnostics recorder $ \k file -> do if file == emptyFilePath then do res <- f k; return (Just res) else fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" -defineEarlyCutOffNoFile :: IdeRule k v => (k -> Action (BS.ByteString, v)) -> Rules () -defineEarlyCutOffNoFile f = defineEarlyCutoff $ RuleNoDiagnostics $ \k file -> do +defineEarlyCutOffNoFile :: IdeRule k v => Recorder Log -> (k -> Action (BS.ByteString, v)) -> Rules () +defineEarlyCutOffNoFile recorder f = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k file -> do if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, Just res) else fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" @@ -1134,9 +1139,10 @@ data OnDiskRule = OnDiskRule -- the internals of this module that we do not want to expose. defineOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) - => (k -> NormalizedFilePath -> OnDiskRule) + => Recorder Log + -> (k -> NormalizedFilePath -> OnDiskRule) -> Rules () -defineOnDisk act = addRule $ +defineOnDisk recorder act = addRule $ \(QDisk key file) (mbOld :: Maybe BS.ByteString) mode -> do extras <- getShakeExtras let OnDiskRule{..} = act key file @@ -1148,7 +1154,7 @@ defineOnDisk act = addRule $ case mbOld of Nothing -> do (diags, mbHash) <- runAct - updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags + updateFileDiagnostics recorder file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash) Just old -> do current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "") @@ -1159,7 +1165,7 @@ defineOnDisk act = addRule $ pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current) else do (diags, mbHash) <- runAct - updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags + updateFileDiagnostics recorder file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags let change | mbHash == Just old = ChangedRecomputeSame | otherwise = ChangedRecomputeDiff @@ -1176,12 +1182,13 @@ needOnDisks k files = do liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k) updateFileDiagnostics :: MonadIO m - => NormalizedFilePath + => Recorder Log + -> NormalizedFilePath -> Key -> ShakeExtras -> [(ShowDiagnostic,Diagnostic)] -- ^ current results -> m () -updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, lspEnv} current = liftIO $ do +updateFileDiagnostics recorder fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, lspEnv} current = liftIO $ do modTime <- (currentValue . fst =<<) <$> atomicallyNamed "diagnostics - read" (getValues state GetModificationTime fp) let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current uri = filePathToUri' fp @@ -1201,7 +1208,7 @@ updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, p lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri publishedDiagnostics let action = when (lastPublish /= newDiags) $ case lspEnv of Nothing -> -- Print an LSP event. - logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags + logWith recorder $ LogDiagsDiffButNoLspEnv (map (fp, ShowDiag,) newDiags) Just env -> LSP.runLspT env $ LSP.sendNotification LSP.STextDocumentPublishDiagnostics $ LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) (List newDiags) diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index 2f081cdedb..49260c6d70 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -31,6 +31,7 @@ module Development.IDE.GHC.ExactPrint setPrecedingLinesT, -- * Helper function eqSrcSpan, + Log ) where @@ -53,13 +54,15 @@ import qualified Data.Text as T import Data.Traversable (for) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service (runAction) -import Development.IDE.Core.Shake +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding (parseImport, parsePattern, parseType) import Development.IDE.Graph (RuleResult, Rules) import Development.IDE.Graph.Classes import Development.IDE.Types.Location +import Development.IDE.Types.Logger (Recorder, cmap) import qualified GHC.Generics as GHC import Generics.SYB import Generics.SYB.GHC @@ -76,6 +79,8 @@ import Retrie.ExactPrint hiding (parseDecl, ------------------------------------------------------------------------------ +data Log = LogShake Shake.Log deriving Show + data GetAnnotatedParsedSource = GetAnnotatedParsedSource deriving (Eq, Show, Typeable, GHC.Generic) @@ -84,8 +89,8 @@ instance NFData GetAnnotatedParsedSource type instance RuleResult GetAnnotatedParsedSource = Annotated ParsedSource -- | Get the latest version of the annotated parse source with comments. -getAnnotatedParsedSourceRule :: Rules () -getAnnotatedParsedSourceRule = define $ \GetAnnotatedParsedSource nfp -> do +getAnnotatedParsedSourceRule :: Recorder Log -> Rules () +getAnnotatedParsedSourceRule recorder = define (cmap LogShake recorder) $ \GetAnnotatedParsedSource nfp -> do pm <- use GetParsedModuleWithComments nfp return ([], fmap annotateParsedSource pm) diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 01d5d888a2..9ef450d17a 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -29,7 +29,7 @@ import Development.IDE.Core.FileStore (registerFileWatches, setSomethingModified) import qualified Development.IDE.Core.FileStore as FileStore import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.OfInterest +import Development.IDE.Core.OfInterest hiding (Log) import Development.IDE.Core.RuleTypes (GetClientSettings (..)) import Development.IDE.Core.Service hiding (Log) import Development.IDE.Core.Shake hiding (Log) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index a914f53c61..6528c864f8 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -51,6 +51,7 @@ import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCo TypeCheck (TypeCheck)) import Development.IDE.Core.Rules (GhcSessionIO (GhcSessionIO), mainRule) +import qualified Development.IDE.Core.Rules as Rules import Development.IDE.Core.Service (initialise, runAction) import qualified Development.IDE.Core.Service as Service import Development.IDE.Core.Shake (IdeState (shakeExtras), @@ -202,7 +203,7 @@ defaultArguments recorder priority = Arguments , argsOTMemoryProfiling = False , argCommand = LSP , argsLogger = stderrLogger priority - , argsRules = mainRule def >> action kick + , argsRules = mainRule (cmap LogRules recorder) def >> action kick , argsGhcidePlugin = mempty , argsHlsPlugins = pluginDescToIdePlugins (Ghcide.descriptors (cmap LogGhcide recorder)) , argsSessionLoadingOptions = def @@ -275,6 +276,7 @@ data Log | LogLanguageServer LanguageServer.Log | LogSession Session.Log | LogPluginHLS PluginHLS.Log + | LogRules Rules.Log deriving Show defaultMain :: Recorder Log -> Arguments -> IO () diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 0d54ec0f92..8b72b56574 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -3,6 +3,7 @@ module Development.IDE.Plugin.Completions ( descriptor + , Log ) where import Control.Concurrent.Async (concurrently) @@ -18,8 +19,9 @@ import Data.Maybe import qualified Data.Text as T import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service -import Development.IDE.Core.Shake +import Development.IDE.Core.Service hiding (Log) +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (rangeToSrcSpan) import Development.IDE.GHC.ExactPrint (Annotated (annsA), @@ -37,6 +39,7 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq (envPack hscEnv) import qualified Development.IDE.Types.KnownTargets as KT import Development.IDE.Types.Location +import Development.IDE.Types.Logger (Recorder, cmap) import GHC.Exts (fromList, toList) import Ide.Plugin.Config (Config) import Ide.Types @@ -45,17 +48,19 @@ import Language.LSP.Types import qualified Language.LSP.VFS as VFS import Text.Fuzzy.Parallel (Scored (..)) -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) - { pluginRules = produceCompletions +data Log = LogShake Shake.Log deriving Show + +descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) + { pluginRules = produceCompletions recorder , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP , pluginCommands = [extendImportCommand] , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} } -produceCompletions :: Rules () -produceCompletions = do - define $ \LocalCompletions file -> do +produceCompletions :: Recorder Log -> Rules () +produceCompletions recorder = do + define (cmap LogShake recorder) $ \LocalCompletions file -> do let uri = fromNormalizedUri $ normalizedFilePathToUri file pm <- useWithStale GetParsedModule file case pm of @@ -63,7 +68,7 @@ produceCompletions = do let cdata = localCompletionsForParsedModule uri pm return ([], Just cdata) _ -> return ([], Nothing) - define $ \NonLocalCompletions file -> do + define (cmap LogShake recorder) $ \NonLocalCompletions file -> do -- For non local completions we avoid depending on the parsed module, -- synthetizing a fake module with an empty body from the buffer -- in the ModSummary, which preserves all the imports diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index eaf51bf861..08ef4e55fa 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -22,6 +22,8 @@ import Text.Regex.TDFA.Text () data Log = LogNotifications Notifications.Log + | LogCompletions Completions.Log + | LogTypeLenses TypeLenses.Log deriving Show descriptors :: Recorder Log -> [PluginDescriptor IdeState] @@ -31,8 +33,8 @@ descriptors recorder = CodeAction.typeSigsPluginDescriptor "ghcide-code-actions-type-signatures", CodeAction.bindingsPluginDescriptor "ghcide-code-actions-bindings", CodeAction.fillHolePluginDescriptor "ghcide-code-actions-fill-holes", - Completions.descriptor "ghcide-completions", - TypeLenses.descriptor "ghcide-type-lenses", + Completions.descriptor (cmap LogCompletions recorder) "ghcide-completions", + TypeLenses.descriptor (cmap LogTypeLenses recorder) "ghcide-type-lenses", Notifications.descriptor (cmap LogNotifications recorder) "ghcide-core" ] diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 127afe57d0..71a3ce15f7 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -10,6 +10,7 @@ module Development.IDE.Plugin.TypeLenses ( GlobalBindingTypeSig (..), GetGlobalBindingTypeSigs (..), GlobalBindingTypeSigsResult (..), + Log ) where import Control.Concurrent.STM.Stats (atomically) @@ -33,6 +34,7 @@ import Development.IDE.Core.RuleTypes (GetBindings (GetBindings), import Development.IDE.Core.Rules (IdeState, runAction) import Development.IDE.Core.Service (getDiagnostics) import Development.IDE.Core.Shake (getHiddenDiagnostics, use) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Util (printName) import Development.IDE.Graph.Classes @@ -41,6 +43,7 @@ import Development.IDE.Types.Location (Position (Position, _chara Range (Range, _end, _start), toNormalizedFilePath', uriToFilePath') +import Development.IDE.Types.Logger (Recorder, cmap) import GHC.Generics (Generic) import Ide.Plugin.Config (Config) import Ide.Plugin.Properties @@ -68,15 +71,17 @@ import Language.LSP.Types (ApplyWorkspaceEditParams ( WorkspaceEdit (WorkspaceEdit)) import Text.Regex.TDFA ((=~), (=~~)) +data Log = LogShake Shake.Log deriving Show + typeLensCommandId :: T.Text typeLensCommandId = "typesignature.add" -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = +descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] - , pluginRules = rules + , pluginRules = rules recorder , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} } @@ -237,9 +242,9 @@ instance NFData GlobalBindingTypeSigsResult where type instance RuleResult GetGlobalBindingTypeSigs = GlobalBindingTypeSigsResult -rules :: Rules () -rules = do - define $ \GetGlobalBindingTypeSigs nfp -> do +rules :: Recorder Log -> Rules () +rules recorder = do + define (cmap LogShake recorder) $ \GetGlobalBindingTypeSigs nfp -> do tmr <- use TypeCheck nfp -- we need session here for tidying types hsc <- use GhcSession nfp diff --git a/plugins/default/src/Ide/Plugin/Example.hs b/plugins/default/src/Ide/Plugin/Example.hs index 89bef3441e..86662d4bef 100644 --- a/plugins/default/src/Ide/Plugin/Example.hs +++ b/plugins/default/src/Ide/Plugin/Example.hs @@ -12,6 +12,7 @@ module Ide.Plugin.Example ( descriptor + , Log ) where import Control.Concurrent.STM @@ -27,6 +28,7 @@ import Data.Typeable import Development.IDE as D import Development.IDE.Core.Shake (getDiagnostics, getHiddenDiagnostics) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat (ParsedModule (ParsedModule)) import GHC.Generics import Ide.PluginUtils @@ -38,9 +40,11 @@ import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) - { pluginRules = exampleRules +data Log = LogShake Shake.Log deriving Show + +descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) + { pluginRules = exampleRules recorder , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction <> mkPluginHandler STextDocumentCodeLens codeLens @@ -74,9 +78,9 @@ instance NFData Example type instance RuleResult Example = () -exampleRules :: Rules () -exampleRules = do - define $ \Example file -> do +exampleRules :: Recorder Log -> Rules () +exampleRules recorder = do + define (cmap LogShake recorder) $ \Example file -> do _pm <- getParsedModule file let diag = mkDiag file "example" DsError (Range (Position 0 0) (Position 1 0)) "example diagnostic, hello world" return ([diag], Just ()) diff --git a/plugins/default/src/Ide/Plugin/Example2.hs b/plugins/default/src/Ide/Plugin/Example2.hs index 4b95e4242b..f940d049ec 100644 --- a/plugins/default/src/Ide/Plugin/Example2.hs +++ b/plugins/default/src/Ide/Plugin/Example2.hs @@ -12,6 +12,7 @@ module Ide.Plugin.Example2 ( descriptor + , Log ) where import Control.Concurrent.STM @@ -25,7 +26,8 @@ import Data.Hashable import qualified Data.Text as T import Data.Typeable import Development.IDE as D -import Development.IDE.Core.Shake +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import GHC.Generics import Ide.PluginUtils import Ide.Types @@ -35,9 +37,11 @@ import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) - { pluginRules = exampleRules +data Log = LogShake Shake.Log deriving Show + +descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) + { pluginRules = exampleRules recorder , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction <> mkPluginHandler STextDocumentCodeLens codeLens @@ -66,9 +70,9 @@ instance NFData Example2 type instance RuleResult Example2 = () -exampleRules :: Rules () -exampleRules = do - define $ \Example2 file -> do +exampleRules :: Recorder Log -> Rules () +exampleRules recorder = do + define (cmap LogShake recorder) $ \Example2 file -> do _pm <- getParsedModule file let diag = mkDiag file "example2" DsError (Range (Position 0 0) (Position 1 0)) "example2 diagnostic, hello world" return ([diag], Just ()) diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs index 53056164e2..9477f681c2 100644 --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Ide.Plugin.AlternateNumberFormat (descriptor) where +module Ide.Plugin.AlternateNumberFormat (descriptor, Log) where import Control.Lens ((^.)) import Control.Monad.Except (ExceptT, MonadIO, liftIO) @@ -14,6 +14,7 @@ import Development.IDE (GetParsedModule (GetParsedModu define, ideLogger, realSrcSpanToRange, runAction, use) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding (getSrcSpan) import Development.IDE.GHC.Compat.Util (toList) import Development.IDE.Graph.Classes (Hashable, NFData) @@ -29,10 +30,12 @@ import Ide.Types import Language.LSP.Types import Language.LSP.Types.Lens (uri) -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) +data Log = LogShake Shake.Log deriving Show + +descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionHandler - , pluginRules = collectLiteralsRule + , pluginRules = collectLiteralsRule recorder } data CollectLiterals = CollectLiterals @@ -53,8 +56,8 @@ instance Show CollectLiteralsResult where instance NFData CollectLiteralsResult -collectLiteralsRule :: Rules () -collectLiteralsRule = define $ \CollectLiterals nfp -> do +collectLiteralsRule :: Recorder Log -> Rules () +collectLiteralsRule recorder = define (cmap LogShake recorder) $ \CollectLiterals nfp -> do pm <- use GetParsedModule nfp -- get the current extensions active and transform them into FormatTypes let fmts = getFormatTypes <$> pm diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs index df2184c2fc..8c3bf2a890 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs @@ -7,21 +7,26 @@ Eval Plugin entry point. -} module Ide.Plugin.Eval ( descriptor, + Log ) where -import Development.IDE (IdeState) -import qualified Ide.Plugin.Eval.CodeLens as CL -import Ide.Plugin.Eval.Rules (rules) -import Ide.Types (PluginDescriptor (..), PluginId, - defaultPluginDescriptor, - mkPluginHandler) +import Development.IDE (IdeState) +import Development.IDE.Types.Logger (Recorder, cmap) +import qualified Ide.Plugin.Eval.CodeLens as CL +import Ide.Plugin.Eval.Rules (rules) +import qualified Ide.Plugin.Eval.Rules as EvalRules +import Ide.Types (PluginDescriptor (..), PluginId, + defaultPluginDescriptor, + mkPluginHandler) import Language.LSP.Types +data Log = LogEvalRules EvalRules.Log deriving Show + -- |Plugin descriptor -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = +descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeLens CL.codeLens , pluginCommands = [CL.evalCommand] - , pluginRules = rules + , pluginRules = rules (cmap LogEvalRules recorder) } diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs index dfca81fabc..f3dea92f26 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -3,7 +3,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} -module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation) where +module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, Log) where import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.HashSet (HashSet) @@ -31,17 +31,20 @@ import Development.IDE.Core.Shake (IsIdeGlobal, addIdeGlobal, getIdeGlobalAction, getIdeGlobalState) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat as SrcLoc import qualified Development.IDE.GHC.Compat.Util as FastString import Development.IDE.Graph (alwaysRerun) +import Development.IDE.Types.Logger (Recorder, cmap) import Ide.Plugin.Eval.Types +data Log = LogShake Shake.Log deriving Show -rules :: Rules () -rules = do - evalParsedModuleRule - redefinedNeedsCompilation +rules :: Recorder Log -> Rules () +rules recorder = do + evalParsedModuleRule recorder + redefinedNeedsCompilation recorder addIdeGlobal . EvaluatingVar =<< liftIO(newIORef mempty) newtype EvaluatingVar = EvaluatingVar (IORef (HashSet NormalizedFilePath)) @@ -65,8 +68,8 @@ pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing #endif -evalParsedModuleRule :: Rules () -evalParsedModuleRule = defineEarlyCutoff $ RuleNoDiagnostics $ \GetEvalComments nfp -> do +evalParsedModuleRule :: Recorder Log -> Rules () +evalParsedModuleRule recorder = defineEarlyCutoff (cmap LogShake recorder) $ RuleNoDiagnostics $ \GetEvalComments nfp -> do (ParsedModule{..}, posMap) <- useWithStale_ GetParsedModuleWithComments nfp let comments = foldMap (\case L (RealSrcSpanAlready real) bdy @@ -97,8 +100,8 @@ evalParsedModuleRule = defineEarlyCutoff $ RuleNoDiagnostics $ \GetEvalComments -- This will ensure that the modules are loaded with linkables -- and the interactive session won't try to compile them on the fly, -- leading to much better performance of the evaluate code lens -redefinedNeedsCompilation :: Rules () -redefinedNeedsCompilation = defineEarlyCutoff $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do +redefinedNeedsCompilation :: Recorder Log -> Rules () +redefinedNeedsCompilation recorder = defineEarlyCutoff (cmap LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do alwaysRerun EvaluatingVar var <- getIdeGlobalAction diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index e6b3e3a5b7..3c122bd8e0 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -13,6 +13,7 @@ module Ide.Plugin.ExplicitImports , descriptorForModules , extractMinimalImports , within + , Log ) where import Control.DeepSeq @@ -29,6 +30,7 @@ import qualified Data.Text as T import Development.IDE hiding (pluginHandlers, pluginRules) import Development.IDE.Core.PositionMapping +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.Graph.Classes import GHC.Generics (Generic) @@ -40,22 +42,27 @@ import Language.LSP.Types importCommandId :: CommandId importCommandId = "ImportLensCommand" +data Log + = LogShake Shake.Log + deriving Show + -- | The "main" function of a plugin -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor = descriptorForModules (/= moduleName pRELUDE) +descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor recorder = descriptorForModules recorder (/= moduleName pRELUDE) descriptorForModules - :: (ModuleName -> Bool) + :: Recorder Log + -> (ModuleName -> Bool) -- ^ Predicate to select modules that will be annotated -> PluginId -> PluginDescriptor IdeState -descriptorForModules pred plId = +descriptorForModules recorder pred plId = (defaultPluginDescriptor plId) { -- This plugin provides a command handler pluginCommands = [importLensCommand], -- This plugin defines a new rule - pluginRules = minimalImportsRule, + pluginRules = minimalImportsRule recorder, pluginHandlers = mconcat [ -- This plugin provides code lenses mkPluginHandler STextDocumentCodeLens $ lensProvider pred @@ -183,8 +190,8 @@ exportedModuleStrings ParsedModule{pm_parsed_source = L _ HsModule{..}} = map show exports exportedModuleStrings _ = [] -minimalImportsRule :: Rules () -minimalImportsRule = define $ \MinimalImports nfp -> do +minimalImportsRule :: Recorder Log -> Rules () +minimalImportsRule recorder = define (cmap LogShake recorder) $ \MinimalImports nfp -> do -- Get the typechecking artifacts from the module tmr <- use TypeCheck nfp -- We also need a GHC session with all the dependencies diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index f04e5d474c..07d0896585 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -26,6 +26,7 @@ module Ide.Plugin.Hlint ( descriptor + , Log ) where import Control.Arrow ((&&&)) import Control.Concurrent.STM @@ -109,6 +110,7 @@ import GHC.Generics (Associativi Generic) import Text.Regex.TDFA.Text () +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat.Core (WarningFlag (Opt_WarnUnrecognisedPragmas), wopt) import Development.IDE.Spans.Pragmas (LineSplitTextEdits (LineSplitTextEdits), @@ -122,6 +124,10 @@ import System.Environment (setEnv, unsetEnv) -- --------------------------------------------------------------------- +newtype Log + = LogShake Shake.Log + deriving Show + #ifdef HLINT_ON_GHC_LIB -- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib pattern RealSrcSpan :: GHC.RealSrcSpan -> Maybe BufSpan -> GHC.SrcSpan @@ -133,9 +139,9 @@ pattern RealSrcSpan x y <- ((,Nothing) -> (GHC.RealSrcSpan x, y)) {-# COMPLETE RealSrcSpan, UnhelpfulSpan #-} #endif -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) - { pluginRules = rules plId +descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) + { pluginRules = rules recorder plId , pluginCommands = [ PluginCommand "applyOne" "Apply a single hint" applyOneCmd , PluginCommand "applyAll" "Apply all hints to the file" applyAllCmd @@ -163,15 +169,15 @@ type instance RuleResult GetHlintDiagnostics = () -- | - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc -- | - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction` -- | - The hlint specific settings have changed, via `getHlintSettingsRule` -rules :: PluginId -> Rules () -rules plugin = do - define $ \GetHlintDiagnostics file -> do +rules :: Recorder Log -> PluginId -> Rules () +rules recorder plugin = do + define (cmap LogShake recorder) $ \GetHlintDiagnostics file -> do config <- getClientConfigAction def let hlintOn = pluginEnabledConfig plcDiagnosticsOn plugin config ideas <- if hlintOn then getIdeas file else return (Right []) return (diagnostics file ideas, Just ()) - defineNoFile $ \GetHlintSettings -> do + defineNoFile (cmap LogShake recorder) $ \GetHlintSettings -> do (Config flags) <- getHlintConfig plugin liftIO $ argsSettings flags diff --git a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs index 375009af53..fa9f514a86 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -7,7 +7,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -module Ide.Plugin.RefineImports (descriptor) where +module Ide.Plugin.RefineImports (descriptor, Log) where import Control.Arrow (Arrow (second)) import Control.DeepSeq (rwhnf) @@ -37,6 +37,7 @@ import Development.IDE.GHC.Compat RealSrcSpan(..), getLoc, ieName, noLoc, tcg_exports, unLoc) -} +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph.Classes import GHC.Generics (Generic) import Ide.Plugin.ExplicitImports (extractMinimalImports, @@ -46,11 +47,13 @@ import Ide.Types import Language.LSP.Server import Language.LSP.Types +newtype Log = LogShake Shake.Log deriving Show + -- | plugin declaration -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) +descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) { pluginCommands = [refineImportCommand] - , pluginRules = refineImportsRule + , pluginRules = refineImportsRule recorder , pluginHandlers = mconcat [ -- This plugin provides code lenses mkPluginHandler STextDocumentCodeLens lensProvider @@ -163,8 +166,8 @@ newtype RefineImportsResult = RefineImportsResult instance Show RefineImportsResult where show _ = "" instance NFData RefineImportsResult where rnf = rwhnf -refineImportsRule :: Rules () -refineImportsRule = define $ \RefineImports nfp -> do +refineImportsRule :: Recorder Log -> Rules () +refineImportsRule recorder = define (cmap LogShake recorder) $ \RefineImports nfp -> do -- Get the typechecking artifacts from the module tmr <- use TypeCheck nfp -- We also need a GHC session with all the dependencies diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs index de93d03ed0..6b5d224d46 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs @@ -1,5 +1,5 @@ -- | A plugin that uses tactics to synthesize code -module Ide.Plugin.Tactic (descriptor) where +module Ide.Plugin.Tactic (descriptor, Log) where import Wingman.Plugin diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index b73d69430c..775486079e 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -36,7 +36,7 @@ import Development.IDE.Core.UseStale import Development.IDE.GHC.Compat hiding (empty) import qualified Development.IDE.GHC.Compat.Util as FastString import Development.IDE.GHC.Error (realSrcSpanToRange) -import Development.IDE.GHC.ExactPrint +import Development.IDE.GHC.ExactPrint hiding (Log) import Development.IDE.Graph (Action, RuleResult, Rules, action) import Development.IDE.Graph.Classes (Hashable, NFData) import Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings) @@ -63,8 +63,14 @@ import Wingman.Judgements.Theta import Wingman.Range import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax) import Wingman.Types +import Development.IDE.Types.Logger (Recorder, cmap) +import qualified Development.IDE.Core.Shake as Shake +newtype Log + = LogShake Shake.Log + deriving Show + tacticDesc :: T.Text -> T.Text tacticDesc name = "fill the hole using the " <> name <> " tactic" @@ -546,9 +552,9 @@ instance NFData GetMetaprograms type instance RuleResult GetMetaprograms = [(Tracked 'Current RealSrcSpan, T.Text)] -wingmanRules :: PluginId -> Rules () -wingmanRules plId = do - define $ \WriteDiagnostics nfp -> +wingmanRules :: Recorder Log -> PluginId -> Rules () +wingmanRules recorder plId = do + define (cmap LogShake recorder) $ \WriteDiagnostics nfp -> usePropertyAction #hole_severity plId properties >>= \case Nothing -> pure (mempty, Just ()) Just severity -> @@ -577,7 +583,7 @@ wingmanRules plId = do , Just () ) - defineNoDiagnostics $ \GetMetaprograms nfp -> do + defineNoDiagnostics (cmap LogShake recorder) $ \GetMetaprograms nfp -> do TrackedStale tcg tcg_map <- fmap tmrTypechecked <$> useWithStale_ TypeCheck nfp let scrutinees = traverse (metaprogramQ . tcg_binds) tcg return $ Just $ flip mapMaybe scrutinees $ \aged@(unTrack -> (ss, program)) -> do diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index d01bdbbc92..0b42774e9b 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -9,20 +9,25 @@ import Prelude hiding (span) import Wingman.AbstractLSP import Wingman.AbstractLSP.TacticActions (makeTacticInteraction) import Wingman.EmptyCase -import Wingman.LanguageServer +import Wingman.LanguageServer hiding (Log) +import qualified Wingman.LanguageServer as WingmanLanguageServer import Wingman.LanguageServer.Metaprogram (hoverProvider) import Wingman.StaticPlugin +import Development.IDE.Types.Logger (Recorder, cmap) +data Log + = LogLanguageServer WingmanLanguageServer.Log + deriving Show -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId +descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = installInteractions ( emptyCaseInteraction : fmap makeTacticInteraction [minBound .. maxBound] ) $ (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentHover hoverProvider - , pluginRules = wingmanRules plId + , pluginRules = wingmanRules (cmap LogLanguageServer recorder) plId , pluginConfigDescriptor = defaultConfigDescriptor { configCustomConfig = mkCustomConfig properties diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 71f6ad9b9b..9a14caebfe 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -15,7 +15,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Default import Data.List (sort) import qualified Data.Text as T -import Development.IDE.Core.Rules +import Development.IDE.Core.Rules hiding (Log) import Development.IDE.Core.Tracing (withTelemetryLogger) import Development.IDE.Graph (ShakeOptions (shakeThreads)) import Development.IDE.Main (isLSP) From c0190d7d2331e107462267311d0565937df6fcb2 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Fri, 7 Jan 2022 18:21:25 -0500 Subject: [PATCH 05/43] fix tests, allow old style logging and contravariant logging to write to same log file --- exe/Main.hs | 21 +++--- ghcide/src/Development/IDE/Main.hs | 18 +---- ghcide/src/Development/IDE/Types/Logger.hs | 65 ++++++++++++++++-- hls-test-utils/src/Test/Hls.hs | 76 ++++++++++++++-------- src/Ide/Main.hs | 2 - 5 files changed, 125 insertions(+), 57 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index 7e81143554..e2e7f13be6 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -9,15 +9,15 @@ import Data.Text (Text) import qualified Data.Text as Text import Development.IDE.Types.Logger (Priority (Debug, Info), WithPriority (WithPriority, priority), - cfilter, cmap, - withDefaultTextWithPriorityRecorder) + cfilter, cmap, setupHsLogger, + withDefaultTextWithPriorityRecorderAndHandle) import Ide.Arguments (Arguments (..), GhcideArguments (..), getArguments) import Ide.Main (defaultMain) import qualified Ide.Main as IdeMain import qualified Plugins - +import qualified System.Log as HsLogger data Log = LogIdeMain IdeMain.Log @@ -31,14 +31,17 @@ main :: IO () main = do args <- getArguments "haskell-language-server" (Plugins.idePlugins undefined False) - let (minPriority, logFilePath, includeExamplePlugins) = + let (hsLoggerMinLogLevel, minPriority, logFilePath, includeExamplePlugins) = case args of Ghcide GhcideArguments{ argsTesting, argsDebugOn, argsLogFile, argsExamplePlugin } -> - let minPriority = if argsDebugOn || argsTesting then Debug else Info - in (minPriority, argsLogFile, argsExamplePlugin) - _ -> (Info, Nothing, False) - - withDefaultTextWithPriorityRecorder (Just "/home/jon/bls.log") $ \textWithPriorityRecorder -> do + let (minHsLoggerLogLevel, minPriority) = + if argsDebugOn || argsTesting then (HsLogger.DEBUG, Debug) else (HsLogger.INFO, Info) + in (minHsLoggerLogLevel, minPriority, argsLogFile, argsExamplePlugin) + _ -> (HsLogger.INFO, Info, Nothing, False) + + withDefaultTextWithPriorityRecorderAndHandle logFilePath $ \textWithPriorityRecorder handle -> do + -- until the contravariant logging system is fully in place + setupHsLogger (Just handle) ["hls", "hie-bios"] hsLoggerMinLogLevel let recorder = textWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 6528c864f8..939fd6d708 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -8,7 +8,7 @@ module Development.IDE.Main ,isLSP ,commandP ,defaultMain -,testing +-- ,testing ,Log) where import Control.Concurrent.Extra (newLock, withLock, withNumCapabilities) @@ -68,7 +68,7 @@ import Development.IDE.Plugin (Plugin (pluginHandlers, import Development.IDE.Plugin.HLS (asGhcIdePlugin) import qualified Development.IDE.Plugin.HLS as PluginHLS import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide -import qualified Development.IDE.Plugin.Test as Test +-- import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Session (SessionLoadingOptions, getHieDbLoc, loadSessionWithOptions, @@ -233,20 +233,6 @@ defaultArguments recorder priority = Arguments return newStdout } -testing :: Recorder Log -> Arguments -testing recorder = - let arguments = defaultArguments recorder Debug - in - arguments { - argsHlsPlugins = pluginDescToIdePlugins $ - idePluginsToPluginDesc (argsHlsPlugins arguments) - ++ [Test.blockCommandDescriptor "block-command", Test.plugin], - argsIdeOptions = \config sessionLoader -> - let defOptions = argsIdeOptions arguments config sessionLoader - in defOptions { - optTesting = IdeTesting True - } - } -- | Cheap stderr logger that relies on LineBuffering stderrLogger :: Priority -> IO Logger diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index 22c663ec88..f723135bbe 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -12,13 +12,14 @@ module Development.IDE.Types.Logger , logError, logWarning, logInfo, logDebug, logTelemetry , noLogging , WithPriority(..) - , logWith, cmap, cmapIO, cfilter, withDefaultTextWithPriorityRecorder) where + , logWith, cmap, cmapIO, cfilter, withDefaultTextWithPriorityRecorder, makeDefaultTextWithPriorityStderrRecorder, setupHsLogger, withDefaultTextWithPriorityRecorderAndHandle) where import Control.Concurrent (myThreadId) import Control.Concurrent.Extra (newLock, withLock) -import Control.Monad (when, (>=>)) +import Control.Monad (forM_, when, (>=>)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Functor.Contravariant (Contravariant (contramap)) +import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text as Text @@ -29,9 +30,45 @@ import GHC.Stack (HasCallStack, SrcLoc (SrcLoc, srcLocModule, srcLocStartLine), getCallStack, withFrozenCallStack) import System.IO (Handle, IOMode (AppendMode), - hFlush, stderr) + hClose, hFlush, hSetEncoding, + 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 import UnliftIO (MonadUnliftIO, withFile) +-- taken from LSP.setupLogger +-- used until contravariant logging system is fully in place +setupHsLogger :: Maybe Handle -> [String] -> HSLogger.Priority -> IO () +setupHsLogger handle extraLogNames level = do + let logStream = fromMaybe stderr handle + + hSetEncoding logStream utf8 + + logH <- HSL.streamHandler logStream level + + let logHandle = logH {HSL.closeFunc = hClose} + 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" + + -- handleIOException :: FilePath -> IOException -> IO Handle + -- handleIOException logFile _ = do + -- hPutStr stderr $ "Couldn't open log file " ++ logFile ++ "; falling back to stderr logging" + -- return stderr + data Priority -- Don't change the ordering of this type or you will mess up the Ord @@ -142,11 +179,17 @@ threadSafeTextStderrRecorder = do makeThreadSafeTextStderrRecorder :: MonadIO m => m (Recorder Text) makeThreadSafeTextStderrRecorder = liftIO threadSafeTextStderrRecorder +makeDefaultTextWithPriorityStderrRecorder :: MonadIO m => m (Recorder (WithPriority Text)) +makeDefaultTextWithPriorityStderrRecorder = do + textStderrRecorder <- makeThreadSafeTextStderrRecorder + pure $ cmapIO textWithPriorityToText textStderrRecorder + withTextFileRecorder :: MonadUnliftIO m => FilePath -> (Recorder Text -> m a) -> m a -withTextFileRecorder path action = withFile path AppendMode $ \handle -> +withTextFileRecorder path action = withFile path AppendMode $ \handle -> do action (textHandleRecorder handle) -- | if no file path given use stderr, else use stderr and file +-- TODO: doesn't handle case where opening file fails withDefaultTextRecorder :: MonadUnliftIO m => Maybe FilePath -> (Recorder Text -> m a) -> m a withDefaultTextRecorder path action = do textStderrRecorder <- makeThreadSafeTextStderrRecorder @@ -160,6 +203,20 @@ withDefaultTextWithPriorityRecorder path action = do withDefaultTextRecorder path $ \textRecorder -> action (cmapIO textWithPriorityToText textRecorder) +-- temporary until contravariant logging is a thing +withDefaultTextWithPriorityRecorderAndHandle :: MonadUnliftIO m + => Maybe FilePath + -> (Recorder (WithPriority Text) -> Handle -> m a) + -> m a +withDefaultTextWithPriorityRecorderAndHandle path action = do + textStderrRecorder <- makeThreadSafeTextStderrRecorder + let textWithPriorityStderrRecorder = cmapIO textWithPriorityToText textStderrRecorder + case path of + Nothing -> action textWithPriorityStderrRecorder stderr + Just path -> withFile path AppendMode $ \handle -> do + let textWithPriorityHandleRecorder = cmapIO textWithPriorityToText (textHandleRecorder handle) + action (textWithPriorityStderrRecorder <> textWithPriorityHandleRecorder) handle + textWithPriorityToText :: WithPriority Text -> IO Text textWithPriorityToText = \case WithPriority{ priority, payload } -> do diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index b525551f8c..d3c931e341 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} module Test.Hls ( module Test.Tasty.HUnit, module Test.Tasty, @@ -47,15 +47,23 @@ import qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) import Data.Default (def) import Data.Maybe (fromMaybe) +import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text as Text import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Development.IDE (IdeState, noLogging) import Development.IDE.Graph (ShakeOptions (shakeThreads)) -import Development.IDE.Main -import qualified Development.IDE.Main as Ghcide +import Development.IDE.Main hiding (Log) +import qualified Development.IDE.Main as Ghcide hiding (Log) +import qualified Development.IDE.Main as IDEMain import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), WaitForIdeRuleResult (ideResultSuccess)) +import qualified Development.IDE.Plugin.Test as Test +import Development.IDE.Types.Logger (Priority (Debug), Recorder, + WithPriority (WithPriority), + cmap, + makeDefaultTextWithPriorityStderrRecorder) import Development.IDE.Types.Options import GHC.IO.Handle import Ide.Plugin.Config (Config, formattingProvider) @@ -82,6 +90,8 @@ import Test.Tasty.Golden import Test.Tasty.HUnit import Test.Tasty.Ingredients.Rerun +newtype Log = LogIDEMain IDEMain.Log deriving Show + -- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes defaultTestRunner :: TestTree -> IO () defaultTestRunner = defaultMainWithRerun . adjustOption (const $ mkTimeout 600000000) @@ -151,6 +161,9 @@ keepCurrentDirectory = bracket getCurrentDirectory setCurrentDirectory . const lock :: Lock lock = unsafePerformIO newLock +logToTextWithPriority :: Log -> WithPriority Text +logToTextWithPriority = WithPriority Debug . Text.pack . show + -- | Host a server, and run a test session on it -- Note: cwd will be shifted into @root@ in @Session a@ runSessionWithServer' :: @@ -164,31 +177,42 @@ runSessionWithServer' :: FilePath -> Session a -> IO a -runSessionWithServer' plugin conf sconf caps root s = withLock lock $ keepCurrentDirectory $ do +runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurrentDirectory $ do (inR, inW) <- createPipe (outR, outW) <- createPipe - let logger = do - logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR" - if logStdErr == "0" - then return noLogging - else argsLogger testing + + textWithPriorityRecorder <- makeDefaultTextWithPriorityStderrRecorder + + let + recorder = cmap logToTextWithPriority textWithPriorityRecorder + arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments mempty Debug + hlsPlugins = + idePluginsToPluginDesc argsHlsPlugins + ++ [Test.blockCommandDescriptor "block-command", Test.plugin] + ++ plugins + ideOptions = \config ghcSession -> + let defIdeOptions@IdeOptions{ optShakeOptions } = argsIdeOptions config ghcSession + in defIdeOptions + { optTesting = IdeTesting True + , optCheckProject = pure False + , optShakeOptions = optShakeOptions{ shakeThreads = 2 } + } + logger = do + logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR" + if logStdErr == "0" then return noLogging else argsLogger server <- async $ Ghcide.defaultMain - testing - { argsHandleIn = pure inR, - argsHandleOut = pure outW, - argsDefaultHlsConfig = conf, - argsLogger = logger, - argsIdeOptions = \config sessionLoader -> - let ideOptions = (argsIdeOptions def config sessionLoader) - {optTesting = IdeTesting True - ,optCheckProject = pure False - } - in ideOptions {optShakeOptions = (optShakeOptions ideOptions) {shakeThreads = 2}}, - argsHlsPlugins = pluginDescToIdePlugins $ plugin ++ idePluginsToPluginDesc (argsHlsPlugins testing) - } + (cmap LogIDEMain recorder) + arguments + { argsHandleIn = pure inR + , argsHandleOut = pure outW + , argsDefaultHlsConfig = conf + , argsLogger = logger + , argsIdeOptions = ideOptions + , argsHlsPlugins = pluginDescToIdePlugins hlsPlugins } + x <- runSessionWithHandles inW outR sconf caps root s hClose inW timeout 3 (wait server) >>= \case diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 9a14caebfe..6db26c164f 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -107,8 +107,6 @@ runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLog whenJust argsCwd IO.setCurrentDirectory dir <- IO.getCurrentDirectory log $ LogDirectory dir - LSP.setupLogger argsLogFile ["hls", "hie-bios"] - $ if argsDebugOn then L.DEBUG else L.INFO when (isLSP argsCommand) $ do log $ LogLsp ghcideArgs (map fst $ ipMap idePlugins) From 994683088ee1ebeb448e20863e831ba221445b22 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Fri, 7 Jan 2022 19:16:12 -0500 Subject: [PATCH 06/43] fix import inside wrong CPP --- exe/Plugins.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 703d305b04..dcbfcd4a96 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} module Plugins where +import Development.IDE.Types.Logger (Recorder, cmap) import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types (IdePlugins) @@ -91,13 +92,11 @@ import qualified Ide.Plugin.StylishHaskell as StylishHaskell #endif #if brittany -import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide -import Development.IDE.Types.Logger (Recorder, cmap) import qualified Ide.Plugin.Brittany as Brittany #endif data Log - = LogGhcide Ghcide.Log + = LogGhcIde GhcIde.Log | LogExample Example.Log | LogExample2 Example2.Log | LogTactic Tactic.Log @@ -184,7 +183,7 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins #endif -- The ghcide descriptors should come last so that the notification handlers -- (which restart the Shake build) run after everything else - GhcIde.descriptors (cmap LogGhcide recorder) + GhcIde.descriptors (cmap LogGhcIde recorder) examplePlugins = [Example.descriptor (cmap LogExample recorder) "eg" ,Example2.descriptor (cmap LogExample2 recorder) "eg2" From 20a3761a0ee33f49d3a2b0ee53e3e7c901cbe048 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Fri, 7 Jan 2022 19:27:37 -0500 Subject: [PATCH 07/43] add CPP for LogTactic constructor --- exe/Plugins.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/exe/Plugins.hs b/exe/Plugins.hs index dcbfcd4a96..e74ffc40df 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -99,7 +99,9 @@ data Log = LogGhcIde GhcIde.Log | LogExample Example.Log | LogExample2 Example2.Log +#if tactic | LogTactic Tactic.Log +#endif | LogEval Eval.Log | LogExplicitImports ExplicitImports.Log | LogRefineImports RefineImports.Log From 528439c20d3aeed640aa057de268442cbff66913 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Fri, 7 Jan 2022 20:04:31 -0500 Subject: [PATCH 08/43] remove redundant import --- hls-test-utils/src/Test/Hls.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index d3c931e341..7f881b7dd1 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -60,7 +60,7 @@ import qualified Development.IDE.Main as IDEMain import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), WaitForIdeRuleResult (ideResultSuccess)) import qualified Development.IDE.Plugin.Test as Test -import Development.IDE.Types.Logger (Priority (Debug), Recorder, +import Development.IDE.Types.Logger (Priority (Debug), WithPriority (WithPriority), cmap, makeDefaultTextWithPriorityStderrRecorder) From e69839d2d9ec914ce2bd13430dfcb5c685a94d9e Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Fri, 7 Jan 2022 21:50:28 -0500 Subject: [PATCH 09/43] fix ghcide tests --- ghcide/exe/Main.hs | 53 ++++++++++++++----- .../session-loader/Development/IDE/Session.hs | 2 +- ghcide/src/Development/IDE/Main.hs | 21 +++++++- ghcide/test/exe/HieDbRetry.hs | 42 +++++++++------ ghcide/test/exe/Main.hs | 34 +++++++++--- 5 files changed, 112 insertions(+), 40 deletions(-) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index c743231255..9e5e1c35bf 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -9,16 +9,23 @@ import Arguments (Arguments (..), getArguments) import Control.Monad.Extra (unless) import Data.Default (def) +import Data.Function ((&)) +import Data.Text (Text) +import qualified Data.Text as Text import Data.Version (showVersion) import Development.GitRev (gitHash) import Development.IDE (Priority (Debug, Info), - action) + action, + makeDefaultTextWithPriorityStderrRecorder) import Development.IDE.Core.OfInterest (kick) import Development.IDE.Core.Rules (mainRule) +import qualified Development.IDE.Core.Rules as Rules import Development.IDE.Core.Tracing (withTelemetryLogger) import Development.IDE.Graph (ShakeOptions (shakeThreads)) -import qualified Development.IDE.Main as Main +import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde +import Development.IDE.Types.Logger (WithPriority (WithPriority, priority), + cfilter, cmap) import Development.IDE.Types.Options import Ide.Plugin.Config (Config (checkParents, checkProject)) import Ide.PluginUtils (pluginDescToIdePlugins) @@ -29,6 +36,11 @@ import System.Exit (exitSuccess) import System.IO (hPutStrLn, stderr) import System.Info (compilerVersion) +data Log + = LogIDEMain IDEMain.Log + | LogRules Rules.Log + deriving Show + ghcideVersion :: IO String ghcideVersion = do path <- getExecutablePath @@ -40,9 +52,12 @@ ghcideVersion = do <> ") (PATH: " <> path <> ")" <> gitHashSection +logToTextWithPriority :: Log -> WithPriority Text +logToTextWithPriority = WithPriority Info . Text.pack . show + main :: IO () main = withTelemetryLogger $ \telemetryLogger -> do - let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors + let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors mempty) -- WARNING: If you write to stdout before runLanguageServer -- then the language server will not work Arguments{..} <- getArguments hlsPlugins @@ -55,26 +70,36 @@ main = withTelemetryLogger $ \telemetryLogger -> do Nothing -> IO.getCurrentDirectory Just root -> IO.setCurrentDirectory root >> IO.getCurrentDirectory - let logPriority = if argsVerbose then Debug else Info - arguments = if argsTesting then Main.testing else Main.defaultArguments logPriority + let minPriority = if argsVerbose then Debug else Info + + textWithPriorityStderrRecorder <- makeDefaultTextWithPriorityStderrRecorder + + let recorder = textWithPriorityStderrRecorder + & cfilter (\WithPriority{ priority } -> priority >= minPriority) + & cmap logToTextWithPriority + + let arguments = + if argsTesting + then IDEMain.testing (cmap LogIDEMain recorder) + else IDEMain.defaultArguments (cmap LogIDEMain recorder) minPriority - Main.defaultMain arguments - { Main.argsProjectRoot = Just argsCwd - , Main.argCommand = argsCommand - ,Main.argsLogger = Main.argsLogger arguments <> pure telemetryLogger + IDEMain.defaultMain (cmap LogIDEMain recorder) arguments + { IDEMain.argsProjectRoot = Just argsCwd + , IDEMain.argCommand = argsCommand + , IDEMain.argsLogger = IDEMain.argsLogger arguments <> pure telemetryLogger - ,Main.argsRules = do + , IDEMain.argsRules = do -- install the main and ghcide-plugin rules - mainRule def + mainRule (cmap LogRules recorder) def -- install the kick action, which triggers a typecheck on every -- Shake database restart, i.e. on every user edit. unless argsDisableKick $ action kick - ,Main.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i) + , IDEMain.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i) - ,Main.argsIdeOptions = \config sessionLoader -> - let defOptions = Main.argsIdeOptions arguments config sessionLoader + , IDEMain.argsIdeOptions = \config sessionLoader -> + let defOptions = IDEMain.argsIdeOptions arguments config sessionLoader in defOptions { optShakeProfiling = argsShakeProfiling , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 01a1b85fd9..a7f19bf47a 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -15,7 +15,7 @@ module Development.IDE.Session ,runWithDb ,retryOnSqliteBusy ,retryOnException - ,Log + ,Log(..) ) where -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 939fd6d708..29ade68395 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -9,7 +9,7 @@ module Development.IDE.Main ,commandP ,defaultMain -- ,testing -,Log) where +,Log, testing) where import Control.Concurrent.Extra (newLock, withLock, withNumCapabilities) import Control.Concurrent.STM.Stats (atomically, @@ -69,6 +69,7 @@ import Development.IDE.Plugin.HLS (asGhcIdePlugin) import qualified Development.IDE.Plugin.HLS as PluginHLS import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide -- import qualified Development.IDE.Plugin.Test as Test +import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Session (SessionLoadingOptions, getHieDbLoc, loadSessionWithOptions, @@ -241,6 +242,24 @@ stderrLogger logLevel = do return $ Logger $ \p m -> when (p >= logLevel) $ withLock lock $ T.hPutStrLn stderr $ "[" <> T.pack (show p) <> "] " <> m +testing :: Recorder Log -> Arguments +testing recorder = + let + arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = defaultArguments recorder Debug + hlsPlugins = pluginDescToIdePlugins $ + idePluginsToPluginDesc argsHlsPlugins + ++ [Test.blockCommandDescriptor "block-command", Test.plugin] + ideOptions = \config sessionLoader -> + let + defOptions = argsIdeOptions config sessionLoader + in + defOptions{ optTesting = IdeTesting True } + in + arguments + { argsHlsPlugins = hlsPlugins + , argsIdeOptions = ideOptions + } + data Log = LogHeapStats !HeapStats.Log | LogLspStart diff --git a/ghcide/test/exe/HieDbRetry.hs b/ghcide/test/exe/HieDbRetry.hs index f3a29cea39..f76da0cb44 100644 --- a/ghcide/test/exe/HieDbRetry.hs +++ b/ghcide/test/exe/HieDbRetry.hs @@ -5,25 +5,33 @@ import Control.Concurrent.Extra (Var, modifyVar, newVar, readVar, withVar) import Control.Exception (ErrorCall (ErrorCall), evaluate, throwIO, tryJust) -import Data.Text (Text) +import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Tuple.Extra (dupe) import qualified Database.SQLite.Simple as SQLite import Development.IDE.Session (retryOnException, retryOnSqliteBusy) -import Development.IDE.Types.Logger (Logger (Logger), Priority, - noLogging) +import qualified Development.IDE.Session as Session +import Development.IDE.Types.Logger (Recorder (Recorder, logger_), + cmap) import qualified System.Random as Random import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) -makeLogger :: Var [(Priority, Text)] -> Logger -makeLogger msgsVar = Logger $ \priority msg -> modifyVar msgsVar (\msgs -> pure ((priority, msg) : msgs, ())) +data Log + = LogSession Session.Log + deriving Show + +makeLogger :: Var [Log] -> Recorder Log +makeLogger msgsVar = + Recorder { + logger_ = \msg -> liftIO $ modifyVar msgsVar (\msgs -> pure (msg : msgs, ())) + } rng :: Random.StdGen rng = Random.mkStdGen 0 -retryOnSqliteBusyForTest :: Logger -> Int -> IO a -> IO a -retryOnSqliteBusyForTest logger maxRetryCount = retryOnException isErrorBusy logger 1 1 maxRetryCount rng +retryOnSqliteBusyForTest :: Recorder Log -> Int -> IO a -> IO a +retryOnSqliteBusyForTest recorder maxRetryCount = retryOnException isErrorBusy (cmap LogSession recorder) 1 1 maxRetryCount rng isErrorBusy :: SQLite.SQLError -> Maybe SQLite.SQLError isErrorBusy e @@ -60,7 +68,7 @@ tests = testGroup "RetryHieDb" let expected = 1 :: Int let maxRetryCount = 0 - actual <- retryOnSqliteBusyForTest noLogging maxRetryCount (pure expected) + actual <- retryOnSqliteBusyForTest mempty maxRetryCount (pure expected) actual @?= expected @@ -69,7 +77,7 @@ tests = testGroup "RetryHieDb" let maxRetryCount = 3 let incrementThenThrow = modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy - _ <- tryJust isErrorBusy (retryOnSqliteBusyForTest noLogging maxRetryCount incrementThenThrow) + _ <- tryJust isErrorBusy (retryOnSqliteBusyForTest mempty maxRetryCount incrementThenThrow) withVar countVar $ \count -> count @?= maxRetryCount + 1 @@ -86,7 +94,7 @@ tests = testGroup "RetryHieDb" modifyVar countVar (\count -> pure (dupe (count + 1))) - _ <- tryJust isErrorCall (retryOnSqliteBusyForTest noLogging maxRetryCount throwThenIncrement) + _ <- tryJust isErrorCall (retryOnSqliteBusyForTest mempty maxRetryCount throwThenIncrement) withVar countVar $ \count -> count @?= 0 @@ -101,27 +109,29 @@ tests = testGroup "RetryHieDb" else modifyVar countVar (\count -> pure (dupe (count + 1))) - _ <- retryOnSqliteBusy noLogging rng incrementThenThrowThenIncrement + _ <- retryOnSqliteBusy mempty rng incrementThenThrowThenIncrement withVar countVar $ \count -> count @?= 2 , testCase "retryOnException exponentially backs off" $ do - logMsgsVar <- newVar ([] :: [(Priority, Text)]) + logMsgsVar <- newVar ([] :: [Log]) let maxDelay = 100 let baseDelay = 1 let maxRetryCount = 6 let logger = makeLogger logMsgsVar - result <- tryJust isErrorBusy (retryOnException isErrorBusy logger maxDelay baseDelay maxRetryCount rng (throwIO errorBusy)) + result <- tryJust isErrorBusy (retryOnException isErrorBusy (cmap LogSession logger) maxDelay baseDelay maxRetryCount rng (throwIO errorBusy)) case result of Left _ -> do withVar logMsgsVar $ \logMsgs -> - if | ((_, lastLogMsg) : _) <- logMsgs -> - -- uses log messages to indirectly check backoff... - lastLogMsg @?= "Retries exhausted - base delay: 64, maximumDelay: 100, maxRetryCount: 0, exception: SQLite3 returned ErrorBusy while attempting to perform : " + -- uses log messages to check backoff... + if | (LogSession (Session.LogHieDbRetriesExhausted baseDelay maximumDelay maxRetryCount _) : _) <- logMsgs -> do + baseDelay @?= 64 + maximumDelay @?= 100 + maxRetryCount @?= 0 | otherwise -> assertFailure "Expected more than 0 log messages" Right _ -> assertFailure "Expected ErrorBusy exception" ] diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 9e221a8e08..0361b1fa30 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -115,6 +115,15 @@ import Test.Tasty.QuickCheck import Text.Printf (printf) import Text.Regex.TDFA ((=~)) import qualified HieDbRetry +import Development.IDE.Types.Logger (WithPriority(WithPriority), makeDefaultTextWithPriorityStderrRecorder, Priority (Info), cmap, Recorder) +import Data.Function ((&)) +import qualified Data.Text as Text +import Data.Text (Text) + +data Log + = LogGhcIde Ghcide.Log + | LogIDEMain IDE.Log + deriving Show -- | Wait for the next progress begin step waitForProgressBegin :: Session () @@ -142,8 +151,17 @@ waitForAllProgressDone = loop done <- null <$> getIncompleteProgressSessions unless done loop +-- TODO: change so all messages aren't Info +logToTextWithPriority :: Log -> WithPriority Text +logToTextWithPriority = WithPriority Info . Text.pack . show + main :: IO () main = do + textWithPriorityStderrRecorder <- makeDefaultTextWithPriorityStderrRecorder + + let recorder = textWithPriorityStderrRecorder + & cmap logToTextWithPriority + -- We mess with env vars so run single-threaded. defaultMainWithRerun $ testGroup "ghcide" [ testSession "open close" $ do @@ -167,7 +185,7 @@ main = do , thTests , symlinkTests , safeTests - , unitTests + , unitTests recorder , haddockTests , positionMappingTests , watchedFilesTests @@ -6088,8 +6106,8 @@ findCodeActions' op errMsg doc range expectedTitles = do findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction findCodeAction doc range t = head <$> findCodeActions doc range [t] -unitTests :: TestTree -unitTests = do +unitTests :: Recorder Log -> TestTree +unitTests recorder = do testGroup "Unit" [ testCase "empty file path does NOT work with the empty String literal" $ uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "." @@ -6129,9 +6147,9 @@ unitTests = do ] } | i <- [(1::Int)..20] - ] ++ Ghcide.descriptors + ] ++ Ghcide.descriptors (cmap LogGhcIde recorder) - testIde IDE.testing{IDE.argsHlsPlugins = plugins} $ do + testIde recorder (IDE.testing (cmap LogIDEMain recorder)){IDE.argsHlsPlugins = plugins} $ do _ <- createDoc "haskell" "A.hs" "module A where" waitForProgressDone actualOrder <- liftIO $ readIORef orderRef @@ -6229,12 +6247,12 @@ findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do if t /= t' then return delay_us else findResolution_us (delay_us * 10) -testIde :: IDE.Arguments -> Session () -> IO () -testIde arguments session = do +testIde :: Recorder Log -> IDE.Arguments -> Session () -> IO () +testIde recorder arguments session = do config <- getConfigFromEnv (hInRead, hInWrite) <- createPipe (hOutRead, hOutWrite) <- createPipe - let server = IDE.defaultMain arguments + let server = IDE.defaultMain (cmap LogIDEMain recorder) arguments { IDE.argsHandleIn = pure hInRead , IDE.argsHandleOut = pure hOutWrite } From e6b4bd7d319154d62e30da1ea94dd84f3b145fe7 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Fri, 7 Jan 2022 22:56:34 -0500 Subject: [PATCH 10/43] remove unused import --- src/Ide/Main.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 6db26c164f..89ea28b29e 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -30,10 +30,7 @@ import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, import Ide.Types (IdePlugins, PluginId (PluginId), ipMap) import Ide.Version -import qualified Language.LSP.Server as LSP import qualified System.Directory.Extra as IO -import System.IO -import qualified System.Log.Logger as L data Log = LogVersion !String From fb5033a2154fef33a9d46c0f316cb57dfa455318 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Fri, 7 Jan 2022 23:16:08 -0500 Subject: [PATCH 11/43] fix plugin tests --- plugins/hls-alternate-number-format-plugin/test/Main.hs | 2 +- plugins/hls-eval-plugin/test/Main.hs | 2 +- plugins/hls-explicit-imports-plugin/test/Main.hs | 2 +- plugins/hls-hlint-plugin/test/Main.hs | 2 +- plugins/hls-refine-imports-plugin/test/Main.hs | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/plugins/hls-alternate-number-format-plugin/test/Main.hs b/plugins/hls-alternate-number-format-plugin/test/Main.hs index cda83db6b7..f37ec9e4f0 100644 --- a/plugins/hls-alternate-number-format-plugin/test/Main.hs +++ b/plugins/hls-alternate-number-format-plugin/test/Main.hs @@ -21,7 +21,7 @@ main :: IO () main = defaultTestRunner test alternateNumberFormatPlugin :: PluginDescriptor IdeState -alternateNumberFormatPlugin = AlternateNumberFormat.descriptor "alternateNumberFormat" +alternateNumberFormatPlugin = AlternateNumberFormat.descriptor mempty "alternateNumberFormat" -- NOTE: For whatever reason, this plugin does not play nice with creating Code Actions on time. diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index 6c69dbbaa7..615b8bc402 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -25,7 +25,7 @@ main :: IO () main = defaultTestRunner tests evalPlugin :: PluginDescriptor IdeState -evalPlugin = Eval.descriptor "eval" +evalPlugin = Eval.descriptor mempty "eval" tests :: TestTree tests = diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index 3bf8b57fec..1395fac5e8 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -16,7 +16,7 @@ import System.FilePath ((<.>), ()) import Test.Hls explicitImportsPlugin :: PluginDescriptor IdeState -explicitImportsPlugin = ExplicitImports.descriptor "explicitImports" +explicitImportsPlugin = ExplicitImports.descriptor mempty "explicitImports" main :: IO () diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 86bbfad319..c5a12f4704 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -23,7 +23,7 @@ main :: IO () main = defaultTestRunner tests hlintPlugin :: PluginDescriptor IdeState -hlintPlugin = HLint.descriptor "hlint" +hlintPlugin = HLint.descriptor mempty "hlint" tests :: TestTree tests = testGroup "hlint" [ diff --git a/plugins/hls-refine-imports-plugin/test/Main.hs b/plugins/hls-refine-imports-plugin/test/Main.hs index 18b021b29d..bbd1ad6958 100644 --- a/plugins/hls-refine-imports-plugin/test/Main.hs +++ b/plugins/hls-refine-imports-plugin/test/Main.hs @@ -24,7 +24,7 @@ main = defaultTestRunner $ ] refineImportsPlugin :: PluginDescriptor IdeState -refineImportsPlugin = RefineImports.descriptor "refineImports" +refineImportsPlugin = RefineImports.descriptor mempty "refineImports" -- code action tests From 4cfa7377c6f42218caae2854d51d8dc355f56429 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Fri, 7 Jan 2022 23:19:42 -0500 Subject: [PATCH 12/43] LSP_TEST_STDERR should apply to contra logger as well --- hls-test-utils/src/Test/Hls.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 7f881b7dd1..cffba47d8f 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -183,8 +183,10 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre textWithPriorityRecorder <- makeDefaultTextWithPriorityStderrRecorder + logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR" + let - recorder = cmap logToTextWithPriority textWithPriorityRecorder + recorder = if logStdErr == "0" then mempty else cmap logToTextWithPriority textWithPriorityRecorder arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments mempty Debug hlsPlugins = idePluginsToPluginDesc argsHlsPlugins @@ -198,7 +200,6 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre , optShakeOptions = optShakeOptions{ shakeThreads = 2 } } logger = do - logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR" if logStdErr == "0" then return noLogging else argsLogger server <- From c87465713bfcd08e8ad5d8eed28e659d28dabd41 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Fri, 7 Jan 2022 23:33:10 -0500 Subject: [PATCH 13/43] fix tactic plugin test --- plugins/hls-tactics-plugin/test/Utils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs index fa516193da..63b3a37508 100644 --- a/plugins/hls-tactics-plugin/test/Utils.hs +++ b/plugins/hls-tactics-plugin/test/Utils.hs @@ -33,7 +33,7 @@ import Wingman.Types plugin :: PluginDescriptor IdeState -plugin = Tactic.descriptor "tactics" +plugin = Tactic.descriptor mempty "tactics" ------------------------------------------------------------------------------ -- | Get a range at the given line and column corresponding to having nothing From 2b3b3b35b79935b6a48e6842ede9dd7689e2f23b Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Sun, 9 Jan 2022 13:52:23 -0500 Subject: [PATCH 14/43] use CPP for Log datatype plugin constructors, remove unused imports --- exe/Main.hs | 2 +- exe/Plugins.hs | 10 ++++++++++ ghcide/src/Development/IDE/Main.hs | 12 +++++------- 3 files changed, 16 insertions(+), 8 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index e2e7f13be6..dd41802fe6 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -29,7 +29,7 @@ logToTextWithPriority = WithPriority Info . Text.pack . show main :: IO () main = do - args <- getArguments "haskell-language-server" (Plugins.idePlugins undefined False) + args <- getArguments "haskell-language-server" (Plugins.idePlugins mempty False) let (hsLoggerMinLogLevel, minPriority, logFilePath, includeExamplePlugins) = case args of diff --git a/exe/Plugins.hs b/exe/Plugins.hs index e74ffc40df..1cfd3ff899 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -102,11 +102,21 @@ data Log #if tactic | LogTactic Tactic.Log #endif +#if eval | LogEval Eval.Log +#endif +#if importLens | LogExplicitImports ExplicitImports.Log +#endif +#if refineImports | LogRefineImports RefineImports.Log +#endif +#if hlint | LogHlint Hlint.Log +#endif +#if alternateNumberFormat | LogAlternateNumberFormat AlternateNumberFormat.Log +#endif deriving Show -- --------------------------------------------------------------------- diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 29ade68395..39ba966af6 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -14,8 +14,7 @@ import Control.Concurrent.Extra (newLock, withLock, withNumCapabilities) import Control.Concurrent.STM.Stats (atomically, dumpSTMStats) -import Control.Exception.Safe (Exception (displayException), - SomeException, catchAny) +import Control.Exception.Safe (SomeException, catchAny) import Control.Monad.Extra (concatMapM, unless, when) import qualified Data.Aeson.Encode.Pretty as A @@ -67,7 +66,7 @@ import qualified Development.IDE.Main.HeapStats as HeapStats import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) import Development.IDE.Plugin.HLS (asGhcIdePlugin) import qualified Development.IDE.Plugin.HLS as PluginHLS -import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide +import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde -- import qualified Development.IDE.Plugin.Test as Test import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Session (SessionLoadingOptions, @@ -126,8 +125,7 @@ import System.IO (BufferMode (LineBufferin hSetEncoding, stderr, stdin, stdout, utf8) import System.Random (newStdGen) -import System.Time.Extra (Seconds, offsetTime, - showDuration) +import System.Time.Extra (Seconds, offsetTime) import Text.Printf (printf) data Command @@ -206,7 +204,7 @@ defaultArguments recorder priority = Arguments , argsLogger = stderrLogger priority , argsRules = mainRule (cmap LogRules recorder) def >> action kick , argsGhcidePlugin = mempty - , argsHlsPlugins = pluginDescToIdePlugins (Ghcide.descriptors (cmap LogGhcide recorder)) + , argsHlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmap LogGhcIde recorder)) , argsSessionLoadingOptions = def , argsIdeOptions = \config ghcSession -> (defaultIdeOptions ghcSession) { optCheckProject = pure $ checkProject config @@ -277,7 +275,7 @@ data Log -- (logDebug logger $ T.pack $ "setInitialDynFlags: " ++ displayException e) | LogService Service.Log | LogShake Shake.Log - | LogGhcide Ghcide.Log + | LogGhcIde GhcIde.Log | LogLanguageServer LanguageServer.Log | LogSession Session.Log | LogPluginHLS PluginHLS.Log From 23a57c2322705f5bb2e86352551d8f3351491738 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Sun, 9 Jan 2022 18:10:40 -0500 Subject: [PATCH 15/43] add a few Pretty instances, add prettyprinter to haskell-language-sever and hls-plugin-api dependencies --- exe/Main.hs | 14 +++++- ghcide/src/Development/IDE/Core/Service.hs | 8 +++ ghcide/src/Development/IDE/Core/Shake.hs | 53 ++++++++++++++++++-- ghcide/src/Development/IDE/Main.hs | 32 ++++++++++-- ghcide/src/Development/IDE/Main/HeapStats.hs | 26 ++++++++-- haskell-language-server.cabal | 1 + hls-plugin-api/hls-plugin-api.cabal | 1 + hls-plugin-api/src/Ide/Types.hs | 3 ++ src/Ide/Arguments.hs | 15 ++++-- src/Ide/Main.hs | 18 ++++++- 10 files changed, 154 insertions(+), 17 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index dd41802fe6..7007e463b1 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -17,6 +17,9 @@ import Ide.Arguments (Arguments (..), import Ide.Main (defaultMain) import qualified Ide.Main as IdeMain import qualified Plugins +import Prettyprinter (Pretty (pretty)) +import qualified Prettyprinter +import qualified Prettyprinter.Render.Text as Prettyprinter import qualified System.Log as HsLogger data Log @@ -24,8 +27,17 @@ data Log | LogPlugins Plugins.Log deriving Show +instance Pretty Log where + pretty log = case log of + LogIdeMain ideMainLog -> pretty ideMainLog + LogPlugins log' -> mempty + logToTextWithPriority :: Log -> WithPriority Text -logToTextWithPriority = WithPriority Info . Text.pack . show +logToTextWithPriority = + WithPriority Info + . Prettyprinter.renderStrict + . Prettyprinter.layoutPretty Prettyprinter.defaultLayoutOptions + . pretty main :: IO () main = do diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index 304eb28606..00cd6a7b4d 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -35,6 +35,7 @@ import qualified Development.IDE.Core.OfInterest as OfInterest import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Shake (WithHieDb) +import Prettyprinter (Pretty (pretty)) import System.Environment (lookupEnv) @@ -44,6 +45,13 @@ data Log | LogFileExists FileExists.Log deriving Show +instance Pretty Log where + pretty log = case log of + LogShake log -> pretty log + LogOfInterest log -> mempty + LogFileExists log -> mempty + + ------------------------------------------------------------ -- Exposed API diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index e4732e420f..187af0103f 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -150,7 +150,6 @@ import Language.LSP.Types.Capabilities import OpenTelemetry.Eventlog import Control.Concurrent.STM.Stats (atomicallyNamed) -import Control.Exception.Base (SomeException (SomeException)) import Control.Exception.Extra hiding (bracket_) import Data.Aeson (toJSON) import qualified Data.ByteString.Char8 as BS8 @@ -160,9 +159,7 @@ import Data.Foldable (for_, toList) import Data.HashSet (HashSet) import qualified Data.HashSet as HSet import Data.String (fromString) -import Data.Text (pack) import Debug.Trace.Flags (userTracingEnabled) -import Development.IDE.Types.Action (DelayedActionInternal) import qualified Development.IDE.Types.Exports as ExportsMap import qualified Focus import HieDb.Types @@ -170,6 +167,8 @@ import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS import Ide.Types (PluginId) import qualified "list-t" ListT +import Prettyprinter (Pretty (pretty), (<+>)) +import qualified Prettyprinter import qualified StmContainers.Map as STM data Log @@ -178,8 +177,24 @@ data Log | LogCreateHieDbExportsMapFinish !Int -- logDebug logger $ "Done initializing exports map from hiedb (" <> pack(show (ExportsMap.size em)) <> ")" | LogBuildSessionRestart !String ![DelayedActionInternal] !(HashSet Key) !Seconds !(Maybe FilePath) + -- let profile = case res of + -- Just fp -> ", profile saved at " <> fp + -- _ -> "" + -- log $ LogBuildSessionRestart reason queue backlog stopTime res + -- -- TODO: should eventually replace with logging using a logger that sends lsp message + -- let msg = T.pack $ "Restarting build session " ++ reason' ++ queueMsg ++ keysMsg ++ abortMsg + -- reason' = "due to " ++ reason + -- queueMsg = " with queue " ++ show (map actionName queue) + -- keysMsg = " for keys " ++ show (HSet.toList backlog) ++ " " + -- abortMsg = "(aborting the previous one took " ++ showDuration stopTime ++ profile ++ ")" | LogDelayedAction !(DelayedAction ()) !Seconds + -- let msg = T.pack $ "finish: " ++ actionName d + -- ++ " (took " ++ showDuration runTime ++ ")" | LogBuildSessionFinish !(Maybe SomeException) + -- let res' = case res of + -- Left e -> "exception: " <> displayException e + -- Right _ -> "completed" + -- let msg = T.pack $ "Finishing build session(" ++ res' ++ ")" | LogDiagsDiffButNoLspEnv ![FileDiagnostic] -- logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags | LogDefineEarlyCutoffRuleNoDiagDiags ![FileDiagnostic] @@ -188,6 +203,37 @@ data Log -- RuleWithCustomNewnessCheck mapM_ (\d -> liftIO $ logWarning logger $ showDiagnosticsColored [d]) diags deriving Show +instance Pretty Log where + pretty log = case log of + LogCreateHieDbExportsMapStart -> + "Initializing exports map from hiedb" + LogCreateHieDbExportsMapFinish exportsMapSize -> + "Done initializing exports map from hiedb. Size:" <+> pretty exportsMapSize + LogBuildSessionRestart reason actionQueue keyBackLog abortDuration shakeProfilePath -> + Prettyprinter.vcat + [ "Restarting build session due to" <+> pretty reason + , "Action Queue:" <+> pretty (map actionName actionQueue) + , "Keys:" <+> pretty (map show $ HSet.toList keyBackLog) + , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ] + LogDelayedAction delayedAction duration -> + Prettyprinter.hsep + [ "Finished:" <+> pretty (actionName delayedAction) + , "Took:" <+> pretty (showDuration duration) ] + LogBuildSessionFinish e -> + Prettyprinter.vcat + [ "Finished build session" + , pretty (fmap displayException e) ] + LogDiagsDiffButNoLspEnv fileDiagnostics -> + "updateFileDiagnostics published different from new diagnostics - file diagnostics:" + <+> pretty (showDiagnosticsColored fileDiagnostics) + LogDefineEarlyCutoffRuleNoDiagDiags fileDiagnostics -> + "defineEarlyCutoff RuleNoDiagnostics - file diagnostics:" + <+> pretty (showDiagnosticsColored fileDiagnostics) + LogDefineEarlyCutoffRuleCustomNewnessDiags fileDiagnostics -> + "defineEarlyCutoff RuleWithCustomNewnessCheck - file diagnostics:" + <+> pretty (showDiagnosticsColored fileDiagnostics) + + -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by -- a worker thread. @@ -665,6 +711,7 @@ shakeRestart recorder IdeState{..} reason acts = let profile = case res of Just fp -> ", profile saved at " <> fp _ -> "" + -- TODO: should replace with logging using a logger that sends lsp message let msg = T.pack $ "Restarting build session " ++ reason' ++ queueMsg ++ keysMsg ++ abortMsg reason' = "due to " ++ reason queueMsg = " with queue " ++ show (map actionName queue) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 39ba966af6..5f18b6cce9 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -14,7 +14,8 @@ import Control.Concurrent.Extra (newLock, withLock, withNumCapabilities) import Control.Concurrent.STM.Stats (atomically, dumpSTMStats) -import Control.Exception.Safe (SomeException, catchAny) +import Control.Exception.Safe (SomeException, catchAny, + displayException) import Control.Monad.Extra (concatMapM, unless, when) import qualified Data.Aeson.Encode.Pretty as A @@ -112,6 +113,8 @@ import qualified Language.LSP.Server as LSP import qualified "list-t" ListT import Numeric.Natural (Natural) import Options.Applicative hiding (action) +import Prettyprinter (Pretty (pretty), (<+>)) +import qualified Prettyprinter import qualified StmContainers.Map as STM import qualified System.Directory.Extra as IO import System.Exit (ExitCode (ExitFailure), @@ -125,7 +128,8 @@ import System.IO (BufferMode (LineBufferin hSetEncoding, stderr, stdin, stdout, utf8) import System.Random (newStdGen) -import System.Time.Extra (Seconds, offsetTime) +import System.Time.Extra (Seconds, offsetTime, + showDuration) import Text.Printf (printf) data Command @@ -138,7 +142,6 @@ data Command | Custom {ideCommand :: IdeCommand IdeState} -- ^ User defined deriving Show - -- TODO move these to hiedb deriving instance Show HieDb.Command deriving instance Show HieDb.Options @@ -282,6 +285,29 @@ data Log | LogRules Rules.Log deriving Show +instance Pretty Log where + pretty log = case log of + LogHeapStats heapStatsLog -> pretty heapStatsLog + LogLspStart -> + Prettyprinter.vsep + [ "Staring LSP server..." + , "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"] + LogLspStartDuration duration -> + "Started LSP server in" <+> pretty (showDuration duration) + LogShouldRunSubset shouldRunSubset -> + "shouldRunSubset:" <+> pretty shouldRunSubset + LogOnlyPartialGhc9Support -> + "Currently, HLS supports GHC 9 only partially. See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail." + LogSetInitialDynFlagsException e -> + "setInitialDynFlags:" <+> pretty (displayException e) + LogService serviceLog -> pretty serviceLog + LogShake log' -> mempty + LogGhcIde log' -> mempty + LogLanguageServer log' -> mempty + LogSession log' -> mempty + LogPluginHLS log' -> mempty + LogRules log' -> mempty + defaultMain :: Recorder Log -> Arguments -> IO () defaultMain recorder Arguments{..} = withHeapStats (cmap LogHeapStats recorder) fun where diff --git a/ghcide/src/Development/IDE/Main/HeapStats.hs b/ghcide/src/Development/IDE/Main/HeapStats.hs index b52b18e5ef..5160738357 100644 --- a/ghcide/src/Development/IDE/Main/HeapStats.hs +++ b/ghcide/src/Development/IDE/Main/HeapStats.hs @@ -5,11 +5,11 @@ module Development.IDE.Main.HeapStats ( withHeapStats, Log ) where import Control.Concurrent import Control.Concurrent.Async import Control.Monad -import qualified Data.Text as T import Data.Word -import Development.IDE.Types.Logger (Logger, Recorder, logInfo, - logWith) +import Development.IDE.Types.Logger (Recorder, logWith) import GHC.Stats +import Prettyprinter (Pretty (pretty), (<+>)) +import qualified Prettyprinter import Text.Printf (printf) data Log @@ -26,6 +26,26 @@ data Log -- logInfo l message deriving Show +instance Pretty Log where + pretty log = case log of + LogHeapStatsPeriod period -> + "Logging heap statistics every" <+> pretty (toFormattedSeconds period) + LogHeapStatsDisabled -> + "Heap statistics are not enabled (RTS option -T is needed)" + LogHeapStats liveBytes heapSize -> + Prettyprinter.hsep + [ "Live bytes:" + , pretty (toFormattedMegabytes liveBytes) + , "Heap size:" + , pretty (toFormattedMegabytes heapSize) ] + where + toFormattedSeconds :: Int -> String + toFormattedSeconds s = printf "%.2fs" (fromIntegral @Int @Double s / 1e6) + + toFormattedMegabytes :: Word64 -> String + toFormattedMegabytes b = printf "%.2fMB" (fromIntegral @Word64 @Double b / 1e6) + + -- | Interval at which to report the latest heap statistics. heapStatsInterval :: Int heapStatsInterval = 60_000_000 -- 60s diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index c35e8c0a37..2d20ed0b0a 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -39,6 +39,7 @@ common common-deps , extra , filepath , text + , prettyprinter -- Default warnings in HLS common warnings diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 12c66bc3cd..3841353323 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -57,6 +57,7 @@ library , text , transformers , unordered-containers + , prettyprinter if os(windows) build-depends: Win32 diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 4d655cee0c..ca9a2a12cb 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -69,6 +69,7 @@ import Language.LSP.Types.Lens as J (HasChildren (children), import Language.LSP.VFS import OpenTelemetry.Eventlog import Options.Applicative (ParserInfo) +import Prettyprinter (Pretty) import System.IO.Unsafe import Text.Regex.TDFA.Text () @@ -396,6 +397,8 @@ type CommandFunction ideState a newtype PluginId = PluginId T.Text deriving (Show, Read, Eq, Ord) + deriving newtype Pretty + instance IsString PluginId where fromString = PluginId . T.pack diff --git a/src/Ide/Arguments.hs b/src/Ide/Arguments.hs index 39ced77cd2..23e3e51887 100644 --- a/src/Ide/Arguments.hs +++ b/src/Ide/Arguments.hs @@ -1,10 +1,12 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} module Ide.Arguments ( Arguments(..) @@ -23,6 +25,7 @@ import Development.IDE.Main (Command (..), commandP) import Ide.Types (IdePlugins) import Options.Applicative import Paths_haskell_language_server +import Prettyprinter (Pretty (pretty)) import System.Environment -- --------------------------------------------------------------------- @@ -48,7 +51,9 @@ data GhcideArguments = GhcideArguments , argsLogFile :: Maybe String , argsThreads :: Int , argsProjectGhcVersion :: Bool - } deriving Show + } + deriving Show + deriving anyclass Pretty data PrintVersion = PrintVersion diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 89ea28b29e..bcb98dbf19 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -30,12 +30,14 @@ import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, import Ide.Types (IdePlugins, PluginId (PluginId), ipMap) import Ide.Version +import Prettyprinter (Pretty, pretty, (<+>)) +import qualified Prettyprinter import qualified System.Directory.Extra as IO data Log = LogVersion !String | LogDirectory !FilePath - | LogLsp !GhcideArguments ![PluginId] + | LogLspStart !GhcideArguments ![PluginId] -- hPutStrLn stderr "Starting (haskell-language-server)LSP server..." -- hPutStrLn stderr $ " with arguments: " <> show ghcideArgs -- hPutStrLn stderr $ " with plugins: " <> show (map fst $ ipMap idePlugins) @@ -43,6 +45,18 @@ data Log | LogIDEMain IDEMain.Log deriving Show +instance Pretty Log where + pretty log = case log of + LogVersion version -> pretty version + LogDirectory path -> "Directory:" <+> pretty path + LogLspStart ghcideArgs pluginIds -> + Prettyprinter.nest 2 $ + Prettyprinter.vsep + [ "Starting (haskell-language-server) LSP server..." + , pretty ghcideArgs + , "PluginIds:" <+> pretty pluginIds ] + LogIDEMain iDEMainLog -> pretty iDEMainLog + defaultMain :: Recorder Log -> Arguments -> IdePlugins IdeState -> IO () defaultMain recorder args idePlugins = do -- WARNING: If you write to stdout before runLanguageServer @@ -106,7 +120,7 @@ runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLog log $ LogDirectory dir when (isLSP argsCommand) $ do - log $ LogLsp ghcideArgs (map fst $ ipMap idePlugins) + log $ LogLspStart ghcideArgs (map fst $ ipMap idePlugins) IDEMain.defaultMain (cmap LogIDEMain recorder) (IDEMain.defaultArguments (cmap LogIDEMain recorder) Info) { IDEMain.argCommand = argsCommand From 504a3df472d0abaf5180b9bd162d77331af7a543 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Sun, 9 Jan 2022 22:06:47 -0500 Subject: [PATCH 16/43] add Pretty Log instances for Session, FileStore, Notifications --- exe/Main.hs | 1 - .../session-loader/Development/IDE/Session.hs | 109 ++++++++++++++---- ghcide/src/Development/IDE/Core/FileStore.hs | 14 +++ .../src/Development/IDE/LSP/LanguageServer.hs | 32 ++++- .../src/Development/IDE/LSP/Notifications.hs | 6 + ghcide/src/Development/IDE/Main.hs | 93 +++++++-------- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 7 ++ 7 files changed, 187 insertions(+), 75 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index 7007e463b1..d50a81698d 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -6,7 +6,6 @@ module Main(main) where import Data.Function ((&)) import Data.Text (Text) -import qualified Data.Text as Text import Development.IDE.Types.Logger (Priority (Debug, Info), WithPriority (WithPriority, priority), cfilter, cmap, setupHsLogger, diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index a7f19bf47a..61d652f331 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -75,7 +75,6 @@ import Language.LSP.Types import System.Directory import qualified System.Directory.Extra as IO import System.FilePath -import System.IO import System.Info import Control.Applicative (Alternative ((<|>))) @@ -94,11 +93,13 @@ import Development.IDE.Types.Shake (WithHieDb) import HieDb.Create import HieDb.Types import HieDb.Utils +import Prettyprinter (Pretty (pretty), (<+>)) +import qualified Prettyprinter import System.Random (RandomGen) import qualified System.Random as Random data Log - = LogSetInitialDynFlags !(Cradle Void) + = LogSettingInitialDynFlags -- seems like wrong location so I changed it -- logDebug logger $ T.pack $ "setInitialDynFlags cradle: " ++ show cradle | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void) -- hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,rootDir,hieYaml,cradle) @@ -121,33 +122,104 @@ data Log -- , "exception: " <> T.pack (show e)] -- in -- T.intercalate ", " logMsgComponents - | LogWorkerSQLiteError !SQLError + | LogHieDbWriterThreadSQLiteError !SQLError -- logDebug logger $ T.pack $ "SQLite error in worker, ignoring: " ++ show e - | LogWorkerException !SomeException + | LogHieDbWriterThreadException !SomeException -- logDebug logger $ T.pack $ "Uncaught error in database worker, ignoring: " ++ show e | LogInterfaceFilesCacheDir !FilePath -- liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack (fromMaybe cacheDir hiCacheDir) - | LogKnownFilesUpdated !(HashMap Target (HashSet FilePath)) + | LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedFilePath)) -- logDebug logger $ "Known files updated: " <> -- T.pack(show $ (HM.map . Set.map) fromNormalizedFilePath x) - | LogUnitIdsBeforeNewHscEnv ![UnitId] + | LogMakingNewHscEnv ![UnitId] -- logInfo logger (T.pack ("Making new HscEnv" ++ show inplace)) | LogDLLLoadError !String -- logDebug logger $ T.pack $ -- "Error dynamically loading libm.so.6:\n" <> err - | LogConsultCradlePath !FilePath + | LogCradlePath !FilePath -- logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp) | LogCradleNotFound !FilePath -- logWarning logger $ implicitCradleWarning lfp + -- implicitCradleWarning :: FilePath -> T.Text + -- implicitCradleWarning fp = + -- "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for " + -- <> T.pack fp <> + -- ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n"<> + -- "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath)) -- logDebug logger $ T.pack ("Session loading result: " <> show eopts) | forall a. Show a => LogCradle !(Cradle a) -- logDebug logger $ T.pack $ "Output from setting up the cradle " <> show cradle | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) -- logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res)) - deriving instance Show Log +instance Pretty Log where + pretty = \case + LogSettingInitialDynFlags -> + "Setting initial dynflags..." + LogGetInitialGhcLibDirDefaultCradleFail cradleError rootDirPath hieYamlPath cradle -> + Prettyprinter.nest 2 $ + Prettyprinter.vcat + [ "Couldn't load cradle for ghc libdir." + , "Cradle error:" <+> Prettyprinter.viaShow cradleError + , "Root dir path:" <+> pretty rootDirPath + , "hie.yaml path:" <+> pretty hieYamlPath + , "Cradle:" <+> Prettyprinter.viaShow cradle ] + LogGetInitialGhcLibDirDefaultCradleNone -> + "Couldn't load cradle. Cradle not found." + LogHieDbRetry delay maxDelay maxRetryCount e -> + Prettyprinter.nest 2 $ + Prettyprinter.vcat + [ "Retrying hiedb action..." + , "delay:" <+> pretty delay + , "maximum delay:" <+> pretty maxDelay + , "retries remaining:" <+> pretty maxRetryCount + , "SQLite error:" <+> pretty (displayException e) ] + LogHieDbRetriesExhausted baseDelay maxDelay maxRetryCount e -> + Prettyprinter.nest 2 $ + Prettyprinter.vcat + [ "Retries exhausted for hiedb action." + , "base delay:" <+> pretty baseDelay + , "maximum delay:" <+> pretty maxDelay + , "retries remaining:" <+> pretty maxRetryCount + , "Exception:" <+> pretty (displayException e) ] + LogHieDbWriterThreadSQLiteError e -> + Prettyprinter.nest 2 $ + Prettyprinter.vcat + [ "HieDb writer thread SQLite error:" + , pretty (displayException e) ] + LogHieDbWriterThreadException e -> + Prettyprinter.nest 2 $ + Prettyprinter.vcat + [ "HieDb writer thread exception:" + , pretty (displayException e) ] + LogInterfaceFilesCacheDir path -> + "Interface files cache directory:" <+> pretty path + LogKnownFilesUpdated targetToPathsMap -> + Prettyprinter.nest 2 $ + Prettyprinter.vcat + [ "Known files updated:" + , Prettyprinter.viaShow $ (HM.map . Set.map) fromNormalizedFilePath targetToPathsMap + ] + LogMakingNewHscEnv inPlaceUnitIds -> + "Making new HscEnv. In-place unit ids:" <+> pretty (map show inPlaceUnitIds) + LogDLLLoadError errorString -> + "Error dynamically loading libm.so.6:" <+> pretty errorString + LogCradlePath path -> + "Cradle path:" <+> pretty path + LogCradleNotFound path -> + Prettyprinter.vcat + [ "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for" <+> pretty path <> "." + , "Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie)." + , "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ] + LogSessionLoadingResult e -> + "Session loading result:" <+> Prettyprinter.viaShow e + LogCradle cradle -> + "Cradle:" <+> Prettyprinter.viaShow cradle + LogNewComponentCache componentCache -> + "New component cache HscEnvEq:" <+> Prettyprinter.viaShow componentCache + -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String hiedbDataVersion = "1" @@ -209,7 +281,6 @@ getInitialGhcLibDirDefault recorder rootDir = do let log = logWith recorder hieYaml <- findCradle def rootDir cradle <- loadCradle def hieYaml rootDir - log $ LogSetInitialDynFlags cradle libDirRes <- getRuntimeGhcLibDir cradle case libDirRes of CradleSuccess libdir -> pure $ Just $ LibDir libdir @@ -225,6 +296,7 @@ setInitialDynFlags :: Recorder Log -> FilePath -> SessionLoadingOptions -> IO (M setInitialDynFlags recorder rootDir SessionLoadingOptions{..} = do libdir <- getInitialGhcLibDir recorder rootDir dynFlags <- mapM dynFlagsForPrinting libdir + logWith recorder LogSettingInitialDynFlags mapM_ setUnsafeGlobalDynFlags dynFlags pure libdir @@ -332,9 +404,9 @@ runWithDb recorder fp k = do -- TODO: probably should let exceptions be caught/logged/handled by top level handler k withHieDbRetryable `Safe.catch` \e@SQLError{} -> do - log $ LogWorkerSQLiteError e + log $ LogHieDbWriterThreadSQLiteError e `Safe.catchAny` \e -> do - log $ LogWorkerException e + log $ LogHieDbWriterThreadException e getHieDbLoc :: FilePath -> IO FilePath @@ -388,7 +460,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath]))) return $ do - extras@ShakeExtras{logger, restartShakeSession, ideNc, knownTargetsVar, lspEnv + extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv } <- getShakeExtras let invalidateShakeCache :: IO () invalidateShakeCache = do @@ -419,7 +491,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do logDirtyKeys <- recordDirtyKeys extras GetKnownTargets [emptyFilePath] return (logDirtyKeys >> pure hasUpdate) for_ hasUpdate $ \x -> - logWith recorder $ LogKnownFilesUpdated ((HM.map . Set.map) fromNormalizedFilePath x) + logWith recorder $ LogKnownFilesUpdated x -- Create a new HscEnv from a hieYaml root and a set of options -- If the hieYaml file already has an HscEnv, the new component is @@ -474,7 +546,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- scratch again (for now) -- It's important to keep the same NameCache though for reasons -- that I do not fully understand - log $ LogUnitIdsBeforeNewHscEnv inplace + log $ LogMakingNewHscEnv inplace hscEnv <- emptyHscEnv ideNc libDir newHscEnv <- -- Add the options for the current component to the HscEnv @@ -560,7 +632,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do lfp <- flip makeRelative cfp <$> getCurrentDirectory - log $ LogConsultCradlePath lfp + log $ LogCradlePath lfp when (isNothing hieYaml) $ log $ LogCradleNotFound lfp @@ -650,7 +722,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the -- GHC options/dynflags needed for the session and the GHC library directory - cradleToOptsAndLibDir :: Show a => Recorder Log -> Cradle a -> FilePath -> IO (Either [CradleError] (ComponentOptions, FilePath)) cradleToOptsAndLibDir recorder cradle file = do @@ -981,12 +1052,6 @@ getCacheDirsDefault prefix opts = do cacheDir :: String cacheDir = "ghcide" -implicitCradleWarning :: FilePath -> T.Text -implicitCradleWarning fp = - "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for " - <> T.pack fp <> - ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n"<> - "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ---------------------------------------------------------------------------------------------------- data PackageSetupException diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 8e8fc38e2d..cc60d3fed0 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -82,6 +82,9 @@ import Language.LSP.Types (DidChangeWatchedF import qualified Language.LSP.Types as LSP import qualified Language.LSP.Types.Capabilities as LSP import Language.LSP.VFS +import Prettyprinter (Pretty (pretty), + (<+>)) +import qualified Prettyprinter import System.FilePath data Log @@ -94,6 +97,17 @@ data Log | LogShake Shake.Log deriving Show +instance Pretty Log where + pretty = \case + LogCouldNotIdentifyReverseDeps path -> + "Could not identify reverse dependencies for" <+> Prettyprinter.viaShow path + (LogTypeCheckingReverseDeps path reverseDepPaths) -> + "Typechecking reverse dependecies for" + <+> Prettyprinter.viaShow path + <> ":" + <+> pretty (fmap (fmap show) reverseDepPaths) + LogShake shakeLog -> pretty shakeLog + makeVFSHandle :: IO VFSHandle makeVFSHandle = do vfsVar <- newVar (1, Map.empty) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 76360e3b05..cfc2908fbc 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -42,14 +42,16 @@ import Development.IDE.Types.Logger import Control.Monad.IO.Unlift (MonadUnliftIO) import qualified Development.IDE.Session as Session import Development.IDE.Types.Shake (WithHieDb) +import Prettyprinter (Pretty (pretty), (<+>)) +import qualified Prettyprinter import System.IO.Unsafe (unsafeInterleaveIO) data Log - = LogRegisterIdeConfig !IdeConfiguration + = LogRegisteringIdeConfig !IdeConfiguration -- logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig - | LogHandleServerException !SomeException + | LogReactorThreadException !SomeException -- logError logger $ T.pack $ "Fatal error in server thread: " <> show e - | LogExceptionInHandler !SomeException + | LogReactorMessageActionException !SomeException -- logError logger $ T.pack $ -- "Unexpected exception, please report!\n" ++ -- "Exception: " ++ show e @@ -60,6 +62,24 @@ data Log | LogSession Session.Log deriving Show +instance Pretty Log where + pretty = \case + LogRegisteringIdeConfig ideConfig -> + "Registering IDE configuration:" <+> Prettyprinter.viaShow ideConfig + LogReactorThreadException e -> + Prettyprinter.vcat + [ "ReactorThreadException" + , pretty $ displayException e ] + LogReactorMessageActionException e -> + Prettyprinter.vcat + [ "ReactorMessageActionException" + , pretty $ displayException e ] + LogReactorThreadStopped -> + "Reactor thread stopped" + (LogCancelledRequest requestId) -> + "Cancelled request" <+> Prettyprinter.viaShow requestId + (LogSession sessionLog) -> pretty sessionLog + issueTrackerUrl :: T.Text issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues" @@ -168,11 +188,11 @@ runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigur let initConfig = parseConfiguration params - log $ LogRegisterIdeConfig initConfig + log $ LogRegisteringIdeConfig initConfig registerIdeConfiguration (shakeExtras ide) initConfig let handleServerException (Left e) = do - log $ LogHandleServerException e + log $ LogReactorThreadException e sendErrorMessage e exitClientMsg handleServerException (Right _) = pure () @@ -185,7 +205,7 @@ runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigur ] exceptionInHandler e = do - log $ LogExceptionInHandler e + log $ LogReactorMessageActionException e sendErrorMessage e checkCancelled _id act k = diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 9ef450d17a..5144656f2b 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -38,12 +38,18 @@ import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Shake (toKey) import Ide.Types +import Prettyprinter (Pretty (pretty)) data Log = LogShake Shake.Log | LogFileStore FileStore.Log deriving Show +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + LogFileStore fileStoreLog -> pretty fileStoreLog + whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 5f18b6cce9..a37e4e1c53 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -132,6 +132,53 @@ import System.Time.Extra (Seconds, offsetTime, showDuration) import Text.Printf (printf) +data Log + = LogHeapStats !HeapStats.Log + | LogLspStart + -- logInfo logger "Starting LSP server..." + -- logInfo logger "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!" + | LogLspStartDuration !Seconds + -- logInfo logger $ T.pack $ "Started LSP server in " ++ showDuration t + | LogShouldRunSubset !Bool + -- logDebug logger $ T.pack $ "runSubset: " <> show runSubset + | LogOnlyPartialGhc9Support + -- hPutStrLn stderr $ + -- "Currently, HLS supports GHC 9 only partially. " + -- <> "See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail." + | LogSetInitialDynFlagsException !SomeException + -- (logDebug logger $ T.pack $ "setInitialDynFlags: " ++ displayException e) + | LogService Service.Log + | LogShake Shake.Log + | LogGhcIde GhcIde.Log + | LogLanguageServer LanguageServer.Log + | LogSession Session.Log + | LogPluginHLS PluginHLS.Log + | LogRules Rules.Log + deriving Show + +instance Pretty Log where + pretty log = case log of + LogHeapStats heapStatsLog -> pretty heapStatsLog + LogLspStart -> + Prettyprinter.vsep + [ "Staring LSP server..." + , "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"] + LogLspStartDuration duration -> + "Started LSP server in" <+> pretty (showDuration duration) + LogShouldRunSubset shouldRunSubset -> + "shouldRunSubset:" <+> pretty shouldRunSubset + LogOnlyPartialGhc9Support -> + "Currently, HLS supports GHC 9 only partially. See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail." + LogSetInitialDynFlagsException e -> + "setInitialDynFlags:" <+> pretty (displayException e) + LogService serviceLog -> pretty serviceLog + LogShake shakeLog -> pretty shakeLog + LogGhcIde ghcIdeLog -> pretty ghcIdeLog + LogLanguageServer languageServerLog -> pretty languageServerLog + LogSession log' -> mempty + LogPluginHLS log' -> mempty + LogRules log' -> mempty + data Command = Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures | Db {hieOptions :: HieDb.Options, hieCommand :: HieDb.Command} @@ -261,52 +308,6 @@ testing recorder = , argsIdeOptions = ideOptions } -data Log - = LogHeapStats !HeapStats.Log - | LogLspStart - -- logInfo logger "Starting LSP server..." - -- logInfo logger "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!" - | LogLspStartDuration !Seconds - -- logInfo logger $ T.pack $ "Started LSP server in " ++ showDuration t - | LogShouldRunSubset !Bool - -- logDebug logger $ T.pack $ "runSubset: " <> show runSubset - | LogOnlyPartialGhc9Support - -- hPutStrLn stderr $ - -- "Currently, HLS supports GHC 9 only partially. " - -- <> "See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail." - | LogSetInitialDynFlagsException !SomeException - -- (logDebug logger $ T.pack $ "setInitialDynFlags: " ++ displayException e) - | LogService Service.Log - | LogShake Shake.Log - | LogGhcIde GhcIde.Log - | LogLanguageServer LanguageServer.Log - | LogSession Session.Log - | LogPluginHLS PluginHLS.Log - | LogRules Rules.Log - deriving Show - -instance Pretty Log where - pretty log = case log of - LogHeapStats heapStatsLog -> pretty heapStatsLog - LogLspStart -> - Prettyprinter.vsep - [ "Staring LSP server..." - , "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"] - LogLspStartDuration duration -> - "Started LSP server in" <+> pretty (showDuration duration) - LogShouldRunSubset shouldRunSubset -> - "shouldRunSubset:" <+> pretty shouldRunSubset - LogOnlyPartialGhc9Support -> - "Currently, HLS supports GHC 9 only partially. See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail." - LogSetInitialDynFlagsException e -> - "setInitialDynFlags:" <+> pretty (displayException e) - LogService serviceLog -> pretty serviceLog - LogShake log' -> mempty - LogGhcIde log' -> mempty - LogLanguageServer log' -> mempty - LogSession log' -> mempty - LogPluginHLS log' -> mempty - LogRules log' -> mempty defaultMain :: Recorder Log -> Arguments -> IO () defaultMain recorder Arguments{..} = withHeapStats (cmap LogHeapStats recorder) fun diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index 08ef4e55fa..a35dc29464 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -18,6 +18,7 @@ import qualified Development.IDE.Plugin.TypeLenses as TypeLenses import Ide.Types import Language.LSP.Server (LspM) import Language.LSP.Types +import Prettyprinter (Pretty (pretty)) import Text.Regex.TDFA.Text () data Log @@ -26,6 +27,12 @@ data Log | LogTypeLenses TypeLenses.Log deriving Show +instance Pretty Log where + pretty = \case + LogNotifications notificationsLog -> pretty notificationsLog + LogCompletions completionsLog -> mempty + LogTypeLenses typeLensesLog -> mempty + descriptors :: Recorder Log -> [PluginDescriptor IdeState] descriptors recorder = [ descriptor "ghcide-hover-and-symbols", From 17937d2097b3e4dbcccfb9bd5fbf49b900226a6d Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Mon, 10 Jan 2022 16:20:26 -0500 Subject: [PATCH 17/43] add remaining Pretty Log instances --- exe/Main.hs | 2 +- exe/Plugins.hs | 26 +++++++++++++++++++ ghcide/src/Development/IDE/Core/FileExists.hs | 6 +++++ ghcide/src/Development/IDE/Core/OfInterest.hs | 6 +++++ ghcide/src/Development/IDE/Core/Rules.hs | 18 +++++++++++++ ghcide/src/Development/IDE/Core/Service.hs | 6 ++--- ghcide/src/Development/IDE/GHC/ExactPrint.hs | 5 ++++ ghcide/src/Development/IDE/Main.hs | 6 ++--- .../src/Development/IDE/Plugin/Completions.hs | 5 ++++ ghcide/src/Development/IDE/Plugin/HLS.hs | 7 ++++- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 4 +-- .../src/Development/IDE/Plugin/TypeLenses.hs | 5 ++++ plugins/default/src/Ide/Plugin/Example.hs | 8 +++++- plugins/default/src/Ide/Plugin/Example2.hs | 8 +++++- .../hls-alternate-number-format-plugin.cabal | 1 + .../src/Ide/Plugin/AlternateNumberFormat.hs | 7 ++++- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 1 + .../hls-eval-plugin/src/Ide/Plugin/Eval.hs | 8 +++++- .../src/Ide/Plugin/Eval/Rules.hs | 7 ++++- .../hls-explicit-imports-plugin.cabal | 1 + .../src/Ide/Plugin/ExplicitImports.hs | 8 +++++- .../hls-hlint-plugin/hls-hlint-plugin.cabal | 1 + .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 6 +++++ .../hls-refine-imports-plugin.cabal | 1 + .../src/Ide/Plugin/RefineImports.hs | 6 +++++ .../src/Wingman/LanguageServer.hs | 5 ++++ .../hls-tactics-plugin/src/Wingman/Plugin.hs | 12 ++++++--- src/Ide/Arguments.hs | 2 -- src/Ide/Main.hs | 2 +- 29 files changed, 158 insertions(+), 22 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index d50a81698d..76305be533 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -29,7 +29,7 @@ data Log instance Pretty Log where pretty log = case log of LogIdeMain ideMainLog -> pretty ideMainLog - LogPlugins log' -> mempty + LogPlugins pluginsLog -> pretty pluginsLog logToTextWithPriority :: Log -> WithPriority Text logToTextWithPriority = diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 1cfd3ff899..828884ad7c 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Plugins where @@ -93,6 +94,7 @@ import qualified Ide.Plugin.StylishHaskell as StylishHaskell #if brittany import qualified Ide.Plugin.Brittany as Brittany +import Prettyprinter (Pretty (pretty)) #endif data Log @@ -119,6 +121,30 @@ data Log #endif deriving Show +instance Pretty Log where + pretty = \case + LogGhcIde ghcIdeLog -> pretty ghcIdeLog + LogExample exampleLog -> pretty exampleLog + LogExample2 example2Log -> pretty example2Log +#if tactic + LogTactic tacticLog -> pretty tacticLog +#endif +#if eval + LogEval evalLog -> pretty evalLog +#endif +#if importLens + LogExplicitImports explicitImportsLog -> pretty explicitImportsLog +#endif +#if refineImports + LogRefineImports refineImportsLog -> pretty refineImportsLog +#endif +#if hlint + LogHlint hlintLog -> pretty hlintLog +#endif +#if alternateNumberFormat + LogAlternateNumberFormat alternateNumberFormatLog -> pretty alternateNumberFormatLog +#endif + -- --------------------------------------------------------------------- -- | The plugins configured for use in this instance of the language diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 899ff5049b..7bf0895549 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -33,6 +33,7 @@ import qualified Focus import Ide.Plugin.Config (Config) import Language.LSP.Server hiding (getVirtualFile) import Language.LSP.Types +import Prettyprinter (Pretty (pretty)) import qualified StmContainers.Map as STM import qualified System.Directory as Dir import qualified System.FilePath.Glob as Glob @@ -91,6 +92,11 @@ data Log | LogShake Shake.Log deriving Show +instance Pretty Log where + pretty = \case + LogFileStore fileStoreLog -> pretty fileStoreLog + LogShake shakeLog -> pretty shakeLog + -- | Grab the current global value of 'FileExistsMap' without acquiring a dependency getFileExistsMapUntracked :: Action FileExistsMap getFileExistsMapUntracked = do diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 7af9c6566b..49df24dc8b 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -42,11 +42,17 @@ import Development.IDE.Types.Logger import Development.IDE.Types.Options (IdeTesting (..)) import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP +import Prettyprinter (Pretty (pretty)) data Log = LogShake Shake.Log deriving Show +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) + instance IsIdeGlobal OfInterestVar -- | The rule that initialises the files of interest state. diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 6a972e5dd2..63270b48fb 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -155,6 +155,8 @@ import HIE.Bios.Ghc.Gap (hostIsDynamic) import Development.IDE.Types.Logger (Recorder, cmap, logWith) import qualified Development.IDE.Core.Shake as Shake import qualified Development.IDE.GHC.ExactPrint as ExactPrint +import Prettyprinter (Pretty (pretty), (<+>)) +import qualified Prettyprinter data Log = LogShake Shake.Log @@ -171,6 +173,22 @@ data Log | LogExactPrint ExactPrint.Log deriving Show +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + LogReindexingHieFile path -> + "Re-indexing hie file for" <+> pretty (fromNormalizedFilePath path) + LogLoadingHieFile path -> + "LOADING HIE FILE FOR" <+> pretty (fromNormalizedFilePath path) + LogLoadingHieFileFail path e -> + Prettyprinter.nest 2 $ + Prettyprinter.vcat + [ "FAILED LOADING HIE FILE FOR" <+> pretty path + , pretty (displayException e) ] + LogLoadingHieFileSuccess path -> + "SUCCEEDED LOADING HIE FILE FOR" <+> pretty path + LogExactPrint exactPrintLog -> pretty exactPrintLog + templateHaskellInstructions :: T.Text templateHaskellInstructions = "https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html#support-for-template-haskell" diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index 00cd6a7b4d..628618207c 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -47,9 +47,9 @@ data Log instance Pretty Log where pretty log = case log of - LogShake log -> pretty log - LogOfInterest log -> mempty - LogFileExists log -> mempty + LogShake shakeLog -> pretty shakeLog + LogOfInterest ofInterestLog -> pretty ofInterestLog + LogFileExists fileExistsLog -> pretty fileExistsLog ------------------------------------------------------------ diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index 49260c6d70..22fa702c7e 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -71,6 +71,7 @@ import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers import Language.LSP.Types import Language.LSP.Types.Capabilities (ClientCapabilities) +import Prettyprinter (Pretty (pretty)) import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, @@ -81,6 +82,10 @@ import Retrie.ExactPrint hiding (parseDecl, data Log = LogShake Shake.Log deriving Show +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + data GetAnnotatedParsedSource = GetAnnotatedParsedSource deriving (Eq, Show, Typeable, GHC.Generic) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index a37e4e1c53..3a5223ac1e 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -175,9 +175,9 @@ instance Pretty Log where LogShake shakeLog -> pretty shakeLog LogGhcIde ghcIdeLog -> pretty ghcIdeLog LogLanguageServer languageServerLog -> pretty languageServerLog - LogSession log' -> mempty - LogPluginHLS log' -> mempty - LogRules log' -> mempty + LogSession sessionLog -> pretty sessionLog + LogPluginHLS pluginHLSLog -> pretty pluginHLSLog + LogRules rulesLog -> pretty rulesLog data Command = Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 8b72b56574..ccedf2ea63 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -46,10 +46,15 @@ import Ide.Types import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.VFS as VFS +import Prettyprinter (Pretty (pretty)) import Text.Fuzzy.Parallel (Scored (..)) data Log = LogShake Shake.Log deriving Show +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = produceCompletions recorder diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 7ebd9ce8e7..9c41da9fa3 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -11,7 +11,6 @@ module Development.IDE.Plugin.HLS import Control.Exception (SomeException) import Control.Monad -import Control.Monad.IO.Class import qualified Data.Aeson as J import Data.Bifunctor import Data.Dependent.Map (DMap) @@ -36,6 +35,7 @@ import Ide.Types as HLS import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.Types as J +import Prettyprinter (Pretty (pretty)) import Text.Regex.TDFA.Text () import UnliftIO (MonadUnliftIO) import UnliftIO.Async (forConcurrently) @@ -49,6 +49,11 @@ data Log -- liftIO $ logInfo (ideLogger ide) "extensibleNotificationPlugins no enabled plugins" deriving Show +instance Pretty Log where + pretty = \case + LogNoEnabledPlugins -> + "extensibleNotificationPlugins no enabled plugins" + -- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: Recorder Log -> IdePlugins IdeState -> Plugin Config asGhcIdePlugin recorder (IdePlugins ls) = diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index a35dc29464..fd7d810f83 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -30,8 +30,8 @@ data Log instance Pretty Log where pretty = \case LogNotifications notificationsLog -> pretty notificationsLog - LogCompletions completionsLog -> mempty - LogTypeLenses typeLensesLog -> mempty + LogCompletions completionsLog -> pretty completionsLog + LogTypeLenses typeLensesLog -> pretty typeLensesLog descriptors :: Recorder Log -> [PluginDescriptor IdeState] descriptors recorder = diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 71a3ce15f7..7225078009 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -69,10 +69,15 @@ import Language.LSP.Types (ApplyWorkspaceEditParams ( TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit)) +import Prettyprinter (Pretty (pretty)) import Text.Regex.TDFA ((=~), (=~~)) data Log = LogShake Shake.Log deriving Show +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + typeLensCommandId :: T.Text typeLensCommandId = "typesignature.add" diff --git a/plugins/default/src/Ide/Plugin/Example.hs b/plugins/default/src/Ide/Plugin/Example.hs index 86662d4bef..74669340ed 100644 --- a/plugins/default/src/Ide/Plugin/Example.hs +++ b/plugins/default/src/Ide/Plugin/Example.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} @@ -36,11 +37,16 @@ import Ide.Types import Language.LSP.Server import Language.LSP.Types import Options.Applicative (ParserInfo, info) +import Prettyprinter (Pretty (pretty)) import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- -data Log = LogShake Shake.Log deriving Show +newtype Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) diff --git a/plugins/default/src/Ide/Plugin/Example2.hs b/plugins/default/src/Ide/Plugin/Example2.hs index f940d049ec..6811728cd5 100644 --- a/plugins/default/src/Ide/Plugin/Example2.hs +++ b/plugins/default/src/Ide/Plugin/Example2.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} @@ -33,11 +34,16 @@ import Ide.PluginUtils import Ide.Types import Language.LSP.Server import Language.LSP.Types +import Prettyprinter (Pretty (pretty)) import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- -data Log = LogShake Shake.Log deriving Show +newtype Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) diff --git a/plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal b/plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal index 20bd4be3d3..2e47529a77 100644 --- a/plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal +++ b/plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal @@ -37,6 +37,7 @@ library , syb , text , unordered-containers + , prettyprinter default-language: Haskell2010 default-extensions: diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs index 9477f681c2..0849cc8bdb 100644 --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs @@ -29,8 +29,13 @@ import Ide.PluginUtils (handleMaybe, handleMaybeM, import Ide.Types import Language.LSP.Types import Language.LSP.Types.Lens (uri) +import Prettyprinter (Pretty (pretty)) -data Log = LogShake Shake.Log deriving Show +newtype Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index a70c68b432..aea3392b38 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -75,6 +75,7 @@ library , megaparsec >=9.0 , mtl , parser-combinators + , prettyprinter , pretty-simple , QuickCheck , safe-exceptions diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs index 8c3bf2a890..af351a498c 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE LambdaCase #-} {- | Eval Plugin entry point. @@ -19,8 +20,13 @@ import Ide.Types (PluginDescriptor (..), PluginId, defaultPluginDescriptor, mkPluginHandler) import Language.LSP.Types +import Prettyprinter (Pretty (pretty)) -data Log = LogEvalRules EvalRules.Log deriving Show +newtype Log = LogEvalRules EvalRules.Log deriving Show + +instance Pretty Log where + pretty = \case + LogEvalRules evalRulesLog -> pretty evalRulesLog -- |Plugin descriptor descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs index f3dea92f26..08cbfc2d7a 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -38,8 +38,13 @@ import qualified Development.IDE.GHC.Compat.Util as FastString import Development.IDE.Graph (alwaysRerun) import Development.IDE.Types.Logger (Recorder, cmap) import Ide.Plugin.Eval.Types +import Prettyprinter (Pretty (pretty)) -data Log = LogShake Shake.Log deriving Show +newtype Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog rules :: Recorder Log -> Rules () rules recorder = do diff --git a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal index d74b23689c..46ca61766a 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -30,6 +30,7 @@ library , lsp , text , unordered-containers + , prettyprinter default-language: Haskell2010 default-extensions: diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 3c122bd8e0..64d939ff24 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -38,14 +39,19 @@ import Ide.PluginUtils (mkLspCommand) import Ide.Types import Language.LSP.Server import Language.LSP.Types +import Prettyprinter (Pretty (pretty)) importCommandId :: CommandId importCommandId = "ImportLensCommand" -data Log +newtype Log = LogShake Shake.Log deriving Show +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + -- | The "main" function of a plugin descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState descriptor recorder = descriptorForModules recorder (/= moduleName pRELUDE) diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index 2b21de18e2..ee09fcec0b 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -72,6 +72,7 @@ library -- and https://github.com/haskell/haskell-language-server/pull/2464#issue-1077133441 is updated -- accordingly , ghc-lib-parser-ex + , prettyprinter if (flag(hlint33)) -- This mirrors the logic in hlint.cabal for hlint-3.3 diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 07d0896585..d58e41791e 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -13,6 +13,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} @@ -120,6 +121,7 @@ import Development.IDE.Spans.Pragmas (LineSplitTe lineSplitInsertTextEdit, lineSplitTextEdits, nextPragmaLine) +import Prettyprinter (Pretty (pretty)) import System.Environment (setEnv, unsetEnv) -- --------------------------------------------------------------------- @@ -128,6 +130,10 @@ newtype Log = LogShake Shake.Log deriving Show +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + #ifdef HLINT_ON_GHC_LIB -- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib pattern RealSrcSpan :: GHC.RealSrcSpan -> Maybe BufSpan -> GHC.SrcSpan diff --git a/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal b/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal index cee9508f3a..7bfbb9d8c6 100644 --- a/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal +++ b/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal @@ -31,6 +31,7 @@ library , lsp , text , unordered-containers + , prettyprinter default-language: Haskell2010 default-extensions: diff --git a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs index fa9f514a86..460754808c 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -46,9 +47,14 @@ import Ide.PluginUtils (mkLspCommand) import Ide.Types import Language.LSP.Server import Language.LSP.Types +import Prettyprinter (Pretty (pretty)) newtype Log = LogShake Shake.Log deriving Show +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + -- | plugin declaration descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index 775486079e..6689a35ea1 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -65,12 +65,17 @@ import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern Metap import Wingman.Types import Development.IDE.Types.Logger (Recorder, cmap) import qualified Development.IDE.Core.Shake as Shake +import Prettyprinter (Pretty (pretty)) newtype Log = LogShake Shake.Log deriving Show +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + tacticDesc :: T.Text -> T.Text tacticDesc name = "fill the hole using the " <> name <> " tactic" diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index 0b42774e9b..6e9aa3d406 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -14,11 +14,17 @@ import qualified Wingman.LanguageServer as WingmanLanguageServer import Wingman.LanguageServer.Metaprogram (hoverProvider) import Wingman.StaticPlugin import Development.IDE.Types.Logger (Recorder, cmap) +import Prettyprinter (Pretty (pretty)) -data Log - = LogLanguageServer WingmanLanguageServer.Log +newtype Log + = LogWingmanLanguageServer WingmanLanguageServer.Log deriving Show +instance Pretty Log where + pretty = \case + LogWingmanLanguageServer wingmanLanguageServerLog -> pretty wingmanLanguageServerLog + + descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = installInteractions @@ -27,7 +33,7 @@ descriptor recorder plId ) $ (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentHover hoverProvider - , pluginRules = wingmanRules (cmap LogLanguageServer recorder) plId + , pluginRules = wingmanRules (cmap LogWingmanLanguageServer recorder) plId , pluginConfigDescriptor = defaultConfigDescriptor { configCustomConfig = mkCustomConfig properties diff --git a/src/Ide/Arguments.hs b/src/Ide/Arguments.hs index 23e3e51887..da1c625670 100644 --- a/src/Ide/Arguments.hs +++ b/src/Ide/Arguments.hs @@ -25,7 +25,6 @@ import Development.IDE.Main (Command (..), commandP) import Ide.Types (IdePlugins) import Options.Applicative import Paths_haskell_language_server -import Prettyprinter (Pretty (pretty)) import System.Environment -- --------------------------------------------------------------------- @@ -53,7 +52,6 @@ data GhcideArguments = GhcideArguments , argsProjectGhcVersion :: Bool } deriving Show - deriving anyclass Pretty data PrintVersion = PrintVersion diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index bcb98dbf19..a2b011c9c6 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -53,7 +53,7 @@ instance Pretty Log where Prettyprinter.nest 2 $ Prettyprinter.vsep [ "Starting (haskell-language-server) LSP server..." - , pretty ghcideArgs + , Prettyprinter.viaShow ghcideArgs , "PluginIds:" <+> pretty pluginIds ] LogIDEMain iDEMainLog -> pretty iDEMainLog From a2fe3712770b39f4dc1ca2acf07568ba2b6a484d Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Mon, 10 Jan 2022 20:26:37 -0500 Subject: [PATCH 18/43] add logToPriorities --- exe/Main.hs | 21 ++++++++---- exe/Plugins.hs | 27 +++++++++++++++- .../session-loader/Development/IDE/Session.hs | 32 +++++++++++++++---- ghcide/src/Development/IDE/Core/FileExists.hs | 14 ++++++-- ghcide/src/Development/IDE/Core/FileStore.hs | 14 ++++++-- ghcide/src/Development/IDE/Core/OfInterest.hs | 10 ++++-- ghcide/src/Development/IDE/Core/Rules.hs | 22 +++++++++---- ghcide/src/Development/IDE/Core/Service.hs | 11 +++++-- ghcide/src/Development/IDE/Core/Shake.hs | 12 ++++++- ghcide/src/Development/IDE/GHC/ExactPrint.hs | 10 ++++-- .../src/Development/IDE/LSP/LanguageServer.hs | 18 +++++++++-- .../src/Development/IDE/LSP/Notifications.hs | 16 +++++++--- ghcide/src/Development/IDE/Main.hs | 19 ++++++++++- ghcide/src/Development/IDE/Main/HeapStats.hs | 8 ++++- .../src/Development/IDE/Plugin/Completions.hs | 13 ++++++-- ghcide/src/Development/IDE/Plugin/HLS.hs | 9 ++++-- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 9 +++++- .../src/Development/IDE/Plugin/TypeLenses.hs | 7 +++- ghcide/src/Development/IDE/Types/Logger.hs | 5 +-- plugins/default/src/Ide/Plugin/Example.hs | 29 ++++++++++------- plugins/default/src/Ide/Plugin/Example2.hs | 23 +++++++------ .../src/Ide/Plugin/AlternateNumberFormat.hs | 6 +++- .../hls-eval-plugin/src/Ide/Plugin/Eval.hs | 7 +++- .../src/Ide/Plugin/Eval/Rules.hs | 7 +++- .../src/Ide/Plugin/ExplicitImports.hs | 6 ++++ .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 7 +++- .../src/Ide/Plugin/RefineImports.hs | 7 +++- .../src/Ide/Plugin/Tactic.hs | 2 +- .../src/Wingman/LanguageServer.hs | 5 +++ .../hls-tactics-plugin/src/Wingman/Plugin.hs | 4 +++ src/Ide/Main.hs | 13 ++++++-- 31 files changed, 314 insertions(+), 79 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index 76305be533..7da16e9de1 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,5 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Main(main) where @@ -10,6 +11,7 @@ import Development.IDE.Types.Logger (Priority (Debug, Info), WithPriority (WithPriority, priority), cfilter, cmap, setupHsLogger, withDefaultTextWithPriorityRecorderAndHandle) +import qualified Development.IDE.Types.Logger as Logger import Ide.Arguments (Arguments (..), GhcideArguments (..), getArguments) @@ -31,12 +33,19 @@ instance Pretty Log where LogIdeMain ideMainLog -> pretty ideMainLog LogPlugins pluginsLog -> pretty pluginsLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogIdeMain log -> IdeMain.logToPriority log + LogPlugins log -> Plugins.logToPriority log + logToTextWithPriority :: Log -> WithPriority Text -logToTextWithPriority = - WithPriority Info - . Prettyprinter.renderStrict - . Prettyprinter.layoutPretty Prettyprinter.defaultLayoutOptions - . pretty +logToTextWithPriority log = WithPriority priority text + where + priority = logToPriority log + text = log + & pretty + & Prettyprinter.layoutPretty Prettyprinter.defaultLayoutOptions + & Prettyprinter.renderStrict main :: IO () main = do @@ -46,7 +55,7 @@ main = do case args of Ghcide GhcideArguments{ argsTesting, argsDebugOn, argsLogFile, argsExamplePlugin } -> let (minHsLoggerLogLevel, minPriority) = - if argsDebugOn || argsTesting then (HsLogger.DEBUG, Debug) else (HsLogger.INFO, Info) + if argsDebugOn || argsTesting then (HsLogger.DEBUG, Info) else (HsLogger.INFO, Info) in (minHsLoggerLogLevel, minPriority, argsLogFile, argsExamplePlugin) _ -> (HsLogger.INFO, Info, Nothing, False) diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 828884ad7c..917ba395ef 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -4,8 +4,10 @@ module Plugins where import Development.IDE.Types.Logger (Recorder, cmap) +import qualified Development.IDE.Types.Logger as Logger import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types (IdePlugins) +import Prettyprinter (Pretty (pretty)) -- fixed plugins import Development.IDE (IdeState) @@ -94,7 +96,6 @@ import qualified Ide.Plugin.StylishHaskell as StylishHaskell #if brittany import qualified Ide.Plugin.Brittany as Brittany -import Prettyprinter (Pretty (pretty)) #endif data Log @@ -145,6 +146,30 @@ instance Pretty Log where LogAlternateNumberFormat alternateNumberFormatLog -> pretty alternateNumberFormatLog #endif +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogGhcIde log -> GhcIde.logToPriority log + LogExample log -> Example.logToPriority log + LogExample2 log -> Example2.logToPriority log +#if tactic + LogTactic log -> Tactic.logToPriority log +#endif +#if eval + LogEval log -> Eval.logToPriority log +#endif +#if importLens + LogExplicitImports log -> ExplicitImports.logToPriority log +#endif +#if refineImports + LogRefineImports log -> RefineImports.logToPriority log +#endif +#if hlint + LogHlint log -> Hlint.logToPriority log +#endif +#if alternateNumberFormat + LogAlternateNumberFormat log -> AlternateNumberFormat.logToPriority log +#endif + -- --------------------------------------------------------------------- -- | The plugins configured for use in this instance of the language diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 61d652f331..76cabb800c 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -16,7 +16,7 @@ module Development.IDE.Session ,retryOnSqliteBusy ,retryOnException ,Log(..) - ) where + , logToPriority) where -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses -- the real GHC library and the types are incompatible. Furthermore, when @@ -29,7 +29,7 @@ import Control.Monad import Control.Monad.Extra import Control.Monad.IO.Class import qualified Crypto.Hash.SHA1 as H -import Data.Aeson +import Data.Aeson hiding (Error) import Data.Bifunctor import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as B @@ -46,12 +46,13 @@ import qualified Data.Text as T import Data.Time.Clock import Data.Version import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake hiding (Log, withHieDb) +import Development.IDE.Core.Shake hiding (Log, Priority, + logToPriority, withHieDb) import qualified Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile, TargetModule, - Var) -import qualified Development.IDE.GHC.Compat.Core as GHC + Var, Warning) +import qualified Development.IDE.GHC.Compat.Core as GHC hiding (Warning) import Development.IDE.GHC.Compat.Env hiding (Logger) import Development.IDE.GHC.Compat.Units (UnitId) import Development.IDE.GHC.Util @@ -62,7 +63,7 @@ import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq, newHscEnvEqPreserveImportPaths) import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Priority (Debug), +import Development.IDE.Types.Logger (Priority (Debug, Error, Info, Warning), Recorder, logWith) import Development.IDE.Types.Options import GHC.Check @@ -220,6 +221,25 @@ instance Pretty Log where LogNewComponentCache componentCache -> "New component cache HscEnvEq:" <+> Prettyprinter.viaShow componentCache +logToPriority :: Log -> Priority +logToPriority = \case + LogSettingInitialDynFlags -> Debug + LogGetInitialGhcLibDirDefaultCradleFail{} -> Warning + LogGetInitialGhcLibDirDefaultCradleNone -> Warning + LogHieDbRetry{} -> Warning + LogHieDbRetriesExhausted{} -> Warning + LogHieDbWriterThreadSQLiteError{} -> Error + LogHieDbWriterThreadException{} -> Error + LogInterfaceFilesCacheDir{} -> Info + LogKnownFilesUpdated{} -> Debug + LogMakingNewHscEnv{} -> Info + LogDLLLoadError{} -> Error + LogCradlePath{} -> Info + LogCradleNotFound{} -> Warning + LogSessionLoadingResult{} -> Debug + LogCradle{} -> Debug + LogNewComponentCache{} -> Debug + -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String hiedbDataVersion = "1" diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 7bf0895549..a0302feddc 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -8,7 +8,7 @@ module Development.IDE.Core.FileExists , watchedGlobs , GetFileExists(..) , Log - ) + , logToPriority) where import Control.Concurrent.STM.Stats (atomically, @@ -19,15 +19,18 @@ import Control.Monad.IO.Class import qualified Data.ByteString as BS import Data.List (partition) import Data.Maybe -import Development.IDE.Core.FileStore hiding (Log) +import Development.IDE.Core.FileStore hiding (Log, + logToPriority) import qualified Development.IDE.Core.FileStore as FileStore import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Core.Shake hiding (Log, + logToPriority) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph import Development.IDE.Types.Location import Development.IDE.Types.Logger (Recorder, cmap) +import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options import qualified Focus import Ide.Plugin.Config (Config) @@ -97,6 +100,11 @@ instance Pretty Log where LogFileStore fileStoreLog -> pretty fileStoreLog LogShake shakeLog -> pretty shakeLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogFileStore log -> FileStore.logToPriority log + LogShake log -> Shake.logToPriority log + -- | Grab the current global value of 'FileExistsMap' without acquiring a dependency getFileExistsMapUntracked :: Action FileExistsMap getFileExistsMapUntracked = do diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index cc60d3fed0..2bf89f2b52 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -23,7 +23,7 @@ module Development.IDE.Core.FileStore( isWatchSupported, registerFileWatches, Log - ) where + , logToPriority) where import Control.Concurrent.STM.Stats (STM, atomically, modifyTVar') @@ -41,7 +41,8 @@ import qualified Data.Text as T import Data.Time import Data.Time.Clock.POSIX import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Core.Shake hiding (Log, + logToPriority) import Development.IDE.GHC.Orphans () import Development.IDE.Graph import Development.IDE.Import.DependencyInformation @@ -71,6 +72,7 @@ import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Logger (Recorder, cmap, logWith) +import qualified Development.IDE.Types.Logger as Logger import Language.LSP.Server hiding (getVirtualFile) import qualified Language.LSP.Server as LSP @@ -92,6 +94,8 @@ data Log -- log = L.logInfo logger . T.pack -- liftIO $ log $ "Could not identify reverse dependencies for " ++ show nfp | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath]) + -- the catch around previous logging statement is weird + -- does forcing nfp, or revs trigger than exception? -- liftIO $ (log $ "Typechecking reverse dependencies for " ++ show nfp ++ ": " ++ show revs) -- `catch` \(e :: SomeException) -> log (show e) | LogShake Shake.Log @@ -108,6 +112,12 @@ instance Pretty Log where <+> pretty (fmap (fmap show) reverseDepPaths) LogShake shakeLog -> pretty shakeLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogCouldNotIdentifyReverseDeps{} -> Logger.Info + LogTypeCheckingReverseDeps{} -> Logger.Info + LogShake shakeLog -> Shake.logToPriority shakeLog + makeVFSHandle :: IO VFSHandle makeVFSHandle = do vfsVar <- newVar (1, Map.empty) diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 49df24dc8b..663d29676b 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -16,7 +16,7 @@ module Development.IDE.Core.OfInterest( kick, FileOfInterestStatus(..), OfInterestVar(..), scheduleGarbageCollection, - Log) where + Log, logToPriority) where import Control.Concurrent.Strict import Control.Monad @@ -33,12 +33,14 @@ import qualified Data.ByteString as BS import Data.Maybe (catMaybes) import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Core.Shake hiding (Log, + logToPriority) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Plugin.Completions.Types import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Logger +import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options (IdeTesting (..)) import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP @@ -51,6 +53,10 @@ instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogShake log -> Shake.logToPriority log + newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) instance IsIdeGlobal OfInterestVar diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 63270b48fb..f50a888420 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -58,7 +58,7 @@ module Development.IDE.Core.Rules( typeCheckRuleDefinition, GhcSessionDepsConfig(..), Log - ) where + , logToPriority) where #if !MIN_VERSION_ghc(8,8,0) import Control.Applicative (liftA2) @@ -97,16 +97,16 @@ import qualified Data.Text.Encoding as T import Data.Time (UTCTime (..)) import Data.Tuple.Extra import Development.IDE.Core.Compile -import Development.IDE.Core.FileExists hiding (Log) +import Development.IDE.Core.FileExists hiding (logToPriority, Log) import Development.IDE.Core.FileStore (getFileContents, modificationTime, resetInterfaceStore) import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.OfInterest hiding (Log) +import Development.IDE.Core.OfInterest hiding (logToPriority, Log) import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service hiding (Log) -import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Core.Service hiding (logToPriority, Log) +import Development.IDE.Core.Shake hiding (logToPriority, Log) import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat.Core hiding (parseModule, @@ -116,7 +116,7 @@ import Development.IDE.GHC.Compat.Core hiding import qualified Development.IDE.GHC.Compat as Compat import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error -import Development.IDE.GHC.ExactPrint hiding (Log) +import Development.IDE.GHC.ExactPrint hiding (logToPriority, Log) import Development.IDE.GHC.Util hiding (modifyDynFlags) import Development.IDE.Graph @@ -153,6 +153,7 @@ import Language.LSP.Server (LspT) import System.Info.Extra (isMac) import HIE.Bios.Ghc.Gap (hostIsDynamic) import Development.IDE.Types.Logger (Recorder, cmap, logWith) +import qualified Development.IDE.Types.Logger as Logger import qualified Development.IDE.Core.Shake as Shake import qualified Development.IDE.GHC.ExactPrint as ExactPrint import Prettyprinter (Pretty (pretty), (<+>)) @@ -189,6 +190,15 @@ instance Pretty Log where "SUCCEEDED LOADING HIE FILE FOR" <+> pretty path LogExactPrint exactPrintLog -> pretty exactPrintLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogShake log -> Shake.logToPriority log + LogReindexingHieFile{} -> Logger.Debug + LogLoadingHieFile{} -> Logger.Debug + LogLoadingHieFileFail{} -> Logger.Debug + LogLoadingHieFileSuccess{} -> Logger.Debug + LogExactPrint log -> ExactPrint.logToPriority log + templateHaskellInstructions :: T.Text templateHaskellInstructions = "https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html#support-for-template-haskell" diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index 628618207c..6ecc48b712 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -16,12 +16,12 @@ module Development.IDE.Core.Service( ideLogger, updatePositionMapping, Log - ) where + , logToPriority) where import Control.Applicative ((<|>)) import Development.IDE.Core.Debouncer import Development.IDE.Core.FileExists (fileExistsRules) -import Development.IDE.Core.OfInterest hiding (Log) +import Development.IDE.Core.OfInterest hiding (Log, logToPriority) import Development.IDE.Graph import Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options (IdeOptions (..)) @@ -32,7 +32,7 @@ import qualified Language.LSP.Types as LSP import Control.Monad import qualified Development.IDE.Core.FileExists as FileExists import qualified Development.IDE.Core.OfInterest as OfInterest -import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Core.Shake hiding (Log, logToPriority) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Shake (WithHieDb) import Prettyprinter (Pretty (pretty)) @@ -51,6 +51,11 @@ instance Pretty Log where LogOfInterest ofInterestLog -> pretty ofInterestLog LogFileExists fileExistsLog -> pretty fileExistsLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogShake log -> Shake.logToPriority log + LogOfInterest log -> OfInterest.logToPriority log + LogFileExists log -> FileExists.logToPriority log ------------------------------------------------------------ -- Exposed API diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 187af0103f..9557919645 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -78,7 +78,7 @@ module Development.IDE.Core.Shake( garbageCollectDirtyKeys, garbageCollectDirtyKeysOlderThan, Log - ) where + , logToPriority) where import Control.Concurrent.Async import Control.Concurrent.STM @@ -233,6 +233,16 @@ instance Pretty Log where "defineEarlyCutoff RuleWithCustomNewnessCheck - file diagnostics:" <+> pretty (showDiagnosticsColored fileDiagnostics) +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogCreateHieDbExportsMapStart -> Logger.Debug + LogCreateHieDbExportsMapFinish{} -> Logger.Debug + LogBuildSessionRestart{} -> Logger.Debug + LogDelayedAction delayedAction _ -> actionPriority delayedAction + LogBuildSessionFinish{} -> Logger.Debug + LogDiagsDiffButNoLspEnv{} -> Logger.Info + LogDefineEarlyCutoffRuleNoDiagDiags{} -> Logger.Warning + LogDefineEarlyCutoffRuleCustomNewnessDiags{} -> Logger.Warning -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index 22fa702c7e..32e3f26174 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -32,7 +32,7 @@ module Development.IDE.GHC.ExactPrint -- * Helper function eqSrcSpan, Log - ) + , logToPriority) where import Control.Applicative (Alternative) @@ -54,7 +54,8 @@ import qualified Data.Text as T import Data.Traversable (for) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service (runAction) -import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Core.Shake hiding (Log, + logToPriority) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding (parseImport, parsePattern, @@ -63,6 +64,7 @@ import Development.IDE.Graph (RuleResult, Rules) import Development.IDE.Graph.Classes import Development.IDE.Types.Location import Development.IDE.Types.Logger (Recorder, cmap) +import qualified Development.IDE.Types.Logger as Logger import qualified GHC.Generics as GHC import Generics.SYB import Generics.SYB.GHC @@ -86,6 +88,10 @@ instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogShake log -> Shake.logToPriority log + data GetAnnotatedParsedSource = GetAnnotatedParsedSource deriving (Eq, Show, Typeable, GHC.Generic) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index cfc2908fbc..1a4eb53c86 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -11,7 +11,7 @@ module Development.IDE.LSP.LanguageServer ( runLanguageServer , Log - ) where + , logToPriority) where import Control.Concurrent.STM import Control.Monad.Extra @@ -32,15 +32,18 @@ import UnliftIO.Concurrent import UnliftIO.Directory import UnliftIO.Exception -import Development.IDE.Core.FileStore hiding (Log) +import Development.IDE.Core.FileStore hiding (Log, + logToPriority) import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Core.Shake hiding (Log, + logToPriority) import Development.IDE.Core.Tracing import Development.IDE.LSP.HoverDefinition import Development.IDE.Types.Logger import Control.Monad.IO.Unlift (MonadUnliftIO) import qualified Development.IDE.Session as Session +import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Shake (WithHieDb) import Prettyprinter (Pretty (pretty), (<+>)) import qualified Prettyprinter @@ -80,6 +83,15 @@ instance Pretty Log where "Cancelled request" <+> Prettyprinter.viaShow requestId (LogSession sessionLog) -> pretty sessionLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogRegisteringIdeConfig{} -> Logger.Info + LogReactorThreadException{} -> Logger.Error + LogReactorMessageActionException{} -> Logger.Error + LogReactorThreadStopped -> Logger.Info + LogCancelledRequest{} -> Logger.Debug + LogSession log -> Session.logToPriority log + issueTrackerUrl :: T.Text issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues" diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 5144656f2b..5d6bb6efde 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -10,7 +10,7 @@ module Development.IDE.LSP.Notifications ( whenUriFile , descriptor , Log - ) where + , logToPriority) where import Language.LSP.Types import qualified Language.LSP.Types as LSP @@ -29,10 +29,13 @@ import Development.IDE.Core.FileStore (registerFileWatches, setSomethingModified) import qualified Development.IDE.Core.FileStore as FileStore import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.OfInterest hiding (Log) +import Development.IDE.Core.OfInterest hiding (Log, + logToPriority) import Development.IDE.Core.RuleTypes (GetClientSettings (..)) -import Development.IDE.Core.Service hiding (Log) -import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Core.Service hiding (Log, + logToPriority) +import Development.IDE.Core.Shake hiding (Log, Priority, + logToPriority) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Location import Development.IDE.Types.Logger @@ -50,6 +53,11 @@ instance Pretty Log where LogShake shakeLog -> pretty shakeLog LogFileStore fileStoreLog -> pretty fileStoreLog +logToPriority :: Log -> Priority +logToPriority = \case + LogShake shakeLog -> Shake.logToPriority shakeLog + LogFileStore fileStoreLog -> FileStore.logToPriority fileStoreLog + whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 3a5223ac1e..71d63b5534 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -9,7 +9,7 @@ module Development.IDE.Main ,commandP ,defaultMain -- ,testing -,Log, testing) where +,Log, testing, logToPriority) where import Control.Concurrent.Extra (newLock, withLock, withNumCapabilities) import Control.Concurrent.STM.Stats (atomically, @@ -81,6 +81,7 @@ import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath') import Development.IDE.Types.Logger (Logger (Logger), Recorder, cmap, logWith) +import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options (IdeGhcSession, IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), IdeTesting (IdeTesting), @@ -179,6 +180,22 @@ instance Pretty Log where LogPluginHLS pluginHLSLog -> pretty pluginHLSLog LogRules rulesLog -> pretty rulesLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogHeapStats log -> HeapStats.logToPriority log + LogLspStart -> Logger.Info + LogLspStartDuration{} -> Logger.Info + LogShouldRunSubset{} -> Logger.Debug + LogOnlyPartialGhc9Support -> Logger.Warning + LogSetInitialDynFlagsException{} -> Logger.Debug + LogService log -> Service.logToPriority log + LogShake log -> Shake.logToPriority log + LogGhcIde log -> GhcIde.logToPriority log + LogLanguageServer log -> LanguageServer.logToPriority log + LogSession log -> Session.logToPriority log + LogPluginHLS log -> PluginHLS.logToPriority log + LogRules log -> Rules.logToPriority log + data Command = Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures | Db {hieOptions :: HieDb.Options, hieCommand :: HieDb.Command} diff --git a/ghcide/src/Development/IDE/Main/HeapStats.hs b/ghcide/src/Development/IDE/Main/HeapStats.hs index 5160738357..5648978a4c 100644 --- a/ghcide/src/Development/IDE/Main/HeapStats.hs +++ b/ghcide/src/Development/IDE/Main/HeapStats.hs @@ -1,12 +1,13 @@ {-# LANGUAGE NumericUnderscores #-} -- | Logging utilities for reporting heap statistics -module Development.IDE.Main.HeapStats ( withHeapStats, Log ) where +module Development.IDE.Main.HeapStats ( withHeapStats, Log , logToPriority) where import Control.Concurrent import Control.Concurrent.Async import Control.Monad import Data.Word import Development.IDE.Types.Logger (Recorder, logWith) +import qualified Development.IDE.Types.Logger as Logger import GHC.Stats import Prettyprinter (Pretty (pretty), (<+>)) import qualified Prettyprinter @@ -45,6 +46,11 @@ instance Pretty Log where toFormattedMegabytes :: Word64 -> String toFormattedMegabytes b = printf "%.2fMB" (fromIntegral @Word64 @Double b / 1e6) +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogHeapStatsPeriod{} -> Logger.Info + LogHeapStatsDisabled -> Logger.Info + LogHeapStats{} -> Logger.Info -- | Interval at which to report the latest heap statistics. heapStatsInterval :: Int diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index ccedf2ea63..fdaa51785a 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -4,7 +4,7 @@ module Development.IDE.Plugin.Completions ( descriptor , Log - ) where + , logToPriority) where import Control.Concurrent.Async (concurrently) import Control.Concurrent.STM.Stats (readTVarIO) @@ -19,8 +19,10 @@ import Data.Maybe import qualified Data.Text as T import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service hiding (Log) -import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Core.Service hiding (Log, + logToPriority) +import Development.IDE.Core.Shake hiding (Log, + logToPriority) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (rangeToSrcSpan) @@ -40,6 +42,7 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq (envPack import qualified Development.IDE.Types.KnownTargets as KT import Development.IDE.Types.Location import Development.IDE.Types.Logger (Recorder, cmap) +import qualified Development.IDE.Types.Logger as Logger import GHC.Exts (fromList, toList) import Ide.Plugin.Config (Config) import Ide.Types @@ -55,6 +58,10 @@ instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogShake shakeLog -> Shake.logToPriority shakeLog + descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = produceCompletions recorder diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 9c41da9fa3..01765fe9d3 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -7,7 +7,7 @@ module Development.IDE.Plugin.HLS ( asGhcIdePlugin , Log - ) where + , logToPriority) where import Control.Exception (SomeException) import Control.Monad @@ -22,13 +22,14 @@ import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) import qualified Data.Map as Map import Data.String import qualified Data.Text as T -import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Core.Shake hiding (Log, logToPriority) import Development.IDE.Core.Tracing import Development.IDE.Graph (Rules) import Development.IDE.LSP.Server import Development.IDE.Plugin import qualified Development.IDE.Plugin as P import Development.IDE.Types.Logger +import qualified Development.IDE.Types.Logger as Logger import Ide.Plugin.Config import Ide.PluginUtils (getClientConfig) import Ide.Types as HLS @@ -54,6 +55,10 @@ instance Pretty Log where LogNoEnabledPlugins -> "extensibleNotificationPlugins no enabled plugins" +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogNoEnabledPlugins -> Logger.Info + -- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: Recorder Log -> IdePlugins IdeState -> Plugin Config asGhcIdePlugin recorder (IdePlugins ls) = diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index fd7d810f83..643e429ae9 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -6,7 +6,7 @@ module Development.IDE.Plugin.HLS.GhcIde ( descriptors , Log - ) where + , logToPriority) where import Control.Monad.IO.Class import Development.IDE import Development.IDE.LSP.HoverDefinition @@ -15,6 +15,7 @@ import Development.IDE.LSP.Outline import qualified Development.IDE.Plugin.CodeAction as CodeAction import qualified Development.IDE.Plugin.Completions as Completions import qualified Development.IDE.Plugin.TypeLenses as TypeLenses +import qualified Development.IDE.Types.Logger as Logger import Ide.Types import Language.LSP.Server (LspM) import Language.LSP.Types @@ -33,6 +34,12 @@ instance Pretty Log where LogCompletions completionsLog -> pretty completionsLog LogTypeLenses typeLensesLog -> pretty typeLensesLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogNotifications log -> Notifications.logToPriority log + LogCompletions log -> Completions.logToPriority log + LogTypeLenses log -> TypeLenses.logToPriority log + descriptors :: Recorder Log -> [PluginDescriptor IdeState] descriptors recorder = [ descriptor "ghcide-hover-and-symbols", diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 7225078009..09f258bb0f 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -11,7 +11,7 @@ module Development.IDE.Plugin.TypeLenses ( GetGlobalBindingTypeSigs (..), GlobalBindingTypeSigsResult (..), Log -) where +, logToPriority) where import Control.Concurrent.STM.Stats (atomically) import Control.DeepSeq (rwhnf) @@ -44,6 +44,7 @@ import Development.IDE.Types.Location (Position (Position, _chara toNormalizedFilePath', uriToFilePath') import Development.IDE.Types.Logger (Recorder, cmap) +import qualified Development.IDE.Types.Logger as Logger import GHC.Generics (Generic) import Ide.Plugin.Config (Config) import Ide.Plugin.Properties @@ -78,6 +79,10 @@ instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogShake log -> Shake.logToPriority log + typeLensCommandId :: T.Text typeLensCommandId = "typesignature.add" diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index f723135bbe..455dab6030 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -225,12 +225,13 @@ textWithPriorityToText = \case pure $ Text.intercalate " | " [ utcTimeToText utcTime -- , callStackToLocationText callStack - , threadIdToText threadId - -- , priorityToText priority + -- , threadIdToText threadId + , priorityToText priority , payload ] where utcTimeToText utcTime = Text.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime + threadIdToText :: Int -> Text threadIdToText = Text.pack . show callStackToLocationText callStack = srcLocText diff --git a/plugins/default/src/Ide/Plugin/Example.hs b/plugins/default/src/Ide/Plugin/Example.hs index 74669340ed..867823f9ec 100644 --- a/plugins/default/src/Ide/Plugin/Example.hs +++ b/plugins/default/src/Ide/Plugin/Example.hs @@ -14,31 +14,32 @@ module Ide.Plugin.Example ( descriptor , Log - ) where + , logToPriority) where import Control.Concurrent.STM -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData) import Control.Monad.IO.Class import Control.Monad.Trans.Maybe import Data.Aeson import Data.Functor -import qualified Data.HashMap.Strict as Map +import qualified Data.HashMap.Strict as Map import Data.Hashable -import qualified Data.Text as T +import qualified Data.Text as T import Data.Typeable -import Development.IDE as D -import Development.IDE.Core.Shake (getDiagnostics, - getHiddenDiagnostics) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat (ParsedModule (ParsedModule)) +import Development.IDE as D +import Development.IDE.Core.Shake (getDiagnostics, + getHiddenDiagnostics) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Compat (ParsedModule (ParsedModule)) +import qualified Development.IDE.Types.Logger as Logger import GHC.Generics import Ide.PluginUtils import Ide.Types import Language.LSP.Server import Language.LSP.Types -import Options.Applicative (ParserInfo, info) -import Prettyprinter (Pretty (pretty)) -import Text.Regex.TDFA.Text () +import Options.Applicative (ParserInfo, info) +import Prettyprinter (Pretty (pretty)) +import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- @@ -48,6 +49,10 @@ instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogShake log -> Shake.logToPriority log + descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = exampleRules recorder diff --git a/plugins/default/src/Ide/Plugin/Example2.hs b/plugins/default/src/Ide/Plugin/Example2.hs index 6811728cd5..a8564fc682 100644 --- a/plugins/default/src/Ide/Plugin/Example2.hs +++ b/plugins/default/src/Ide/Plugin/Example2.hs @@ -14,28 +14,29 @@ module Ide.Plugin.Example2 ( descriptor , Log - ) where + , logToPriority) where import Control.Concurrent.STM -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData) import Control.Monad.IO.Class import Control.Monad.Trans.Maybe import Data.Aeson import Data.Functor -import qualified Data.HashMap.Strict as Map +import qualified Data.HashMap.Strict as Map import Data.Hashable -import qualified Data.Text as T +import qualified Data.Text as T import Data.Typeable -import Development.IDE as D -import Development.IDE.Core.Shake hiding (Log) -import qualified Development.IDE.Core.Shake as Shake +import Development.IDE as D +import Development.IDE.Core.Shake hiding (Log, logToPriority) +import qualified Development.IDE.Core.Shake as Shake +import qualified Development.IDE.Types.Logger as Logger import GHC.Generics import Ide.PluginUtils import Ide.Types import Language.LSP.Server import Language.LSP.Types -import Prettyprinter (Pretty (pretty)) -import Text.Regex.TDFA.Text () +import Prettyprinter (Pretty (pretty)) +import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- @@ -45,6 +46,10 @@ instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogShake log -> Shake.logToPriority log + descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = exampleRules recorder diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs index 0849cc8bdb..f5c755915c 100644 --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Ide.Plugin.AlternateNumberFormat (descriptor, Log) where +module Ide.Plugin.AlternateNumberFormat (descriptor, Log, logToPriority) where import Control.Lens ((^.)) import Control.Monad.Except (ExceptT, MonadIO, liftIO) @@ -37,6 +37,10 @@ instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogShake log -> Shake.logToPriority log + descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionHandler diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs index af351a498c..b85e87be40 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs @@ -9,10 +9,11 @@ Eval Plugin entry point. module Ide.Plugin.Eval ( descriptor, Log -) where +, logToPriority) where import Development.IDE (IdeState) import Development.IDE.Types.Logger (Recorder, cmap) +import qualified Development.IDE.Types.Logger as Logger import qualified Ide.Plugin.Eval.CodeLens as CL import Ide.Plugin.Eval.Rules (rules) import qualified Ide.Plugin.Eval.Rules as EvalRules @@ -28,6 +29,10 @@ instance Pretty Log where pretty = \case LogEvalRules evalRulesLog -> pretty evalRulesLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogEvalRules log -> EvalRules.logToPriority log + -- |Plugin descriptor descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs index 08cbfc2d7a..95e56b1be7 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -3,7 +3,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} -module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, Log) where +module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, Log, logToPriority) where import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.HashSet (HashSet) @@ -37,6 +37,7 @@ import qualified Development.IDE.GHC.Compat as SrcLoc import qualified Development.IDE.GHC.Compat.Util as FastString import Development.IDE.Graph (alwaysRerun) import Development.IDE.Types.Logger (Recorder, cmap) +import qualified Development.IDE.Types.Logger as Logger import Ide.Plugin.Eval.Types import Prettyprinter (Pretty (pretty)) @@ -46,6 +47,10 @@ instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogShake log -> Shake.logToPriority log + rules :: Recorder Log -> Rules () rules recorder = do evalParsedModuleRule recorder diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 64d939ff24..db234b666a 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -15,6 +15,7 @@ module Ide.Plugin.ExplicitImports , extractMinimalImports , within , Log + , logToPriority ) where import Control.DeepSeq @@ -34,6 +35,7 @@ import Development.IDE.Core.PositionMapping import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.Graph.Classes +import qualified Development.IDE.Types.Logger as Logger import GHC.Generics (Generic) import Ide.PluginUtils (mkLspCommand) import Ide.Types @@ -52,6 +54,10 @@ instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogShake log -> Shake.logToPriority log + -- | The "main" function of a plugin descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState descriptor recorder = descriptorForModules recorder (/= moduleName pRELUDE) diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index d58e41791e..4771083d86 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -28,7 +28,7 @@ module Ide.Plugin.Hlint ( descriptor , Log - ) where + , logToPriority) where import Control.Arrow ((&&&)) import Control.Concurrent.STM import Control.DeepSeq @@ -121,6 +121,7 @@ import Development.IDE.Spans.Pragmas (LineSplitTe lineSplitInsertTextEdit, lineSplitTextEdits, nextPragmaLine) +import qualified Development.IDE.Types.Logger as Logger import Prettyprinter (Pretty (pretty)) import System.Environment (setEnv, unsetEnv) @@ -134,6 +135,10 @@ instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogShake log -> Shake.logToPriority log + #ifdef HLINT_ON_GHC_LIB -- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib pattern RealSrcSpan :: GHC.RealSrcSpan -> Maybe BufSpan -> GHC.SrcSpan diff --git a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs index 460754808c..d638bbb823 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -8,7 +8,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -module Ide.Plugin.RefineImports (descriptor, Log) where +module Ide.Plugin.RefineImports (descriptor, Log, logToPriority) where import Control.Arrow (Arrow (second)) import Control.DeepSeq (rwhnf) @@ -40,6 +40,7 @@ import Development.IDE.GHC.Compat tcg_exports, unLoc) -} import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph.Classes +import qualified Development.IDE.Types.Logger as Logger import GHC.Generics (Generic) import Ide.Plugin.ExplicitImports (extractMinimalImports, within) @@ -55,6 +56,10 @@ instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogShake log -> Shake.logToPriority log + -- | plugin declaration descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs index 6b5d224d46..a2d45b99bc 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs @@ -1,5 +1,5 @@ -- | A plugin that uses tactics to synthesize code -module Ide.Plugin.Tactic (descriptor, Log) where +module Ide.Plugin.Tactic (descriptor, Log, logToPriority) where import Wingman.Plugin diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index 6689a35ea1..12a2df82fb 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -66,6 +66,7 @@ import Wingman.Types import Development.IDE.Types.Logger (Recorder, cmap) import qualified Development.IDE.Core.Shake as Shake import Prettyprinter (Pretty (pretty)) +import qualified Development.IDE.Types.Logger as Logger newtype Log @@ -76,6 +77,10 @@ instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogShake log -> Shake.logToPriority log + tacticDesc :: T.Text -> T.Text tacticDesc name = "fill the hole using the " <> name <> " tactic" diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index 6e9aa3d406..4e7fe8e587 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -15,6 +15,7 @@ import Wingman.LanguageServer.Metaprogram (hoverProvider) import Wingman.StaticPlugin import Development.IDE.Types.Logger (Recorder, cmap) import Prettyprinter (Pretty (pretty)) +import qualified Development.IDE.Types.Logger as Logger newtype Log = LogWingmanLanguageServer WingmanLanguageServer.Log @@ -24,6 +25,9 @@ instance Pretty Log where pretty = \case LogWingmanLanguageServer wingmanLanguageServerLog -> pretty wingmanLanguageServerLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogWingmanLanguageServer log -> WingmanLanguageServer.logToPriority log descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState descriptor recorder plId diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index a2b011c9c6..04e10fd0bd 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -2,12 +2,13 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -module Ide.Main(defaultMain, runLspMode, Log) where +module Ide.Main(defaultMain, runLspMode, Log, logToPriority) where import Control.Monad.Extra import qualified Data.Aeson.Encode.Pretty as A @@ -15,13 +16,14 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Default import Data.List (sort) import qualified Data.Text as T -import Development.IDE.Core.Rules hiding (Log) +import Development.IDE.Core.Rules hiding (Log, logToPriority) import Development.IDE.Core.Tracing (withTelemetryLogger) import Development.IDE.Graph (ShakeOptions (shakeThreads)) import Development.IDE.Main (isLSP) import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Session as Session import Development.IDE.Types.Logger as G +import qualified Development.IDE.Types.Logger as Logger import qualified Development.IDE.Types.Options as Ghcide import Ide.Arguments import Ide.Logger @@ -57,6 +59,13 @@ instance Pretty Log where , "PluginIds:" <+> pretty pluginIds ] LogIDEMain iDEMainLog -> pretty iDEMainLog +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogVersion{} -> Logger.Info + LogDirectory{} -> Logger.Info + LogLspStart{} -> Logger.Info + LogIDEMain log -> IDEMain.logToPriority log + defaultMain :: Recorder Log -> Arguments -> IdePlugins IdeState -> IO () defaultMain recorder args idePlugins = do -- WARNING: If you write to stdout before runLanguageServer From 5d879b08708d7cee93ade945adbbd61c6c7322bc Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Mon, 10 Jan 2022 22:31:23 -0500 Subject: [PATCH 19/43] fix slight interleaving issue with hslogger and logger both logging, have default logger be mutex stderr or file handle, use stderr if failing to open log file --- exe/Main.hs | 16 +- ghcide/exe/Main.hs | 11 +- ghcide/src/Development/IDE/Types/Logger.hs | 177 +++++++++------------ ghcide/test/exe/Main.hs | 5 +- hls-test-utils/src/Test/Hls.hs | 5 +- 5 files changed, 92 insertions(+), 122 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index 7da16e9de1..0247d3463b 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -9,8 +9,8 @@ import Data.Function ((&)) import Data.Text (Text) import Development.IDE.Types.Logger (Priority (Debug, Info), WithPriority (WithPriority, priority), - cfilter, cmap, setupHsLogger, - withDefaultTextWithPriorityRecorderAndHandle) + cfilter, cmap, + withDefaultRecorder) import qualified Development.IDE.Types.Logger as Logger import Ide.Arguments (Arguments (..), GhcideArguments (..), @@ -51,17 +51,15 @@ main :: IO () main = do args <- getArguments "haskell-language-server" (Plugins.idePlugins mempty False) - let (hsLoggerMinLogLevel, minPriority, logFilePath, includeExamplePlugins) = + let (hsLoggerMinPriority, minPriority, logFilePath, includeExamplePlugins) = case args of Ghcide GhcideArguments{ argsTesting, argsDebugOn, argsLogFile, argsExamplePlugin } -> - let (minHsLoggerLogLevel, minPriority) = - if argsDebugOn || argsTesting then (HsLogger.DEBUG, Info) else (HsLogger.INFO, Info) - in (minHsLoggerLogLevel, minPriority, argsLogFile, argsExamplePlugin) + let (minHsLoggerPriority, minPriority) = + if argsDebugOn || argsTesting then (HsLogger.DEBUG, Debug) else (HsLogger.INFO, Info) + in (minHsLoggerPriority, minPriority, argsLogFile, argsExamplePlugin) _ -> (HsLogger.INFO, Info, Nothing, False) - withDefaultTextWithPriorityRecorderAndHandle logFilePath $ \textWithPriorityRecorder handle -> do - -- until the contravariant logging system is fully in place - setupHsLogger (Just handle) ["hls", "hie-bios"] hsLoggerMinLogLevel + withDefaultRecorder logFilePath hsLoggerMinPriority $ \textWithPriorityRecorder -> do let recorder = textWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 9e5e1c35bf..d73547a7b5 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -15,8 +15,7 @@ import qualified Data.Text as Text import Data.Version (showVersion) import Development.GitRev (gitHash) import Development.IDE (Priority (Debug, Info), - action, - makeDefaultTextWithPriorityStderrRecorder) + action) import Development.IDE.Core.OfInterest (kick) import Development.IDE.Core.Rules (mainRule) import qualified Development.IDE.Core.Rules as Rules @@ -25,7 +24,8 @@ import Development.IDE.Graph (ShakeOptions (shakeThreads)) import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde import Development.IDE.Types.Logger (WithPriority (WithPriority, priority), - cfilter, cmap) + cfilter, cmap, + makeDefaultStderrRecorder) import Development.IDE.Types.Options import Ide.Plugin.Config (Config (checkParents, checkProject)) import Ide.PluginUtils (pluginDescToIdePlugins) @@ -35,6 +35,7 @@ import System.Environment (getExecutablePath) import System.Exit (exitSuccess) import System.IO (hPutStrLn, stderr) import System.Info (compilerVersion) +import qualified System.Log as HsLogger data Log = LogIDEMain IDEMain.Log @@ -70,9 +71,9 @@ main = withTelemetryLogger $ \telemetryLogger -> do Nothing -> IO.getCurrentDirectory Just root -> IO.setCurrentDirectory root >> IO.getCurrentDirectory - let minPriority = if argsVerbose then Debug else Info + let (hsLoggerMinPriority, minPriority) = if argsVerbose then (HsLogger.DEBUG, Debug) else (HsLogger.INFO, Info) - textWithPriorityStderrRecorder <- makeDefaultTextWithPriorityStderrRecorder + textWithPriorityStderrRecorder <- makeDefaultStderrRecorder hsLoggerMinPriority let recorder = textWithPriorityStderrRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority) diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index 455dab6030..48c319d74d 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -12,14 +12,14 @@ module Development.IDE.Types.Logger , logError, logWarning, logInfo, logDebug, logTelemetry , noLogging , WithPriority(..) - , logWith, cmap, cmapIO, cfilter, withDefaultTextWithPriorityRecorder, makeDefaultTextWithPriorityStderrRecorder, setupHsLogger, withDefaultTextWithPriorityRecorderAndHandle) where + , logWith, cmap, cmapIO, cfilter, withDefaultRecorder, makeDefaultStderrRecorder) where import Control.Concurrent (myThreadId) -import Control.Concurrent.Extra (newLock, withLock) +import Control.Concurrent.Extra (Lock, newLock, withLock) +import Control.Exception (IOException, try) import Control.Monad (forM_, when, (>=>)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Functor.Contravariant (Contravariant (contramap)) -import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text as Text @@ -30,44 +30,13 @@ import GHC.Stack (HasCallStack, SrcLoc (SrcLoc, srcLocModule, srcLocStartLine), getCallStack, withFrozenCallStack) import System.IO (Handle, IOMode (AppendMode), - hClose, hFlush, hSetEncoding, - stderr, utf8) + hFlush, hSetEncoding, 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 -import UnliftIO (MonadUnliftIO, withFile) - --- taken from LSP.setupLogger --- used until contravariant logging system is fully in place -setupHsLogger :: Maybe Handle -> [String] -> HSLogger.Priority -> IO () -setupHsLogger handle extraLogNames level = do - let logStream = fromMaybe stderr handle - - hSetEncoding logStream utf8 - - logH <- HSL.streamHandler logStream level - - let logHandle = logH {HSL.closeFunc = hClose} - 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" - - -- handleIOException :: FilePath -> IOException -> IO Handle - -- handleIOException logFile _ = do - -- hPutStr stderr $ "Couldn't open log file " ++ logFile ++ "; falling back to stderr logging" - -- return stderr +import qualified System.Log.Logger as HsLogger +import UnliftIO (MonadUnliftIO, finally, hClose, + openFile) data Priority @@ -119,8 +88,7 @@ data WithPriority a = WithPriority { priority :: Priority, payload :: a } derivi -- You shouldn't call warning/error if the user has caused an error, only -- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). data Recorder msg = Recorder - { logger_ :: forall m. (HasCallStack, MonadIO m) => msg -> m () - } + { logger_ :: forall m. (HasCallStack, MonadIO m) => msg -> m () } logWith :: (HasCallStack, MonadIO m) => Recorder msg -> msg -> m () logWith recorder msg = withFrozenCallStack $ logger_ recorder msg @@ -128,20 +96,17 @@ logWith recorder msg = withFrozenCallStack $ logger_ recorder msg instance Semigroup (Recorder msg) where (<>) Recorder{ logger_ = logger_1 } Recorder{ logger_ = logger_2 } = Recorder - { logger_ = \msg -> logger_1 msg >> logger_2 msg - } + { logger_ = \msg -> logger_1 msg >> logger_2 msg } instance Monoid (Recorder msg) where mempty = Recorder - { logger_ = \_ -> pure () - } + { logger_ = \_ -> pure () } instance Contravariant Recorder where contramap f Recorder{ logger_ } = Recorder - { logger_ = logger_ . f - } + { logger_ = logger_ . f } cmap :: (a -> b) -> Recorder b -> Recorder a cmap = contramap @@ -149,73 +114,77 @@ cmap = contramap cmapIO :: (a -> IO b) -> Recorder b -> Recorder a cmapIO f Recorder{ logger_ } = Recorder - { logger_ = (liftIO . f) >=> logger_ - } + { logger_ = (liftIO . f) >=> logger_ } cfilter :: (a -> Bool) -> Recorder a -> Recorder a cfilter p Recorder{ logger_ } = Recorder - { logger_ = \msg -> when (p msg) (logger_ msg) - } + { logger_ = \msg -> when (p msg) (logger_ msg) } textHandleRecorder :: Handle -> Recorder Text textHandleRecorder handle = Recorder - { logger_ = \text -> liftIO $ Text.hPutStrLn handle text *> hFlush handle - } - -textStderrRecorder :: Recorder Text -textStderrRecorder = textHandleRecorder stderr - --- | Cheap stderr logger_ that relies on LineBuffering -threadSafeTextStderrRecorder :: IO (Recorder Text) -threadSafeTextStderrRecorder = do - lock <- newLock - let Recorder{ logger_ } = textStderrRecorder - pure $ Recorder - { logger_ = \msg -> liftIO $ withLock lock (logger_ msg) - } - -makeThreadSafeTextStderrRecorder :: MonadIO m => m (Recorder Text) -makeThreadSafeTextStderrRecorder = liftIO threadSafeTextStderrRecorder - -makeDefaultTextWithPriorityStderrRecorder :: MonadIO m => m (Recorder (WithPriority Text)) -makeDefaultTextWithPriorityStderrRecorder = do - textStderrRecorder <- makeThreadSafeTextStderrRecorder - pure $ cmapIO textWithPriorityToText textStderrRecorder - -withTextFileRecorder :: MonadUnliftIO m => FilePath -> (Recorder Text -> m a) -> m a -withTextFileRecorder path action = withFile path AppendMode $ \handle -> do - action (textHandleRecorder handle) - --- | if no file path given use stderr, else use stderr and file --- TODO: doesn't handle case where opening file fails -withDefaultTextRecorder :: MonadUnliftIO m => Maybe FilePath -> (Recorder Text -> m a) -> m a -withDefaultTextRecorder path action = do - textStderrRecorder <- makeThreadSafeTextStderrRecorder + { logger_ = \text -> liftIO $ Text.hPutStrLn handle text *> hFlush handle } + +makeDefaultStderrRecorder :: MonadIO m => HsLogger.Priority -> m (Recorder (WithPriority Text)) +makeDefaultStderrRecorder hsLoggerMinPriority = do + lock <- liftIO newLock + makeDefaultHandleRecorder hsLoggerMinPriority lock stderr + +-- | If no path given then use stderr, otherwise use file. +-- kinda complicated because we are logging with both hslogger and our own +-- logger simultaneously +withDefaultRecorder + :: MonadUnliftIO m + => Maybe FilePath + -> HsLogger.Priority + -> (Recorder (WithPriority Text) -> m a) + -> m a +withDefaultRecorder path hsLoggerMinPriority action = do + lock <- liftIO newLock + let makeHandleRecorder = makeDefaultHandleRecorder hsLoggerMinPriority lock case path of - Nothing -> action textStderrRecorder - Just path -> withTextFileRecorder path $ \textFileRecorder -> - action (textStderrRecorder <> textFileRecorder) - -withDefaultTextWithPriorityRecorder :: MonadUnliftIO m => Maybe FilePath -> (Recorder (WithPriority Text) -> m a) -> m a -withDefaultTextWithPriorityRecorder path action = do - withDefaultTextRecorder path $ \textRecorder -> - action (cmapIO textWithPriorityToText textRecorder) - --- temporary until contravariant logging is a thing -withDefaultTextWithPriorityRecorderAndHandle :: MonadUnliftIO m - => Maybe FilePath - -> (Recorder (WithPriority Text) -> Handle -> m a) - -> m a -withDefaultTextWithPriorityRecorderAndHandle path action = do - textStderrRecorder <- makeThreadSafeTextStderrRecorder - let textWithPriorityStderrRecorder = cmapIO textWithPriorityToText textStderrRecorder - case path of - Nothing -> action textWithPriorityStderrRecorder stderr - Just path -> withFile path AppendMode $ \handle -> do - let textWithPriorityHandleRecorder = cmapIO textWithPriorityToText (textHandleRecorder handle) - action (textWithPriorityStderrRecorder <> textWithPriorityHandleRecorder) handle + Nothing -> makeHandleRecorder stderr >>= action + Just path -> do + handle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode) + case handle of + Left _ -> makeHandleRecorder stderr >>= \recorder -> + logWith recorder (WithPriority Error $ "Couldn't open log file " <> Text.pack path <> "; falling back to stderr.") + >> action recorder + Right handle -> finally (makeHandleRecorder handle >>= action) (hClose handle) + +makeDefaultHandleRecorder :: MonadIO m => HsLogger.Priority -> Lock -> Handle -> m (Recorder (WithPriority Text)) +makeDefaultHandleRecorder hsLoggerMinPriority lock handle = do + let Recorder{ logger_ } = textHandleRecorder handle + let threadSafeRecorder = Recorder { logger_ = \msg -> liftIO $ withLock lock (logger_ msg) } + let textWithPriorityRecorder = cmapIO textWithPriorityToText threadSafeRecorder + liftIO $ setupHsLogger lock handle ["hls", "hie-bios"] hsLoggerMinPriority + pure textWithPriorityRecorder + +-- taken from LSP.setupLogger +-- used until contravariant logging system is fully in place +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" textWithPriorityToText :: WithPriority Text -> IO Text textWithPriorityToText = \case diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 0361b1fa30..38981ab66c 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -115,10 +115,11 @@ import Test.Tasty.QuickCheck import Text.Printf (printf) import Text.Regex.TDFA ((=~)) import qualified HieDbRetry -import Development.IDE.Types.Logger (WithPriority(WithPriority), makeDefaultTextWithPriorityStderrRecorder, Priority (Info), cmap, Recorder) +import Development.IDE.Types.Logger (WithPriority(WithPriority), Priority (Info), cmap, Recorder, makeDefaultStderrRecorder) import Data.Function ((&)) import qualified Data.Text as Text import Data.Text (Text) +import qualified System.Log as HsLogger data Log = LogGhcIde Ghcide.Log @@ -157,7 +158,7 @@ logToTextWithPriority = WithPriority Info . Text.pack . show main :: IO () main = do - textWithPriorityStderrRecorder <- makeDefaultTextWithPriorityStderrRecorder + textWithPriorityStderrRecorder <- makeDefaultStderrRecorder HsLogger.DEBUG let recorder = textWithPriorityStderrRecorder & cmap logToTextWithPriority diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index cffba47d8f..ef0cca628c 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -63,7 +63,7 @@ import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Types.Logger (Priority (Debug), WithPriority (WithPriority), cmap, - makeDefaultTextWithPriorityStderrRecorder) + makeDefaultStderrRecorder) import Development.IDE.Types.Options import GHC.IO.Handle import Ide.Plugin.Config (Config, formattingProvider) @@ -81,6 +81,7 @@ import System.Directory (getCurrentDirectory, import System.Environment (lookupEnv) import System.FilePath import System.IO.Unsafe (unsafePerformIO) +import qualified System.Log as HsLogger import System.Process.Extra (createPipe) import System.Time.Extra import Test.Hls.Util @@ -181,7 +182,7 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre (inR, inW) <- createPipe (outR, outW) <- createPipe - textWithPriorityRecorder <- makeDefaultTextWithPriorityStderrRecorder + textWithPriorityRecorder <- makeDefaultStderrRecorder HsLogger.DEBUG logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR" From e94fd03d4ed7fdbe2ced3b8044d8959cc382aa87 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Mon, 10 Jan 2022 23:12:26 -0500 Subject: [PATCH 20/43] forgot to add .cabal files with hslogger dep --- ghcide/ghcide.cabal | 2 ++ hls-test-utils/hls-test-utils.cabal | 1 + 2 files changed, 3 insertions(+) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index c10923c66f..ece6773a74 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -306,6 +306,7 @@ executable ghcide "-with-rtsopts=-I0 -A128M -T" main-is: Main.hs build-depends: + hslogger, hiedb, aeson, base == 4.*, @@ -385,6 +386,7 @@ test-suite ghcide-tests lsp, lsp-types, hls-plugin-api, + hslogger, network-uri, lens, list-t, diff --git a/hls-test-utils/hls-test-utils.cabal b/hls-test-utils/hls-test-utils.cabal index 5eb4c7cfaa..c35baa8f4d 100644 --- a/hls-test-utils/hls-test-utils.cabal +++ b/hls-test-utils/hls-test-utils.cabal @@ -44,6 +44,7 @@ library , ghcide ^>=1.5.0 , hls-graph , hls-plugin-api ^>=1.2 + , hslogger , hspec <2.8 , hspec-core , lens From eb7a69af3189be7583cb51eeaaedf4502b340019 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Tue, 11 Jan 2022 00:02:47 -0500 Subject: [PATCH 21/43] dont use UnliftIO file IO helpers because they are too new --- ghcide/src/Development/IDE/Types/Logger.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index 48c319d74d..62304bed6b 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -30,14 +30,13 @@ import GHC.Stack (HasCallStack, SrcLoc (SrcLoc, srcLocModule, srcLocStartLine), getCallStack, withFrozenCallStack) import System.IO (Handle, IOMode (AppendMode), - hFlush, hSetEncoding, stderr, utf8) + 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 -import UnliftIO (MonadUnliftIO, finally, hClose, - openFile) - +import UnliftIO (MonadUnliftIO, finally) data Priority -- Don't change the ordering of this type or you will mess up the Ord @@ -151,7 +150,7 @@ withDefaultRecorder path hsLoggerMinPriority action = do Left _ -> makeHandleRecorder stderr >>= \recorder -> logWith recorder (WithPriority Error $ "Couldn't open log file " <> Text.pack path <> "; falling back to stderr.") >> action recorder - Right handle -> finally (makeHandleRecorder handle >>= action) (hClose handle) + Right handle -> finally (makeHandleRecorder handle >>= action) (liftIO $ hClose handle) makeDefaultHandleRecorder :: MonadIO m => HsLogger.Priority -> Lock -> Handle -> m (Recorder (WithPriority Text)) makeDefaultHandleRecorder hsLoggerMinPriority lock handle = do From d430883c039787304f1d5151d3015ba1cfe0f002 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Tue, 11 Jan 2022 17:16:24 -0500 Subject: [PATCH 22/43] remove log helper comments, use Doc instead of Text as final console/file logger input, renaming, export Log constructors --- exe/Main.hs | 19 +++------ exe/Plugins.hs | 18 ++++----- ghcide/exe/Main.hs | 26 +++++++++---- ghcide/ghcide.cabal | 3 ++ .../session-loader/Development/IDE/Session.hs | 39 +------------------ ghcide/src/Development/IDE/Core/FileExists.hs | 8 ++-- ghcide/src/Development/IDE/Core/FileStore.hs | 12 ++---- ghcide/src/Development/IDE/Core/Log.hs | 2 + ghcide/src/Development/IDE/Core/OfInterest.hs | 5 ++- ghcide/src/Development/IDE/Core/Rules.hs | 20 ++++------ ghcide/src/Development/IDE/Core/Service.hs | 15 +++---- ghcide/src/Development/IDE/Core/Shake.hs | 27 ++----------- .../src/Development/IDE/LSP/LanguageServer.hs | 13 ++----- .../src/Development/IDE/LSP/Notifications.hs | 14 +++---- ghcide/src/Development/IDE/Main.hs | 32 ++++++--------- ghcide/src/Development/IDE/Main/HeapStats.hs | 10 +---- .../src/Development/IDE/Plugin/Completions.hs | 7 ++-- ghcide/src/Development/IDE/Plugin/HLS.hs | 3 +- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 8 ++-- .../src/Development/IDE/Plugin/TypeLenses.hs | 4 +- ghcide/src/Development/IDE/Types/Logger.hs | 16 +++++--- ghcide/test/exe/Main.hs | 29 +++++++++----- hls-test-utils/hls-test-utils.cabal | 1 + hls-test-utils/src/Test/Hls.hs | 35 ++++++++++++----- plugins/default/src/Ide/Plugin/Example.hs | 4 +- plugins/default/src/Ide/Plugin/Example2.hs | 4 +- .../src/Ide/Plugin/AlternateNumberFormat.hs | 4 +- .../hls-eval-plugin/src/Ide/Plugin/Eval.hs | 6 +-- .../src/Ide/Plugin/ExplicitImports.hs | 4 +- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 4 +- .../src/Ide/Plugin/RefineImports.hs | 4 +- .../src/Ide/Plugin/Tactic.hs | 2 +- .../hls-tactics-plugin/src/Wingman/Plugin.hs | 2 +- src/Ide/Main.hs | 6 +-- 34 files changed, 175 insertions(+), 231 deletions(-) create mode 100644 ghcide/src/Development/IDE/Core/Log.hs diff --git a/exe/Main.hs b/exe/Main.hs index 0247d3463b..62d92227b5 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -6,7 +6,6 @@ module Main(main) where import Data.Function ((&)) -import Data.Text (Text) import Development.IDE.Types.Logger (Priority (Debug, Info), WithPriority (WithPriority, priority), cfilter, cmap, @@ -18,9 +17,7 @@ import Ide.Arguments (Arguments (..), import Ide.Main (defaultMain) import qualified Ide.Main as IdeMain import qualified Plugins -import Prettyprinter (Pretty (pretty)) -import qualified Prettyprinter -import qualified Prettyprinter.Render.Text as Prettyprinter +import Prettyprinter (Doc, Pretty (pretty)) import qualified System.Log as HsLogger data Log @@ -38,17 +35,13 @@ logToPriority = \case LogIdeMain log -> IdeMain.logToPriority log LogPlugins log -> Plugins.logToPriority log -logToTextWithPriority :: Log -> WithPriority Text -logToTextWithPriority log = WithPriority priority text - where - priority = logToPriority log - text = log - & pretty - & Prettyprinter.layoutPretty Prettyprinter.defaultLayoutOptions - & Prettyprinter.renderStrict +logToDocWithPriority :: Log -> WithPriority (Doc a) +logToDocWithPriority log = WithPriority (logToPriority log) (pretty log) main :: IO () main = do + -- passing mempty for recorder to idePlugins means that any custom cli + -- command provided by a plugin will not have logging powers args <- getArguments "haskell-language-server" (Plugins.idePlugins mempty False) let (hsLoggerMinPriority, minPriority, logFilePath, includeExamplePlugins) = @@ -63,6 +56,6 @@ main = do let recorder = textWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority) - & cmap logToTextWithPriority + & cmap logToDocWithPriority defaultMain (cmap LogIdeMain recorder) args (Plugins.idePlugins (cmap LogPlugins recorder) includeExamplePlugins) diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 917ba395ef..5ddac8cb4e 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -124,26 +124,26 @@ data Log instance Pretty Log where pretty = \case - LogGhcIde ghcIdeLog -> pretty ghcIdeLog - LogExample exampleLog -> pretty exampleLog - LogExample2 example2Log -> pretty example2Log + LogGhcIde log -> pretty log + LogExample log -> pretty log + LogExample2 log -> pretty log #if tactic - LogTactic tacticLog -> pretty tacticLog + LogTactic log -> pretty log #endif #if eval - LogEval evalLog -> pretty evalLog + LogEval log -> pretty log #endif #if importLens - LogExplicitImports explicitImportsLog -> pretty explicitImportsLog + LogExplicitImports log -> pretty log #endif #if refineImports - LogRefineImports refineImportsLog -> pretty refineImportsLog + LogRefineImports log -> pretty log #endif #if hlint - LogHlint hlintLog -> pretty hlintLog + LogHlint log -> pretty log #endif #if alternateNumberFormat - LogAlternateNumberFormat alternateNumberFormatLog -> pretty alternateNumberFormatLog + LogAlternateNumberFormat log -> pretty log #endif logToPriority :: Log -> Logger.Priority diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index d73547a7b5..dc6e3ecfdb 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -10,8 +10,6 @@ import Arguments (Arguments (..), import Control.Monad.Extra (unless) import Data.Default (def) import Data.Function ((&)) -import Data.Text (Text) -import qualified Data.Text as Text import Data.Version (showVersion) import Development.GitRev (gitHash) import Development.IDE (Priority (Debug, Info), @@ -26,10 +24,12 @@ import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde import Development.IDE.Types.Logger (WithPriority (WithPriority, priority), cfilter, cmap, makeDefaultStderrRecorder) +import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options import Ide.Plugin.Config (Config (checkParents, checkProject)) import Ide.PluginUtils (pluginDescToIdePlugins) import Paths_ghcide (version) +import Prettyprinter (Doc, Pretty (pretty)) import qualified System.Directory.Extra as IO import System.Environment (getExecutablePath) import System.Exit (exitSuccess) @@ -42,6 +42,19 @@ data Log | LogRules Rules.Log deriving Show +instance Pretty Log where + pretty = \case + LogIDEMain log -> pretty log + LogRules log -> pretty log + +logToPriority :: Log -> Logger.Priority +logToPriority = \case + LogIDEMain log -> IDEMain.logToPriority log + LogRules log -> Rules.logToPriority log + +logToDocWithPriority :: Log -> WithPriority (Doc a) +logToDocWithPriority log = WithPriority (logToPriority log) (pretty log) + ghcideVersion :: IO String ghcideVersion = do path <- getExecutablePath @@ -53,9 +66,6 @@ ghcideVersion = do <> ") (PATH: " <> path <> ")" <> gitHashSection -logToTextWithPriority :: Log -> WithPriority Text -logToTextWithPriority = WithPriority Info . Text.pack . show - main :: IO () main = withTelemetryLogger $ \telemetryLogger -> do let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors mempty) @@ -73,11 +83,11 @@ main = withTelemetryLogger $ \telemetryLogger -> do let (hsLoggerMinPriority, minPriority) = if argsVerbose then (HsLogger.DEBUG, Debug) else (HsLogger.INFO, Info) - textWithPriorityStderrRecorder <- makeDefaultStderrRecorder hsLoggerMinPriority + defaultRecorder <- makeDefaultStderrRecorder hsLoggerMinPriority - let recorder = textWithPriorityStderrRecorder + let recorder = defaultRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority) - & cmap logToTextWithPriority + & cmap logToDocWithPriority let arguments = if argsTesting diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index ece6773a74..8ae771e1ec 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -146,6 +146,7 @@ library Generics.SYB.GHC Development.IDE Development.IDE.Main + Development.IDE.Core.Log Development.IDE.Core.Actions Development.IDE.Main.HeapStats Development.IDE.Core.Debouncer @@ -329,6 +330,7 @@ executable ghcide hls-graph, text, unordered-containers, + prettyprinter other-modules: Arguments Paths_ghcide @@ -392,6 +394,7 @@ test-suite ghcide-tests list-t, lsp-test ^>= 0.14, optparse-applicative, + prettyprinter, process, QuickCheck, quickcheck-instances, diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 76cabb800c..9c91c174d6 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -100,59 +100,22 @@ import System.Random (RandomGen) import qualified System.Random as Random data Log - = LogSettingInitialDynFlags -- seems like wrong location so I changed it - -- logDebug logger $ T.pack $ "setInitialDynFlags cradle: " ++ show cradle + = LogSettingInitialDynFlags | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void) - -- hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,rootDir,hieYaml,cradle) | LogGetInitialGhcLibDirDefaultCradleNone - -- hPutStrLn stderr "Couldn't load cradle (CradleNone)" | LogHieDbRetry !Int !Int !Int !SomeException - -- logWarning logger $ "Retrying - " <> makeLogMsgComponentsText (Right delay) newMaxRetryCount e | LogHieDbRetriesExhausted !Int !Int !Int !SomeException - -- logWarning logger $ "Retries exhausted - " <> makeLogMsgComponentsText (Left baseDelay) maxRetryCount e - -- -- e.g. delay: 1010102, maximumDelay: 12010, maxRetryCount: 9, exception: SQLError { ... } - -- makeLogMsgComponentsText delay newMaxRetryCount e = - -- let - -- logMsgComponents = - -- [ either - -- (("base delay: " <>) . T.pack . show) - -- (("delay: " <>) . T.pack . show) - -- delay - -- , "maximumDelay: " <> T.pack (show maxDelay) - -- , "maxRetryCount: " <> T.pack (show newMaxRetryCount) - -- , "exception: " <> T.pack (show e)] - -- in - -- T.intercalate ", " logMsgComponents | LogHieDbWriterThreadSQLiteError !SQLError - -- logDebug logger $ T.pack $ "SQLite error in worker, ignoring: " ++ show e | LogHieDbWriterThreadException !SomeException - -- logDebug logger $ T.pack $ "Uncaught error in database worker, ignoring: " ++ show e | LogInterfaceFilesCacheDir !FilePath - -- liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack (fromMaybe cacheDir hiCacheDir) | LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedFilePath)) - -- logDebug logger $ "Known files updated: " <> - -- T.pack(show $ (HM.map . Set.map) fromNormalizedFilePath x) | LogMakingNewHscEnv ![UnitId] - -- logInfo logger (T.pack ("Making new HscEnv" ++ show inplace)) | LogDLLLoadError !String - -- logDebug logger $ T.pack $ - -- "Error dynamically loading libm.so.6:\n" <> err | LogCradlePath !FilePath - -- logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp) | LogCradleNotFound !FilePath - -- logWarning logger $ implicitCradleWarning lfp - -- implicitCradleWarning :: FilePath -> T.Text - -- implicitCradleWarning fp = - -- "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for " - -- <> T.pack fp <> - -- ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n"<> - -- "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath)) - -- logDebug logger $ T.pack ("Session loading result: " <> show eopts) | forall a. Show a => LogCradle !(Cradle a) - -- logDebug logger $ T.pack $ "Output from setting up the cradle " <> show cradle | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) - -- logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res)) deriving instance Show Log instance Pretty Log where diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index a0302feddc..2635d46dc7 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -7,7 +7,7 @@ module Development.IDE.Core.FileExists , getFileExists , watchedGlobs , GetFileExists(..) - , Log + , Log(..) , logToPriority) where @@ -19,7 +19,7 @@ import Control.Monad.IO.Class import qualified Data.ByteString as BS import Data.List (partition) import Data.Maybe -import Development.IDE.Core.FileStore hiding (Log, +import Development.IDE.Core.FileStore hiding (Log, LogShake, logToPriority) import qualified Development.IDE.Core.FileStore as FileStore import Development.IDE.Core.IdeConfiguration @@ -97,8 +97,8 @@ data Log instance Pretty Log where pretty = \case - LogFileStore fileStoreLog -> pretty fileStoreLog - LogShake shakeLog -> pretty shakeLog + LogFileStore log -> pretty log + LogShake log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 2bf89f2b52..4bbcbc8d9e 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -22,7 +22,7 @@ module Development.IDE.Core.FileStore( getModTime, isWatchSupported, registerFileWatches, - Log + Log(..) , logToPriority) where import Control.Concurrent.STM.Stats (STM, atomically, @@ -91,13 +91,7 @@ import System.FilePath data Log = LogCouldNotIdentifyReverseDeps !NormalizedFilePath - -- log = L.logInfo logger . T.pack - -- liftIO $ log $ "Could not identify reverse dependencies for " ++ show nfp | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath]) - -- the catch around previous logging statement is weird - -- does forcing nfp, or revs trigger than exception? - -- liftIO $ (log $ "Typechecking reverse dependencies for " ++ show nfp ++ ": " ++ show revs) - -- `catch` \(e :: SomeException) -> log (show e) | LogShake Shake.Log deriving Show @@ -110,13 +104,13 @@ instance Pretty Log where <+> Prettyprinter.viaShow path <> ":" <+> pretty (fmap (fmap show) reverseDepPaths) - LogShake shakeLog -> pretty shakeLog + LogShake log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case LogCouldNotIdentifyReverseDeps{} -> Logger.Info LogTypeCheckingReverseDeps{} -> Logger.Info - LogShake shakeLog -> Shake.logToPriority shakeLog + LogShake log -> Shake.logToPriority log makeVFSHandle :: IO VFSHandle makeVFSHandle = do diff --git a/ghcide/src/Development/IDE/Core/Log.hs b/ghcide/src/Development/IDE/Core/Log.hs new file mode 100644 index 0000000000..b1be590eb0 --- /dev/null +++ b/ghcide/src/Development/IDE/Core/Log.hs @@ -0,0 +1,2 @@ +module Development.IDE.Core.Log where + diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 663d29676b..124b8b9fcc 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -16,7 +16,8 @@ module Development.IDE.Core.OfInterest( kick, FileOfInterestStatus(..), OfInterestVar(..), scheduleGarbageCollection, - Log, logToPriority) where + Log(..), + logToPriority) where import Control.Concurrent.Strict import Control.Monad @@ -51,7 +52,7 @@ data Log = LogShake Shake.Log instance Pretty Log where pretty = \case - LogShake shakeLog -> pretty shakeLog + LogShake log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index f50a888420..6e8e9320f1 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -57,8 +57,8 @@ module Development.IDE.Core.Rules( getParsedModuleDefinition, typeCheckRuleDefinition, GhcSessionDepsConfig(..), - Log - , logToPriority) where + Log(..), + logToPriority) where #if !MIN_VERSION_ghc(8,8,0) import Control.Applicative (liftA2) @@ -97,15 +97,15 @@ import qualified Data.Text.Encoding as T import Data.Time (UTCTime (..)) import Data.Tuple.Extra import Development.IDE.Core.Compile -import Development.IDE.Core.FileExists hiding (logToPriority, Log) +import Development.IDE.Core.FileExists hiding (LogShake, logToPriority, Log) import Development.IDE.Core.FileStore (getFileContents, modificationTime, resetInterfaceStore) import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.OfInterest hiding (logToPriority, Log) +import Development.IDE.Core.OfInterest hiding (LogShake, logToPriority, Log) import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service hiding (logToPriority, Log) +import Development.IDE.Core.Service hiding (LogShake, logToPriority, Log) import Development.IDE.Core.Shake hiding (logToPriority, Log) import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat.Core hiding @@ -162,21 +162,15 @@ import qualified Prettyprinter data Log = LogShake Shake.Log | LogReindexingHieFile !NormalizedFilePath - -- L.logDebug (logger se) $ "Re-indexing hie file for" <> T.pack (fromNormalizedFilePath f) | LogLoadingHieFile !NormalizedFilePath - -- log <- asks $ L.logDebug . logger - -- liftIO $ log $ "LOADING HIE FILE :" <> T.pack (show file) | LogLoadingHieFileFail !FilePath !SomeException | LogLoadingHieFileSuccess !FilePath - -- liftIO . log $ either (const $ "FAILED LOADING HIE FILE FOR:" <> T.pack (show hie_loc)) - -- (const $ "SUCCEEDED LOADING HIE FILE FOR:" <> T.pack (show hie_loc)) - -- res | LogExactPrint ExactPrint.Log deriving Show instance Pretty Log where pretty = \case - LogShake shakeLog -> pretty shakeLog + LogShake log -> pretty log LogReindexingHieFile path -> "Re-indexing hie file for" <+> pretty (fromNormalizedFilePath path) LogLoadingHieFile path -> @@ -188,7 +182,7 @@ instance Pretty Log where , pretty (displayException e) ] LogLoadingHieFileSuccess path -> "SUCCEEDED LOADING HIE FILE FOR" <+> pretty path - LogExactPrint exactPrintLog -> pretty exactPrintLog + LogExactPrint log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index 6ecc48b712..f98dd2b13b 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -15,13 +15,14 @@ module Development.IDE.Core.Service( getDiagnostics, ideLogger, updatePositionMapping, - Log - , logToPriority) where + Log(..), + logToPriority) where import Control.Applicative ((<|>)) import Development.IDE.Core.Debouncer import Development.IDE.Core.FileExists (fileExistsRules) -import Development.IDE.Core.OfInterest hiding (Log, logToPriority) +import Development.IDE.Core.OfInterest hiding (Log, LogShake, + logToPriority) import Development.IDE.Graph import Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options (IdeOptions (..)) @@ -46,10 +47,10 @@ data Log deriving Show instance Pretty Log where - pretty log = case log of - LogShake shakeLog -> pretty shakeLog - LogOfInterest ofInterestLog -> pretty ofInterestLog - LogFileExists fileExistsLog -> pretty fileExistsLog + pretty = \case + LogShake log -> pretty log + LogOfInterest log -> pretty log + LogFileExists log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 9557919645..556b629a65 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -77,8 +77,8 @@ module Development.IDE.Core.Shake( addPersistentRule, garbageCollectDirtyKeys, garbageCollectDirtyKeysOlderThan, - Log - , logToPriority) where + Log(..), + logToPriority) where import Control.Concurrent.Async import Control.Concurrent.STM @@ -173,38 +173,17 @@ import qualified StmContainers.Map as STM data Log = LogCreateHieDbExportsMapStart - -- logDebug logger "Initializing exports map from hiedb" | LogCreateHieDbExportsMapFinish !Int - -- logDebug logger $ "Done initializing exports map from hiedb (" <> pack(show (ExportsMap.size em)) <> ")" | LogBuildSessionRestart !String ![DelayedActionInternal] !(HashSet Key) !Seconds !(Maybe FilePath) - -- let profile = case res of - -- Just fp -> ", profile saved at " <> fp - -- _ -> "" - -- log $ LogBuildSessionRestart reason queue backlog stopTime res - -- -- TODO: should eventually replace with logging using a logger that sends lsp message - -- let msg = T.pack $ "Restarting build session " ++ reason' ++ queueMsg ++ keysMsg ++ abortMsg - -- reason' = "due to " ++ reason - -- queueMsg = " with queue " ++ show (map actionName queue) - -- keysMsg = " for keys " ++ show (HSet.toList backlog) ++ " " - -- abortMsg = "(aborting the previous one took " ++ showDuration stopTime ++ profile ++ ")" | LogDelayedAction !(DelayedAction ()) !Seconds - -- let msg = T.pack $ "finish: " ++ actionName d - -- ++ " (took " ++ showDuration runTime ++ ")" | LogBuildSessionFinish !(Maybe SomeException) - -- let res' = case res of - -- Left e -> "exception: " <> displayException e - -- Right _ -> "completed" - -- let msg = T.pack $ "Finishing build session(" ++ res' ++ ")" | LogDiagsDiffButNoLspEnv ![FileDiagnostic] - -- logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags | LogDefineEarlyCutoffRuleNoDiagDiags ![FileDiagnostic] - -- RuleNoDiagnostics mapM_ (\d -> liftIO $ logWarning logger $ showDiagnosticsColored [d]) diags | LogDefineEarlyCutoffRuleCustomNewnessDiags ![FileDiagnostic] - -- RuleWithCustomNewnessCheck mapM_ (\d -> liftIO $ logWarning logger $ showDiagnosticsColored [d]) diags deriving Show instance Pretty Log where - pretty log = case log of + pretty = \case LogCreateHieDbExportsMapStart -> "Initializing exports map from hiedb" LogCreateHieDbExportsMapFinish exportsMapSize -> diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 1a4eb53c86..36e72940aa 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -10,7 +10,7 @@ -- This version removes the daml: handling module Development.IDE.LSP.LanguageServer ( runLanguageServer - , Log + , Log(..) , logToPriority) where import Control.Concurrent.STM @@ -51,17 +51,10 @@ import System.IO.Unsafe (unsafeInterleaveIO) data Log = LogRegisteringIdeConfig !IdeConfiguration - -- logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig | LogReactorThreadException !SomeException - -- logError logger $ T.pack $ "Fatal error in server thread: " <> show e | LogReactorMessageActionException !SomeException - -- logError logger $ T.pack $ - -- "Unexpected exception, please report!\n" ++ - -- "Exception: " ++ show e | LogReactorThreadStopped - -- logInfo logger "Reactor thread stopped" | LogCancelledRequest !SomeLspId - -- logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id | LogSession Session.Log deriving Show @@ -79,9 +72,9 @@ instance Pretty Log where , pretty $ displayException e ] LogReactorThreadStopped -> "Reactor thread stopped" - (LogCancelledRequest requestId) -> + LogCancelledRequest requestId -> "Cancelled request" <+> Prettyprinter.viaShow requestId - (LogSession sessionLog) -> pretty sessionLog + LogSession log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 5d6bb6efde..a750c33cdc 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -9,7 +9,7 @@ module Development.IDE.LSP.Notifications ( whenUriFile , descriptor - , Log + , Log(..) , logToPriority) where import Language.LSP.Types @@ -29,10 +29,10 @@ import Development.IDE.Core.FileStore (registerFileWatches, setSomethingModified) import qualified Development.IDE.Core.FileStore as FileStore import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.OfInterest hiding (Log, +import Development.IDE.Core.OfInterest hiding (Log, LogShake, logToPriority) import Development.IDE.Core.RuleTypes (GetClientSettings (..)) -import Development.IDE.Core.Service hiding (Log, +import Development.IDE.Core.Service hiding (Log, LogShake, logToPriority) import Development.IDE.Core.Shake hiding (Log, Priority, logToPriority) @@ -50,13 +50,13 @@ data Log instance Pretty Log where pretty = \case - LogShake shakeLog -> pretty shakeLog - LogFileStore fileStoreLog -> pretty fileStoreLog + LogShake log -> pretty log + LogFileStore log -> pretty log logToPriority :: Log -> Priority logToPriority = \case - LogShake shakeLog -> Shake.logToPriority shakeLog - LogFileStore fileStoreLog -> FileStore.logToPriority fileStoreLog + LogShake log -> Shake.logToPriority log + LogFileStore log -> FileStore.logToPriority log whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 71d63b5534..50bde6634c 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -8,8 +8,9 @@ module Development.IDE.Main ,isLSP ,commandP ,defaultMain --- ,testing -,Log, testing, logToPriority) where +,testing +,Log(..) +,logToPriority) where import Control.Concurrent.Extra (newLock, withLock, withNumCapabilities) import Control.Concurrent.STM.Stats (atomically, @@ -68,7 +69,6 @@ import Development.IDE.Plugin (Plugin (pluginHandlers, import Development.IDE.Plugin.HLS (asGhcIdePlugin) import qualified Development.IDE.Plugin.HLS as PluginHLS import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde --- import qualified Development.IDE.Plugin.Test as Test import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Session (SessionLoadingOptions, getHieDbLoc, @@ -136,18 +136,10 @@ import Text.Printf (printf) data Log = LogHeapStats !HeapStats.Log | LogLspStart - -- logInfo logger "Starting LSP server..." - -- logInfo logger "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!" | LogLspStartDuration !Seconds - -- logInfo logger $ T.pack $ "Started LSP server in " ++ showDuration t | LogShouldRunSubset !Bool - -- logDebug logger $ T.pack $ "runSubset: " <> show runSubset | LogOnlyPartialGhc9Support - -- hPutStrLn stderr $ - -- "Currently, HLS supports GHC 9 only partially. " - -- <> "See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail." | LogSetInitialDynFlagsException !SomeException - -- (logDebug logger $ T.pack $ "setInitialDynFlags: " ++ displayException e) | LogService Service.Log | LogShake Shake.Log | LogGhcIde GhcIde.Log @@ -158,8 +150,8 @@ data Log deriving Show instance Pretty Log where - pretty log = case log of - LogHeapStats heapStatsLog -> pretty heapStatsLog + pretty = \case + LogHeapStats log -> pretty log LogLspStart -> Prettyprinter.vsep [ "Staring LSP server..." @@ -172,13 +164,13 @@ instance Pretty Log where "Currently, HLS supports GHC 9 only partially. See [issue #297](https://github.com/haskell/haskell-language-server/issues/297) for more detail." LogSetInitialDynFlagsException e -> "setInitialDynFlags:" <+> pretty (displayException e) - LogService serviceLog -> pretty serviceLog - LogShake shakeLog -> pretty shakeLog - LogGhcIde ghcIdeLog -> pretty ghcIdeLog - LogLanguageServer languageServerLog -> pretty languageServerLog - LogSession sessionLog -> pretty sessionLog - LogPluginHLS pluginHLSLog -> pretty pluginHLSLog - LogRules rulesLog -> pretty rulesLog + LogService log -> pretty log + LogShake log -> pretty log + LogGhcIde log -> pretty log + LogLanguageServer log -> pretty log + LogSession log -> pretty log + LogPluginHLS log -> pretty log + LogRules log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case diff --git a/ghcide/src/Development/IDE/Main/HeapStats.hs b/ghcide/src/Development/IDE/Main/HeapStats.hs index 5648978a4c..d3953435a4 100644 --- a/ghcide/src/Development/IDE/Main/HeapStats.hs +++ b/ghcide/src/Development/IDE/Main/HeapStats.hs @@ -1,6 +1,6 @@ {-# LANGUAGE NumericUnderscores #-} -- | Logging utilities for reporting heap statistics -module Development.IDE.Main.HeapStats ( withHeapStats, Log , logToPriority) where +module Development.IDE.Main.HeapStats ( withHeapStats, Log(..), logToPriority ) where import Control.Concurrent import Control.Concurrent.Async @@ -15,16 +15,8 @@ import Text.Printf (printf) data Log = LogHeapStatsPeriod !Int - -- logInfo l ("Logging heap statistics every " - -- <> T.pack (printf "%.2fs" (fromIntegral @Int @Double heapStatsInterval / 1e6))) | LogHeapStatsDisabled - -- logInfo l "Heap statistics are not enabled (RTS option -T is needed)" | LogHeapStats !Word64 !Word64 - -- format :: Word64 -> T.Text - -- format m = T.pack (printf "%.2fMB" (fromIntegral @Word64 @Double m / 1e6)) - -- message = "Live bytes: " <> format live_bytes <> " " <> - -- "Heap size: " <> format heap_size - -- logInfo l message deriving Show instance Pretty Log where diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index fdaa51785a..5bbf66c32f 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -3,7 +3,7 @@ module Development.IDE.Plugin.Completions ( descriptor - , Log + , Log(..) , logToPriority) where import Control.Concurrent.Async (concurrently) @@ -20,6 +20,7 @@ import qualified Data.Text as T import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service hiding (Log, + LogShake, logToPriority) import Development.IDE.Core.Shake hiding (Log, logToPriority) @@ -56,11 +57,11 @@ data Log = LogShake Shake.Log deriving Show instance Pretty Log where pretty = \case - LogShake shakeLog -> pretty shakeLog + LogShake log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case - LogShake shakeLog -> Shake.logToPriority shakeLog + LogShake log -> Shake.logToPriority log descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 01765fe9d3..76e8e906d1 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -6,7 +6,7 @@ module Development.IDE.Plugin.HLS ( asGhcIdePlugin - , Log + , Log(..) , logToPriority) where import Control.Exception (SomeException) @@ -47,7 +47,6 @@ import UnliftIO.Exception (catchAny) data Log = LogNoEnabledPlugins - -- liftIO $ logInfo (ideLogger ide) "extensibleNotificationPlugins no enabled plugins" deriving Show instance Pretty Log where diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index 643e429ae9..e9b668cd8b 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -5,7 +5,7 @@ module Development.IDE.Plugin.HLS.GhcIde ( descriptors - , Log + , Log(..) , logToPriority) where import Control.Monad.IO.Class import Development.IDE @@ -30,9 +30,9 @@ data Log instance Pretty Log where pretty = \case - LogNotifications notificationsLog -> pretty notificationsLog - LogCompletions completionsLog -> pretty completionsLog - LogTypeLenses typeLensesLog -> pretty typeLensesLog + LogNotifications log -> pretty log + LogCompletions log -> pretty log + LogTypeLenses log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 09f258bb0f..e23af70522 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -10,7 +10,7 @@ module Development.IDE.Plugin.TypeLenses ( GlobalBindingTypeSig (..), GetGlobalBindingTypeSigs (..), GlobalBindingTypeSigsResult (..), - Log + Log(..) , logToPriority) where import Control.Concurrent.STM.Stats (atomically) @@ -77,7 +77,7 @@ data Log = LogShake Shake.Log deriving Show instance Pretty Log where pretty = \case - LogShake shakeLog -> pretty shakeLog + LogShake log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index 62304bed6b..b5ad64c141 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -29,6 +29,10 @@ import Data.Time (defaultTimeLocale, formatTime, import GHC.Stack (HasCallStack, SrcLoc (SrcLoc, srcLocModule, srcLocStartLine), getCallStack, withFrozenCallStack) +import Prettyprinter (Doc, Pretty (pretty), + defaultLayoutOptions, layoutPretty, + (<+>)) +import Prettyprinter.Render.Text (renderStrict) import System.IO (Handle, IOMode (AppendMode), hClose, hFlush, hSetEncoding, openFile, stderr, utf8) @@ -125,7 +129,7 @@ textHandleRecorder handle = Recorder { logger_ = \text -> liftIO $ Text.hPutStrLn handle text *> hFlush handle } -makeDefaultStderrRecorder :: MonadIO m => HsLogger.Priority -> m (Recorder (WithPriority Text)) +makeDefaultStderrRecorder :: MonadIO m => HsLogger.Priority -> m (Recorder (WithPriority (Doc a))) makeDefaultStderrRecorder hsLoggerMinPriority = do lock <- liftIO newLock makeDefaultHandleRecorder hsLoggerMinPriority lock stderr @@ -137,7 +141,7 @@ withDefaultRecorder :: MonadUnliftIO m => Maybe FilePath -> HsLogger.Priority - -> (Recorder (WithPriority Text) -> m a) + -> (Recorder (WithPriority (Doc d)) -> m a) -> m a withDefaultRecorder path hsLoggerMinPriority action = do lock <- liftIO newLock @@ -148,17 +152,19 @@ withDefaultRecorder path hsLoggerMinPriority action = do handle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode) case handle of Left _ -> makeHandleRecorder stderr >>= \recorder -> - logWith recorder (WithPriority Error $ "Couldn't open log file " <> Text.pack path <> "; falling back to stderr.") + logWith recorder (WithPriority Error $ "Couldn't open log file" <+> pretty path <> "; falling back to stderr.") >> action recorder Right handle -> finally (makeHandleRecorder handle >>= action) (liftIO $ hClose handle) -makeDefaultHandleRecorder :: MonadIO m => HsLogger.Priority -> Lock -> Handle -> m (Recorder (WithPriority Text)) +makeDefaultHandleRecorder :: MonadIO m => HsLogger.Priority -> Lock -> Handle -> m (Recorder (WithPriority (Doc a))) makeDefaultHandleRecorder hsLoggerMinPriority lock handle = do let Recorder{ logger_ } = textHandleRecorder handle let threadSafeRecorder = Recorder { logger_ = \msg -> liftIO $ withLock lock (logger_ msg) } let textWithPriorityRecorder = cmapIO textWithPriorityToText threadSafeRecorder liftIO $ setupHsLogger lock handle ["hls", "hie-bios"] hsLoggerMinPriority - pure textWithPriorityRecorder + pure (cmap docToText textWithPriorityRecorder) + where + docToText = fmap (renderStrict . layoutPretty defaultLayoutOptions) -- taken from LSP.setupLogger -- used until contravariant logging system is fully in place diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 38981ab66c..ee5a6a94f6 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -115,17 +115,29 @@ import Test.Tasty.QuickCheck import Text.Printf (printf) import Text.Regex.TDFA ((=~)) import qualified HieDbRetry -import Development.IDE.Types.Logger (WithPriority(WithPriority), Priority (Info), cmap, Recorder, makeDefaultStderrRecorder) +import Development.IDE.Types.Logger (WithPriority(WithPriority, priority), Priority (Debug), cmap, Recorder, makeDefaultStderrRecorder, cfilter) import Data.Function ((&)) -import qualified Data.Text as Text -import Data.Text (Text) import qualified System.Log as HsLogger +import Prettyprinter (Doc, Pretty (pretty)) data Log = LogGhcIde Ghcide.Log | LogIDEMain IDE.Log deriving Show +instance Pretty Log where + pretty = \case + LogGhcIde log -> pretty log + LogIDEMain log -> pretty log + +logToPriority :: Log -> Priority +logToPriority = \case + LogGhcIde log -> Ghcide.logToPriority log + LogIDEMain log -> IDE.logToPriority log + +logToDocWithPriority :: Log -> WithPriority (Doc a) +logToDocWithPriority log = WithPriority (logToPriority log) (pretty log) + -- | Wait for the next progress begin step waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case @@ -152,16 +164,13 @@ waitForAllProgressDone = loop done <- null <$> getIncompleteProgressSessions unless done loop --- TODO: change so all messages aren't Info -logToTextWithPriority :: Log -> WithPriority Text -logToTextWithPriority = WithPriority Info . Text.pack . show - main :: IO () main = do - textWithPriorityStderrRecorder <- makeDefaultStderrRecorder HsLogger.DEBUG + defaultRecorder <- makeDefaultStderrRecorder HsLogger.DEBUG - let recorder = textWithPriorityStderrRecorder - & cmap logToTextWithPriority + let recorder = defaultRecorder + & cfilter (\WithPriority{ priority } -> priority >= Debug) + & cmap logToDocWithPriority -- We mess with env vars so run single-threaded. defaultMainWithRerun $ testGroup "ghcide" diff --git a/hls-test-utils/hls-test-utils.cabal b/hls-test-utils/hls-test-utils.cabal index c35baa8f4d..9203ac62f2 100644 --- a/hls-test-utils/hls-test-utils.cabal +++ b/hls-test-utils/hls-test-utils.cabal @@ -51,6 +51,7 @@ library , lsp ^>=1.4 , lsp-test ^>=0.14 , lsp-types ^>=1.4 + , prettyprinter , tasty , tasty-expected-failure , tasty-golden diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index ef0cca628c..0eec5d58f7 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -47,22 +47,20 @@ import qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) import Data.Default (def) import Data.Maybe (fromMaybe) -import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text as Text import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Development.IDE (IdeState, noLogging) import Development.IDE.Graph (ShakeOptions (shakeThreads)) -import Development.IDE.Main hiding (Log) -import qualified Development.IDE.Main as Ghcide hiding (Log) +import Development.IDE.Main hiding (Log, logToPriority) +import qualified Development.IDE.Main as Ghcide import qualified Development.IDE.Main as IDEMain import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), WaitForIdeRuleResult (ideResultSuccess)) import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Types.Logger (Priority (Debug), - WithPriority (WithPriority), - cmap, + WithPriority (WithPriority, priority), + cfilter, cmap, makeDefaultStderrRecorder) import Development.IDE.Types.Options import GHC.IO.Handle @@ -76,6 +74,8 @@ import Language.LSP.Types hiding SemanticTokenRelative (length), SemanticTokensEdit (_start)) import Language.LSP.Types.Capabilities (ClientCapabilities) +import Prelude hiding (log) +import Prettyprinter (Doc, Pretty (pretty)) import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.Environment (lookupEnv) @@ -93,6 +93,17 @@ import Test.Tasty.Ingredients.Rerun newtype Log = LogIDEMain IDEMain.Log deriving Show +instance Pretty Log where + pretty = \case + LogIDEMain log -> pretty log + +logToPriority :: Log -> Priority +logToPriority = \case + LogIDEMain log -> IDEMain.logToPriority log + +logToDocWithPriority :: Log -> WithPriority (Doc a) +logToDocWithPriority log = WithPriority (logToPriority log) (pretty log) + -- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes defaultTestRunner :: TestTree -> IO () defaultTestRunner = defaultMainWithRerun . adjustOption (const $ mkTimeout 600000000) @@ -162,8 +173,6 @@ keepCurrentDirectory = bracket getCurrentDirectory setCurrentDirectory . const lock :: Lock lock = unsafePerformIO newLock -logToTextWithPriority :: Log -> WithPriority Text -logToTextWithPriority = WithPriority Debug . Text.pack . show -- | Host a server, and run a test session on it -- Note: cwd will be shifted into @root@ in @Session a@ @@ -182,12 +191,18 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre (inR, inW) <- createPipe (outR, outW) <- createPipe - textWithPriorityRecorder <- makeDefaultStderrRecorder HsLogger.DEBUG + -- this recorder may be different than the recorder in the passed in plugin + -- if you want to modify ghcide specific logging during tests then this one + -- should be modified + -- otherwise modify the recorder passed to the plugin descriptor + defaultRecorder <- makeDefaultStderrRecorder HsLogger.DEBUG logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR" let - recorder = if logStdErr == "0" then mempty else cmap logToTextWithPriority textWithPriorityRecorder + recorder = if logStdErr == "0" + then mempty + else (cmap logToDocWithPriority . cfilter (\WithPriority{ priority } -> priority >= Debug)) defaultRecorder arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments mempty Debug hlsPlugins = idePluginsToPluginDesc argsHlsPlugins diff --git a/plugins/default/src/Ide/Plugin/Example.hs b/plugins/default/src/Ide/Plugin/Example.hs index 867823f9ec..6015a76c15 100644 --- a/plugins/default/src/Ide/Plugin/Example.hs +++ b/plugins/default/src/Ide/Plugin/Example.hs @@ -13,7 +13,7 @@ module Ide.Plugin.Example ( descriptor - , Log + , Log(..) , logToPriority) where import Control.Concurrent.STM @@ -47,7 +47,7 @@ newtype Log = LogShake Shake.Log deriving Show instance Pretty Log where pretty = \case - LogShake shakeLog -> pretty shakeLog + LogShake log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case diff --git a/plugins/default/src/Ide/Plugin/Example2.hs b/plugins/default/src/Ide/Plugin/Example2.hs index a8564fc682..647dfb45a6 100644 --- a/plugins/default/src/Ide/Plugin/Example2.hs +++ b/plugins/default/src/Ide/Plugin/Example2.hs @@ -13,7 +13,7 @@ module Ide.Plugin.Example2 ( descriptor - , Log + , Log(..) , logToPriority) where import Control.Concurrent.STM @@ -44,7 +44,7 @@ newtype Log = LogShake Shake.Log deriving Show instance Pretty Log where pretty = \case - LogShake shakeLog -> pretty shakeLog + LogShake log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs index f5c755915c..e774f58eb6 100644 --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Ide.Plugin.AlternateNumberFormat (descriptor, Log, logToPriority) where +module Ide.Plugin.AlternateNumberFormat (descriptor, Log(..), logToPriority) where import Control.Lens ((^.)) import Control.Monad.Except (ExceptT, MonadIO, liftIO) @@ -35,7 +35,7 @@ newtype Log = LogShake Shake.Log deriving Show instance Pretty Log where pretty = \case - LogShake shakeLog -> pretty shakeLog + LogShake log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs index b85e87be40..b23a09238c 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs @@ -8,8 +8,8 @@ Eval Plugin entry point. -} module Ide.Plugin.Eval ( descriptor, - Log -, logToPriority) where + Log(..), + logToPriority) where import Development.IDE (IdeState) import Development.IDE.Types.Logger (Recorder, cmap) @@ -27,7 +27,7 @@ newtype Log = LogEvalRules EvalRules.Log deriving Show instance Pretty Log where pretty = \case - LogEvalRules evalRulesLog -> pretty evalRulesLog + LogEvalRules log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index db234b666a..4abd55452c 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -14,7 +14,7 @@ module Ide.Plugin.ExplicitImports , descriptorForModules , extractMinimalImports , within - , Log + , Log(..) , logToPriority ) where @@ -52,7 +52,7 @@ newtype Log instance Pretty Log where pretty = \case - LogShake shakeLog -> pretty shakeLog + LogShake log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 4771083d86..ac55801e91 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -27,7 +27,7 @@ module Ide.Plugin.Hlint ( descriptor - , Log + , Log(..) , logToPriority) where import Control.Arrow ((&&&)) import Control.Concurrent.STM @@ -133,7 +133,7 @@ newtype Log instance Pretty Log where pretty = \case - LogShake shakeLog -> pretty shakeLog + LogShake log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case diff --git a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs index d638bbb823..16f8b164c5 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -8,7 +8,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -module Ide.Plugin.RefineImports (descriptor, Log, logToPriority) where +module Ide.Plugin.RefineImports (descriptor, Log(..), logToPriority) where import Control.Arrow (Arrow (second)) import Control.DeepSeq (rwhnf) @@ -54,7 +54,7 @@ newtype Log = LogShake Shake.Log deriving Show instance Pretty Log where pretty = \case - LogShake shakeLog -> pretty shakeLog + LogShake log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs index a2d45b99bc..dcc6d30b15 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs @@ -1,5 +1,5 @@ -- | A plugin that uses tactics to synthesize code -module Ide.Plugin.Tactic (descriptor, Log, logToPriority) where +module Ide.Plugin.Tactic (descriptor, Log(..), logToPriority) where import Wingman.Plugin diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index 4e7fe8e587..63ba9fec02 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -23,7 +23,7 @@ newtype Log instance Pretty Log where pretty = \case - LogWingmanLanguageServer wingmanLanguageServerLog -> pretty wingmanLanguageServerLog + LogWingmanLanguageServer log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 04e10fd0bd..a4053ab3a9 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -8,7 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -module Ide.Main(defaultMain, runLspMode, Log, logToPriority) where +module Ide.Main(defaultMain, runLspMode, Log(..), logToPriority) where import Control.Monad.Extra import qualified Data.Aeson.Encode.Pretty as A @@ -40,10 +40,6 @@ data Log = LogVersion !String | LogDirectory !FilePath | LogLspStart !GhcideArguments ![PluginId] - -- hPutStrLn stderr "Starting (haskell-language-server)LSP server..." - -- hPutStrLn stderr $ " with arguments: " <> show ghcideArgs - -- hPutStrLn stderr $ " with plugins: " <> show (map fst $ ipMap idePlugins) - -- hPutStrLn stderr $ " in directory: " <> dir | LogIDEMain IDEMain.Log deriving Show From 14a126c8a1f2e4dfafa9e6c3f139c0984e15d315 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Tue, 11 Jan 2022 18:15:38 -0500 Subject: [PATCH 23/43] remove accidentally added useless file, removed prettyprinter dep from hls-plugin-api because stack ghc8.6.5 doesnt have it? --- ghcide/ghcide.cabal | 1 - ghcide/src/Development/IDE/Core/Log.hs | 2 -- ghcide/src/Development/IDE/Types/Logger.hs | 24 +++++++++++----------- hls-plugin-api/hls-plugin-api.cabal | 1 - hls-plugin-api/src/Ide/Types.hs | 2 -- src/Ide/Main.hs | 5 ++++- 6 files changed, 16 insertions(+), 19 deletions(-) delete mode 100644 ghcide/src/Development/IDE/Core/Log.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 8ae771e1ec..8424ba7bd9 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -146,7 +146,6 @@ library Generics.SYB.GHC Development.IDE Development.IDE.Main - Development.IDE.Core.Log Development.IDE.Core.Actions Development.IDE.Main.HeapStats Development.IDE.Core.Debouncer diff --git a/ghcide/src/Development/IDE/Core/Log.hs b/ghcide/src/Development/IDE/Core/Log.hs deleted file mode 100644 index b1be590eb0..0000000000 --- a/ghcide/src/Development/IDE/Core/Log.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Development.IDE.Core.Log where - diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index b5ad64c141..5715dca94c 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -194,7 +194,7 @@ setupHsLogger lock handle extraLogNames level = do textWithPriorityToText :: WithPriority Text -> IO Text textWithPriorityToText = \case WithPriority{ priority, payload } -> do - threadId <- myThreadId + -- threadId <- myThreadId utcTime <- getCurrentTime pure $ Text.intercalate " | " [ utcTimeToText utcTime @@ -205,19 +205,19 @@ textWithPriorityToText = \case where utcTimeToText utcTime = Text.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime - threadIdToText :: Int -> Text - threadIdToText = Text.pack . show + -- threadIdToText :: Int -> Text + -- threadIdToText = Text.pack . show - callStackToLocationText callStack = srcLocText - where - srcLocText = - case getCallStack callStack of - [] -> "unknown" - [(_name, srcLoc)] -> srcLocToText srcLoc - (_, srcLoc) : (_callerName, _) : _ -> srcLocToText srcLoc + -- callStackToLocationText callStack = srcLocText + -- where + -- srcLocText = + -- case getCallStack callStack of + -- [] -> "unknown" + -- [(_name, srcLoc)] -> srcLocToText srcLoc + -- (_, srcLoc) : (_callerName, _) : _ -> srcLocToText srcLoc - srcLocToText SrcLoc{srcLocModule, srcLocStartLine} = - Text.pack srcLocModule <> ":" <> Text.pack (show srcLocStartLine) + -- srcLocToText SrcLoc{srcLocModule, srcLocStartLine} = + -- Text.pack srcLocModule <> ":" <> Text.pack (show srcLocStartLine) priorityToText :: Priority -> Text priorityToText = Text.pack . show diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 3841353323..12c66bc3cd 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -57,7 +57,6 @@ library , text , transformers , unordered-containers - , prettyprinter if os(windows) build-depends: Win32 diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index ca9a2a12cb..15d27855e2 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -69,7 +69,6 @@ import Language.LSP.Types.Lens as J (HasChildren (children), import Language.LSP.VFS import OpenTelemetry.Eventlog import Options.Applicative (ParserInfo) -import Prettyprinter (Pretty) import System.IO.Unsafe import Text.Regex.TDFA.Text () @@ -397,7 +396,6 @@ type CommandFunction ideState a newtype PluginId = PluginId T.Text deriving (Show, Read, Eq, Ord) - deriving newtype Pretty instance IsString PluginId where fromString = PluginId . T.pack diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index a4053ab3a9..b95481136e 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Ide.Main(defaultMain, runLspMode, Log(..), logToPriority) where @@ -13,8 +14,10 @@ module Ide.Main(defaultMain, runLspMode, Log(..), logToPriority) where import Control.Monad.Extra import qualified Data.Aeson.Encode.Pretty as A import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Coerce (coerce) import Data.Default import Data.List (sort) +import Data.Text (Text) import qualified Data.Text as T import Development.IDE.Core.Rules hiding (Log, logToPriority) import Development.IDE.Core.Tracing (withTelemetryLogger) @@ -52,7 +55,7 @@ instance Pretty Log where Prettyprinter.vsep [ "Starting (haskell-language-server) LSP server..." , Prettyprinter.viaShow ghcideArgs - , "PluginIds:" <+> pretty pluginIds ] + , "PluginIds:" <+> pretty (coerce @_ @[Text] pluginIds) ] LogIDEMain iDEMainLog -> pretty iDEMainLog logToPriority :: Log -> Logger.Priority From e7f832081e89286fc26503b8c59c3aa92ac1be52 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Tue, 11 Jan 2022 19:13:39 -0500 Subject: [PATCH 24/43] use deprecated prettyprint modules import for the sake of circleci ghc-8.6.5 --- ghcide/src/Development/IDE/Types/Logger.hs | 58 ++++++++++++---------- 1 file changed, 31 insertions(+), 27 deletions(-) diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index 5715dca94c..1c5a4b70b1 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -14,33 +14,37 @@ module Development.IDE.Types.Logger , WithPriority(..) , logWith, cmap, cmapIO, cfilter, withDefaultRecorder, makeDefaultStderrRecorder) where -import Control.Concurrent (myThreadId) -import Control.Concurrent.Extra (Lock, newLock, withLock) -import Control.Exception (IOException, try) -import Control.Monad (forM_, when, (>=>)) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Functor.Contravariant (Contravariant (contramap)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Data.Time (defaultTimeLocale, formatTime, - getCurrentTime) -import GHC.Stack (HasCallStack, - SrcLoc (SrcLoc, srcLocModule, srcLocStartLine), - getCallStack, withFrozenCallStack) -import Prettyprinter (Doc, Pretty (pretty), - defaultLayoutOptions, layoutPretty, - (<+>)) -import Prettyprinter.Render.Text (renderStrict) -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 -import UnliftIO (MonadUnliftIO, finally) +import Control.Concurrent (myThreadId) +import Control.Concurrent.Extra (Lock, newLock, withLock) +import Control.Exception (IOException, try) +import Control.Monad (forM_, when, (>=>)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Functor.Contravariant (Contravariant (contramap)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Text.Prettyprint.Doc (Doc, Pretty (pretty), + defaultLayoutOptions, + layoutPretty, (<+>)) +import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) +import Data.Time (defaultTimeLocale, + formatTime, + getCurrentTime) +import GHC.Stack (HasCallStack, + SrcLoc (SrcLoc, srcLocModule, srcLocStartLine), + getCallStack, + withFrozenCallStack) +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 +import UnliftIO (MonadUnliftIO, finally) data Priority -- Don't change the ordering of this type or you will mess up the Ord From 23c2ad91a52d2deca2a53784fec5dcc1061279e7 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Tue, 1 Feb 2022 02:18:13 -0500 Subject: [PATCH 25/43] use dummy stderr logger for plugin cli commands, use priorityToHsLoggerPriority function instead of manual mapping --- exe/Main.hs | 23 ++++++++-------- ghcide/src/Development/IDE/Types/Logger.hs | 32 ++++++++-------------- 2 files changed, 24 insertions(+), 31 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index 62d92227b5..f7c35cf8aa 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -9,8 +9,9 @@ import Data.Function ((&)) import Development.IDE.Types.Logger (Priority (Debug, Info), WithPriority (WithPriority, priority), cfilter, cmap, + makeDefaultStderrRecorder, + priorityToHsLoggerPriority, withDefaultRecorder) -import qualified Development.IDE.Types.Logger as Logger import Ide.Arguments (Arguments (..), GhcideArguments (..), getArguments) @@ -18,7 +19,6 @@ import Ide.Main (defaultMain) import qualified Ide.Main as IdeMain import qualified Plugins import Prettyprinter (Doc, Pretty (pretty)) -import qualified System.Log as HsLogger data Log = LogIdeMain IdeMain.Log @@ -30,7 +30,7 @@ instance Pretty Log where LogIdeMain ideMainLog -> pretty ideMainLog LogPlugins pluginsLog -> pretty pluginsLog -logToPriority :: Log -> Logger.Priority +logToPriority :: Log -> Priority logToPriority = \case LogIdeMain log -> IdeMain.logToPriority log LogPlugins log -> Plugins.logToPriority log @@ -40,17 +40,18 @@ logToDocWithPriority log = WithPriority (logToPriority log) (pretty log) main :: IO () main = do - -- passing mempty for recorder to idePlugins means that any custom cli - -- command provided by a plugin will not have logging powers - args <- getArguments "haskell-language-server" (Plugins.idePlugins mempty False) + -- plugin cli commands use stderr logger for now unless we change the args + -- parser to get logging arguments first or do more complicated things + stderrRecorder <- cmap logToDocWithPriority <$> makeDefaultStderrRecorder (priorityToHsLoggerPriority Info) + args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmap LogPlugins stderrRecorder) False) - let (hsLoggerMinPriority, minPriority, logFilePath, includeExamplePlugins) = + let (minPriority, logFilePath, includeExamplePlugins) = case args of Ghcide GhcideArguments{ argsTesting, argsDebugOn, argsLogFile, argsExamplePlugin } -> - let (minHsLoggerPriority, minPriority) = - if argsDebugOn || argsTesting then (HsLogger.DEBUG, Debug) else (HsLogger.INFO, Info) - in (minHsLoggerPriority, minPriority, argsLogFile, argsExamplePlugin) - _ -> (HsLogger.INFO, Info, Nothing, False) + let minPriority = if argsDebugOn || argsTesting then Debug else Info + in (minPriority, argsLogFile, argsExamplePlugin) + _ -> (Info, Nothing, False) + let hsLoggerMinPriority = priorityToHsLoggerPriority minPriority withDefaultRecorder logFilePath hsLoggerMinPriority $ \textWithPriorityRecorder -> do let recorder = diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index 1c5a4b70b1..16c4fc2172 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -12,11 +12,11 @@ module Development.IDE.Types.Logger , logError, logWarning, logInfo, logDebug, logTelemetry , noLogging , WithPriority(..) - , logWith, cmap, cmapIO, cfilter, withDefaultRecorder, makeDefaultStderrRecorder) where + , logWith, cmap, cmapIO, cfilter, withDefaultRecorder, makeDefaultStderrRecorder, priorityToHsLoggerPriority) where import Control.Concurrent (myThreadId) import Control.Concurrent.Extra (Lock, newLock, withLock) -import Control.Exception (IOException, try) +import Control.Exception (IOException) import Control.Monad (forM_, when, (>=>)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Functor.Contravariant (Contravariant (contramap)) @@ -44,7 +44,8 @@ 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 -import UnliftIO (MonadUnliftIO, finally) +import UnliftIO (MonadUnliftIO, finally, + try) data Priority -- Don't change the ordering of this type or you will mess up the Ord @@ -170,6 +171,14 @@ makeDefaultHandleRecorder hsLoggerMinPriority lock handle = do where docToText = fmap (renderStrict . layoutPretty defaultLayoutOptions) +priorityToHsLoggerPriority :: Priority -> HsLogger.Priority +priorityToHsLoggerPriority = \case + Telemetry -> HsLogger.INFO + Debug -> HsLogger.DEBUG + Info -> HsLogger.INFO + Warning -> HsLogger.WARNING + Error -> HsLogger.ERROR + -- taken from LSP.setupLogger -- used until contravariant logging system is fully in place setupHsLogger :: Lock -> Handle -> [String] -> HsLogger.Priority -> IO () @@ -198,31 +207,14 @@ setupHsLogger lock handle extraLogNames level = do textWithPriorityToText :: WithPriority Text -> IO Text textWithPriorityToText = \case WithPriority{ priority, payload } -> do - -- threadId <- myThreadId utcTime <- getCurrentTime pure $ Text.intercalate " | " [ utcTimeToText utcTime - -- , callStackToLocationText callStack - -- , threadIdToText threadId , priorityToText priority , payload ] where utcTimeToText utcTime = Text.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime - -- threadIdToText :: Int -> Text - -- threadIdToText = Text.pack . show - - -- callStackToLocationText callStack = srcLocText - -- where - -- srcLocText = - -- case getCallStack callStack of - -- [] -> "unknown" - -- [(_name, srcLoc)] -> srcLocToText srcLoc - -- (_, srcLoc) : (_callerName, _) : _ -> srcLocToText srcLoc - - -- srcLocToText SrcLoc{srcLocModule, srcLocStartLine} = - -- Text.pack srcLocModule <> ":" <> Text.pack (show srcLocStartLine) - priorityToText :: Priority -> Text priorityToText = Text.pack . show From 72b441ee20514c100fa08f116c98410dcd04f4ad Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Tue, 1 Feb 2022 02:32:44 -0500 Subject: [PATCH 26/43] remove old plugin detritus that somehow got committed --- .../src/Ide/Plugin/AliasImport.hs | 234 ------------------ 1 file changed, 234 deletions(-) delete mode 100644 plugins/hls-alias-import-plugin/src/Ide/Plugin/AliasImport.hs diff --git a/plugins/hls-alias-import-plugin/src/Ide/Plugin/AliasImport.hs b/plugins/hls-alias-import-plugin/src/Ide/Plugin/AliasImport.hs deleted file mode 100644 index beced9a7a9..0000000000 --- a/plugins/hls-alias-import-plugin/src/Ide/Plugin/AliasImport.hs +++ /dev/null @@ -1,234 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} --- {-# LANGUAGE ExplicitNamespaces #-} - -module Ide.Plugin.AliasImport (descriptor) where - -import Control.DeepSeq (rwhnf) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Aeson (FromJSON, ToJSON) -import Data.Aeson.Types (Value (Null)) -import Data.Either (isRight) -import Data.Foldable (find) -import Data.Function ((&)) -import qualified Data.HashMap.Internal.Strict as HashMap -import Data.IORef (readIORef) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Text (Text) -import qualified Data.Text as Text -import Debug.Trace (trace) -import Development.IDE (realSrcSpanToRange) -import Development.IDE.Core.RuleTypes (GetHieAst (GetHieAst), - GetParsedModule (GetParsedModule), - HieAstResult (HAR, refMap)) -import Development.IDE.Core.Rules (GetParsedModule (GetParsedModule), - IdeState, runAction) -import Development.IDE.Core.Service (IdeState, runAction) -import Development.IDE.Core.Shake (IdeState, use) -import Development.IDE.GHC.Compat (ContextInfo (Use), - Identifier, - IdentifierDetails (identInfo), - OccName (occNameFS), Span, - generateReferencesMap) -import Development.IDE.GHC.Compat.Core (GenLocated (L), GhcPs, - GhcRn, - ImportDecl (ImportDecl, ideclAs, ideclHiding, ideclName, ideclQualified), - ImportDeclQualifiedStyle (NotQualified), - LImportDecl, - Module (Module), - ParsedModule (ParsedModule, pm_parsed_source), - ParsedSource, SrcSpan, - TcGblEnv (tcg_used_gres), - findImportUsage, getLoc, - getMinimalImports, - hsmodImports, ieNames, - initTcWithGbl, - moduleNameString, - nameModule_maybe, - nameOccName, - pattern RealSrcSpan, - rdrNameOcc, - realSrcSpanStart, unLoc) -import Development.IDE.GHC.Compat.Util (unpackFS) -import Development.IDE.GHC.Error (isInsideSrcSpan) -import Development.IDE.Graph.Classes (Hashable, NFData (rnf)) -import Development.IDE.Types.Diagnostics (List (List)) -import Development.IDE.Types.Location (Range (Range)) -import GHC.Generics (Generic) -import Ide.Types (CommandFunction, CommandId, - PluginCommand (PluginCommand), - PluginDescriptor (pluginCommands, pluginHandlers, pluginRules), - PluginId, - PluginMethodHandler, - defaultPluginDescriptor, - mkPluginHandler) -import Language.LSP.Server (sendRequest) -import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), - CodeAction (..), - CodeActionKind (..), - CodeActionParams (..), - Method (TextDocumentCodeAction), - SMethod (STextDocumentCodeAction, SWorkspaceApplyEdit), - TextDocumentIdentifier (..), - TextEdit (TextEdit), - WorkspaceEdit (..), - toNormalizedUri, - type (|?) (..), - uriToNormalizedFilePath) - - - --- Goal: --- A code action located on an import that allows you to qualify every unqualified name used --- in the code, imported from the module. --- More specifically: --- --- Unqualified | Explicit List | Hiding | ? --- True | True | True | qualify unqualified names not on the explicit list with final module name --- True | True | False | qualify unqualified names on the explicit list with final module name --- True | False | True | syntax error --- True | False | False | qualify all unqualified names imported from module with final module name --- False | True | True | rename qualified names not in explicit list --- False | True | False | rename qualified names in explicit list --- False | False | True | syntax error --- False | False | False | rename all qualified names --- --- get final module name --- get all names in source from a certain module, (part of a certain set - prob not necessary) --- find if its qualified and rename the qualification or qualify it if not qualified --- --- Algorithm: --- 0. We are given the range where the code action is initialized which must be --- an import declaration. --- 1. Get the parsed source. --- 2. Get the import of the code action range. --- 3. Find the module associated with the import. --- 4. Find the final name of the module. --- 5. Find and replace each name in the parsed source of the module with a --- version qualified by the modules final name. --- --- Notes: --- The idea is to create a code action provider that gets the parsed (or type --- checked) source which creates a code action at the proper locations, and --- gives this to the client. - -hehe :: Text -hehe = undefined - --- aliasImportCommandId :: CommandId --- aliasImportCommandId = "Huh?" - --- aliasImportCommand :: PluginCommand IdeState --- aliasImportCommand = PluginCommand aliasImportCommandId "Alias import command" runAliasImportCommand - --- newtype AliasImportCommandParams = AliasImportCommandParams WorkspaceEdit --- deriving Generic --- deriving anyclass (FromJSON, ToJSON) - --- runAliasImportCommand :: CommandFunction IdeState AliasImportCommandParams --- runAliasImportCommand state (AliasImportCommandParams edit) = do --- _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) --- pure (Right Null) - - -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor pluginId = (defaultPluginDescriptor pluginId) { - -- pluginRules = minimalImportsRule, - -- pluginCommands = [aliasImportCommand], - pluginHandlers = mconcat - [ mkPluginHandler STextDocumentCodeAction codeActionProvider - ] -} - -isRangeWithinSrcSpan :: Range -> SrcSpan -> Bool -isRangeWithinSrcSpan (Range start end) srcSpan = - isInsideSrcSpan start srcSpan && isInsideSrcSpan end srcSpan - -findLImportDeclAt :: Range -> ParsedModule -> Maybe (LImportDecl GhcPs) -findLImportDeclAt range parsedModule - | ParsedModule {..} <- parsedModule - , L _ hsModule <- pm_parsed_source - , locatedImportDecls <- hsmodImports hsModule = - find (\ (L srcSpan _) -> isRangeWithinSrcSpan range srcSpan) locatedImportDecls - | otherwise = Nothing - -getImportedUsedIdentifierTextEdits :: ImportDecl GhcPs -> Identifier -> [(Span, IdentifierDetails i)] -> [TextEdit] -getImportedUsedIdentifierTextEdits importDecl identifier spanIdentifierDetailsPairs - | ImportDecl {..} <- importDecl - , Just qualification <- getQualificationIfIdentifierIsImportedByImportDecl importDecl identifier = - mapMaybe (textEditIfIdentifierDetailsContainUse identifier qualification) spanIdentifierDetailsPairs - | otherwise = [] - -getQualificationIfIdentifierIsImportedByImportDecl :: ImportDecl GhcPs -> Identifier -> Maybe Text -getQualificationIfIdentifierIsImportedByImportDecl importDecl identifier - | ImportDecl {..} <- importDecl - , Right name <- identifier - , Just (Module _ identifierModuleName) <- nameModule_maybe name - , L _ importModuleName <- ideclName - , identifierModuleName == importModuleName - , qualificationModuleName <- if | Just (L _ aliasModuleName) <- ideclAs -> aliasModuleName - | otherwise -> importModuleName - , qualificationText <- Text.pack $ moduleNameString qualificationModuleName = - case ideclHiding of - Nothing -> Just qualificationText - Just (isHiding, L _ locatedImportExportEntities) - | ieOccNames <- foldMap (map rdrNameOcc . ieNames . unLoc) locatedImportExportEntities - , identifierOccName <- nameOccName name - , ieOccNamesContainIdentifierOccName <- identifierOccName `elem` ieOccNames -> - if (isHiding && not ieOccNamesContainIdentifierOccName) - || (not isHiding && ieOccNamesContainIdentifierOccName) - then Just qualificationText - else Nothing - | otherwise = Nothing - -textEditIfIdentifierDetailsContainUse :: Identifier -> Text -> (Span, IdentifierDetails i) -> Maybe TextEdit -textEditIfIdentifierDetailsContainUse identifier qualification (span, identifierDetails) - | Right name <- identifier - , identifierNameText <- Text.pack $ unpackFS $ occNameFS $ nameOccName name - , identifierDetailsContainUse identifierDetails - , range <- realSrcSpanToRange span = - Just $ TextEdit range (qualification <> "." <> identifierNameText) - | otherwise = Nothing - -identifierDetailsContainUse :: IdentifierDetails a -> Bool -identifierDetailsContainUse = elem Use . identInfo - -codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction -codeActionProvider ideState pluginId (CodeActionParams _ _ documentId range context) - | trace "Hiiiiiiiiiiiiii" False = undefined - | TextDocumentIdentifier uri <- documentId - , Just normalizedFilePath <- uriToNormalizedFilePath (toNormalizedUri uri) = liftIO $ do - parsedModule <- runAction "QualifyImportedNames.GetParsedModule" ideState (use GetParsedModule normalizedFilePath) - if | Just parsedModule <- parsedModule - , Just (L _ ImportDecl {..}) <- findLImportDeclAt range parsedModule - , NotQualified <- ideclQualified -> do - hieAstResult <- runAction "QualifyImportedNames.GetHieAst" ideState (use GetHieAst normalizedFilePath) - if | Just HAR {..} <- hieAstResult - , Just (L _ importDecl) <- findLImportDeclAt range parsedModule - , let folder acc k v = getImportedUsedIdentifierTextEdits importDecl k v ++ acc - , importedUsedIdentifierTextEdits <- Map.foldlWithKey' folder [] refMap -> - let codeAction = InR CodeAction {..} - _title = "Qualify imported names" - _kind = Just CodeActionQuickFix - _command = Nothing - _edit = Just WorkspaceEdit {..} - _changes = Just $ HashMap.singleton uri $ List importedUsedIdentifierTextEdits - _documentChanges = Nothing - _diagnostics = Nothing - _isPreferred = Nothing - _disabled = Nothing - _xdata = Nothing - _changeAnnotations = Nothing - in pure $ Right $ List [codeAction | not (null importedUsedIdentifierTextEdits)] - | otherwise -> pure $ Right $ List [] - | otherwise -> pure $ Right $ List [] - | otherwise = pure $ Right $ List [] - From 198e0ba13327df2d0175a1a0cfa9f03f35cd1eb1 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Tue, 1 Feb 2022 02:50:28 -0500 Subject: [PATCH 27/43] fix prettyprinter imports for 8.6.5 --- ghcide/src/Development/IDE/Main/HeapStats.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Main/HeapStats.hs b/ghcide/src/Development/IDE/Main/HeapStats.hs index d3953435a4..3e943c564e 100644 --- a/ghcide/src/Development/IDE/Main/HeapStats.hs +++ b/ghcide/src/Development/IDE/Main/HeapStats.hs @@ -1,16 +1,18 @@ {-# LANGUAGE NumericUnderscores #-} +-- for the sake of compiling ghc 8.6.5 prettyprinter +{-# OPTIONS_GHC -Wno-deprecations #-} -- | Logging utilities for reporting heap statistics module Development.IDE.Main.HeapStats ( withHeapStats, Log(..), logToPriority ) where import Control.Concurrent import Control.Concurrent.Async import Control.Monad +import Data.Text.Prettyprint.Doc (Pretty (pretty), (<+>)) +import qualified Data.Text.Prettyprint.Doc as Prettyprinter import Data.Word import Development.IDE.Types.Logger (Recorder, logWith) import qualified Development.IDE.Types.Logger as Logger import GHC.Stats -import Prettyprinter (Pretty (pretty), (<+>)) -import qualified Prettyprinter import Text.Printf (printf) data Log From 74e9c0e307e2091f0d1b1f2dd1589d4ba9d690ab Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Tue, 1 Feb 2022 03:01:25 -0500 Subject: [PATCH 28/43] try enforcing prettyprinter bounds? --- ghcide/ghcide.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 7e99a94078..32d5d314d6 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -329,7 +329,7 @@ executable ghcide hls-graph, text, unordered-containers, - prettyprinter + prettyprinter >= 1.7 other-modules: Arguments Paths_ghcide From 5f045ed41a1674733fca987048201ac00f506049 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Tue, 1 Feb 2022 05:16:58 -0500 Subject: [PATCH 29/43] enforcing bound makes no sense --- ghcide/ghcide.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 32d5d314d6..7e99a94078 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -329,7 +329,7 @@ executable ghcide hls-graph, text, unordered-containers, - prettyprinter >= 1.7 + prettyprinter other-modules: Arguments Paths_ghcide From 2a9f68609688d7e6719e128b69317b16100c5cc9 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Tue, 1 Feb 2022 15:45:51 -0500 Subject: [PATCH 30/43] maybe changing stack yamls does trick --- stack-8.6.5.yaml | 1 + stack-8.8.4.yaml | 1 + 2 files changed, 2 insertions(+) diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 121998bfc6..9287ff9113 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -79,6 +79,7 @@ extra-deps: - optparse-applicative-0.15.1.0 - ormolu-0.1.4.1 - parser-combinators-1.2.1 + - prettyprinter-1.7.1 - primitive-0.7.1.0 - refinery-0.4.0.0 - regex-base-0.94.0.0 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index ce00d47573..aba8de6350 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -64,6 +64,7 @@ extra-deps: - monad-dijkstra-0.1.1.2 - opentelemetry-0.6.1 - opentelemetry-extra-0.6.1 + - prettyprinter-1.7.1 - refinery-0.4.0.0 - retrie-1.1.0.0 - semigroups-0.18.5 From 42c22e54a8bdf3d09ff221463f35fe655387277a Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Tue, 1 Feb 2022 16:02:06 -0500 Subject: [PATCH 31/43] filter out warnings when their diags are empty to more closely match original --- ghcide/src/Development/IDE/Core/Shake.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 3ef5284232..3a4ab3085d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -220,8 +220,15 @@ logToPriority = \case LogDelayedAction delayedAction _ -> actionPriority delayedAction LogBuildSessionFinish{} -> Logger.Debug LogDiagsDiffButNoLspEnv{} -> Logger.Info - LogDefineEarlyCutoffRuleNoDiagDiags{} -> Logger.Warning - LogDefineEarlyCutoffRuleCustomNewnessDiags{} -> Logger.Warning + LogDefineEarlyCutoffRuleNoDiagDiags diags + -- it may be worth having a priority below debug because + -- originally these were only logged if diags was nonempty + -- either that or mapM_ log diags like the original + | null diags -> Logger.Debug + | otherwise -> Logger.Warning + LogDefineEarlyCutoffRuleCustomNewnessDiags diags + | null diags -> Logger.Debug + | otherwise -> Logger.Warning -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by From 1978a5254e9241425dd9087250555e620917e084 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Thu, 3 Feb 2022 16:02:27 -0500 Subject: [PATCH 32/43] add ability to select wanted logging columns, match prev ghcide exe logging behaviour --- exe/Main.hs | 6 +- ghcide/exe/Main.hs | 37 ++++++-- ghcide/src/Development/IDE/Main.hs | 21 ++--- ghcide/src/Development/IDE/Types/Logger.hs | 103 +++++++++++++++------ hls-test-utils/src/Test/Hls.hs | 31 ++++--- src/Ide/Main.hs | 2 +- 6 files changed, 126 insertions(+), 74 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index f7c35cf8aa..9d6e2b7fd7 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -42,8 +42,8 @@ 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 - stderrRecorder <- cmap logToDocWithPriority <$> makeDefaultStderrRecorder (priorityToHsLoggerPriority Info) - args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmap LogPlugins stderrRecorder) False) + pluginCliRecorder <- cmap logToDocWithPriority <$> makeDefaultStderrRecorder Nothing (priorityToHsLoggerPriority Info) + args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmap LogPlugins pluginCliRecorder) False) let (minPriority, logFilePath, includeExamplePlugins) = case args of @@ -53,7 +53,7 @@ main = do _ -> (Info, Nothing, False) let hsLoggerMinPriority = priorityToHsLoggerPriority minPriority - withDefaultRecorder logFilePath hsLoggerMinPriority $ \textWithPriorityRecorder -> do + withDefaultRecorder logFilePath Nothing hsLoggerMinPriority $ \textWithPriorityRecorder -> do let recorder = textWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index dc6e3ecfdb..304e1dd971 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -21,9 +21,13 @@ import Development.IDE.Core.Tracing (withTelemetryLogger) import Development.IDE.Graph (ShakeOptions (shakeThreads)) import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde -import Development.IDE.Types.Logger (WithPriority (WithPriority, priority), +import Development.IDE.Types.Logger (Logger (Logger), + LoggingColumn (DataColumn, PriorityColumn), + Recorder (Recorder), + WithPriority (WithPriority, priority), cfilter, cmap, - makeDefaultStderrRecorder) + makeDefaultStderrRecorder, + priorityToHsLoggerPriority) import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options import Ide.Plugin.Config (Config (checkParents, checkProject)) @@ -35,22 +39,24 @@ import System.Environment (getExecutablePath) import System.Exit (exitSuccess) import System.IO (hPutStrLn, stderr) import System.Info (compilerVersion) -import qualified System.Log as HsLogger data Log = LogIDEMain IDEMain.Log | LogRules Rules.Log + | LogGhcIde GhcIde.Log deriving Show instance Pretty Log where pretty = \case LogIDEMain log -> pretty log LogRules log -> pretty log + LogGhcIde log -> pretty log logToPriority :: Log -> Logger.Priority logToPriority = \case LogIDEMain log -> IDEMain.logToPriority log LogRules log -> Rules.logToPriority log + LogGhcIde log -> GhcIde.logToPriority log logToDocWithPriority :: Log -> WithPriority (Doc a) logToDocWithPriority log = WithPriority (logToPriority log) (pretty log) @@ -68,7 +74,12 @@ ghcideVersion = do main :: IO () main = withTelemetryLogger $ \telemetryLogger -> do - let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors mempty) + -- stderr recorder just for plugin cli commands + pluginCliRecorder <- + cmap logToDocWithPriority + <$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) (priorityToHsLoggerPriority Info) + + let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmap LogGhcIde pluginCliRecorder)) -- WARNING: If you write to stdout before runLanguageServer -- then the language server will not work Arguments{..} <- getArguments hlsPlugins @@ -81,18 +92,24 @@ main = withTelemetryLogger $ \telemetryLogger -> do Nothing -> IO.getCurrentDirectory Just root -> IO.setCurrentDirectory root >> IO.getCurrentDirectory - let (hsLoggerMinPriority, minPriority) = if argsVerbose then (HsLogger.DEBUG, Debug) else (HsLogger.INFO, Info) + let minPriority = if argsVerbose then Debug else Info + + docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) (priorityToHsLoggerPriority minPriority) + + let docWithFilteredPriorityRecorder@Recorder{ logger_ } = + docWithPriorityRecorder + & cfilter (\WithPriority{ priority } -> priority >= minPriority) - defaultRecorder <- makeDefaultStderrRecorder hsLoggerMinPriority + -- hack so old-school logging still works + let logger = Logger $ \p m -> logger_ (WithPriority p (pretty m)) - let recorder = defaultRecorder - & cfilter (\WithPriority{ priority } -> priority >= minPriority) + let recorder = docWithFilteredPriorityRecorder & cmap logToDocWithPriority let arguments = if argsTesting - then IDEMain.testing (cmap LogIDEMain recorder) - else IDEMain.defaultArguments (cmap LogIDEMain recorder) minPriority + then IDEMain.testing (cmap LogIDEMain recorder) logger + else IDEMain.defaultArguments (cmap LogIDEMain recorder) logger IDEMain.defaultMain (cmap LogIDEMain recorder) arguments { IDEMain.argsProjectRoot = Just argsCwd diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index edf27bd4ae..3346ad8a32 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -252,15 +252,13 @@ data Arguments = Arguments , argsThreads :: Maybe Natural } --- instance Default Arguments where --- def = defaultArguments Info -defaultArguments :: Recorder Log -> Priority -> Arguments -defaultArguments recorder priority = Arguments +defaultArguments :: Recorder Log -> Logger -> Arguments +defaultArguments recorder logger = Arguments { argsProjectRoot = Nothing , argsOTMemoryProfiling = False , argCommand = LSP - , argsLogger = stderrLogger priority + , argsLogger = pure logger , argsRules = mainRule (cmap LogRules recorder) def >> action kick , argsGhcidePlugin = mempty , argsHlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmap LogGhcIde recorder)) @@ -292,17 +290,10 @@ defaultArguments recorder priority = Arguments } --- | Cheap stderr logger that relies on LineBuffering -stderrLogger :: Priority -> IO Logger -stderrLogger logLevel = do - lock <- newLock - return $ Logger $ \p m -> when (p >= logLevel) $ withLock lock $ - T.hPutStrLn stderr $ "[" <> T.pack (show p) <> "] " <> m - -testing :: Recorder Log -> Arguments -testing recorder = +testing :: Recorder Log -> Logger -> Arguments +testing recorder logger = let - arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = defaultArguments recorder Debug + arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = defaultArguments recorder logger hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc argsHlsPlugins ++ [Test.blockCommandDescriptor "block-command", Test.plugin] diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index 16c4fc2172..3877274c3c 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -12,7 +12,14 @@ module Development.IDE.Types.Logger , logError, logWarning, logInfo, logDebug, logTelemetry , noLogging , WithPriority(..) - , logWith, cmap, cmapIO, cfilter, withDefaultRecorder, makeDefaultStderrRecorder, priorityToHsLoggerPriority) where + , logWith + , cmap + , cmapIO + , cfilter + , withDefaultRecorder + , makeDefaultStderrRecorder + , priorityToHsLoggerPriority + , LoggingColumn(..)) where import Control.Concurrent (myThreadId) import Control.Concurrent.Extra (Lock, newLock, withLock) @@ -20,20 +27,20 @@ import Control.Exception (IOException) import Control.Monad (forM_, when, (>=>)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Functor.Contravariant (Contravariant (contramap)) +import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text as Text import qualified Data.Text.IO as Text import Data.Text.Prettyprint.Doc (Doc, Pretty (pretty), defaultLayoutOptions, - layoutPretty, (<+>)) + layoutPretty, vcat, + (<+>)) import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) import Data.Time (defaultTimeLocale, formatTime, getCurrentTime) import GHC.Stack (HasCallStack, - SrcLoc (SrcLoc, srcLocModule, srcLocStartLine), - getCallStack, withFrozenCallStack) import System.IO (Handle, IOMode (AppendMode), @@ -44,8 +51,9 @@ 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 -import UnliftIO (MonadUnliftIO, finally, - try) +import UnliftIO (MonadUnliftIO, + displayException, + finally, try) data Priority -- Don't change the ordering of this type or you will mess up the Ord @@ -134,10 +142,10 @@ textHandleRecorder handle = Recorder { logger_ = \text -> liftIO $ Text.hPutStrLn handle text *> hFlush handle } -makeDefaultStderrRecorder :: MonadIO m => HsLogger.Priority -> m (Recorder (WithPriority (Doc a))) -makeDefaultStderrRecorder hsLoggerMinPriority = do +makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> HsLogger.Priority -> m (Recorder (WithPriority (Doc a))) +makeDefaultStderrRecorder columns hsLoggerMinPriority = do lock <- liftIO newLock - makeDefaultHandleRecorder hsLoggerMinPriority lock stderr + makeDefaultHandleRecorder columns hsLoggerMinPriority lock stderr -- | If no path given then use stderr, otherwise use file. -- kinda complicated because we are logging with both hslogger and our own @@ -145,27 +153,42 @@ makeDefaultStderrRecorder hsLoggerMinPriority = do withDefaultRecorder :: MonadUnliftIO m => Maybe FilePath + -> Maybe [LoggingColumn] -> HsLogger.Priority -> (Recorder (WithPriority (Doc d)) -> m a) -> m a -withDefaultRecorder path hsLoggerMinPriority action = do +withDefaultRecorder path columns hsLoggerMinPriority action = do lock <- liftIO newLock - let makeHandleRecorder = makeDefaultHandleRecorder hsLoggerMinPriority lock + let makeHandleRecorder = makeDefaultHandleRecorder columns hsLoggerMinPriority lock case path of - Nothing -> makeHandleRecorder stderr >>= action + Nothing -> do + recorder <- makeHandleRecorder stderr + let message = "No log file specified; using stderr." + logWith recorder (WithPriority Info message) + action recorder Just path -> do - handle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode) - case handle of - Left _ -> makeHandleRecorder stderr >>= \recorder -> - logWith recorder (WithPriority Error $ "Couldn't open log file" <+> pretty path <> "; falling back to stderr.") - >> action recorder - Right handle -> finally (makeHandleRecorder handle >>= action) (liftIO $ hClose handle) - -makeDefaultHandleRecorder :: MonadIO m => HsLogger.Priority -> Lock -> Handle -> m (Recorder (WithPriority (Doc a))) -makeDefaultHandleRecorder hsLoggerMinPriority lock handle = do + fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode) + case fileHandle of + Left e -> do + recorder <- makeHandleRecorder stderr + let exceptionMessage = pretty $ displayException e + let message = vcat [exceptionMessage, "Couldn't open log file" <+> pretty path <> "; falling back to stderr."] + logWith recorder (WithPriority Warning message) + action recorder + Right fileHandle -> finally (makeHandleRecorder fileHandle >>= action) (liftIO $ hClose fileHandle) + +makeDefaultHandleRecorder + :: MonadIO m + => Maybe [LoggingColumn] + -> HsLogger.Priority + -> Lock + -> Handle + -> m (Recorder (WithPriority (Doc a))) +makeDefaultHandleRecorder columns hsLoggerMinPriority lock handle = do let Recorder{ logger_ } = textHandleRecorder handle let threadSafeRecorder = Recorder { logger_ = \msg -> liftIO $ withLock lock (logger_ msg) } - let textWithPriorityRecorder = cmapIO textWithPriorityToText threadSafeRecorder + let loggingColumns = fromMaybe defaultLoggingColumns columns + let textWithPriorityRecorder = cmapIO (textWithPriorityToText loggingColumns) threadSafeRecorder liftIO $ setupHsLogger lock handle ["hls", "hie-bios"] hsLoggerMinPriority pure (cmap docToText textWithPriorityRecorder) where @@ -204,18 +227,38 @@ setupHsLogger lock handle extraLogNames level = do logFormat = "$time [$tid] $prio $loggername:\t$msg" logDateFormat = "%Y-%m-%d %H:%M:%S%Q" -textWithPriorityToText :: WithPriority Text -> IO Text -textWithPriorityToText = \case - WithPriority{ priority, payload } -> do - utcTime <- getCurrentTime - pure $ Text.intercalate " | " - [ utcTimeToText utcTime - , priorityToText priority - , payload ] +data LoggingColumn + = TimeColumn + | ThreadIdColumn + | PriorityColumn + | DataColumn + +defaultLoggingColumns :: [LoggingColumn] +defaultLoggingColumns = [TimeColumn, PriorityColumn, DataColumn] + +textWithPriorityToText :: [LoggingColumn] -> WithPriority Text -> IO Text +textWithPriorityToText columns WithPriority{ priority, payload } = do + textColumns <- mapM loggingColumnToText columns + pure $ Text.intercalate " | " textColumns where utcTimeToText utcTime = Text.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime priorityToText :: Priority -> Text priorityToText = Text.pack . show + threadIdToText = Text.pack . show + + loggingColumnToText :: LoggingColumn -> IO Text + loggingColumnToText = \case + TimeColumn -> do + utcTime <- getCurrentTime + pure (utcTimeToText utcTime) + ThreadIdColumn -> do + threadId <- myThreadId + pure (threadIdToText threadId) + PriorityColumn -> pure (priorityToText priority) + DataColumn -> pure payload + + + diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index a771c15271..b9f7587cc1 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -4,7 +4,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} module Test.Hls ( module Test.Tasty.HUnit, module Test.Tasty, @@ -52,7 +51,7 @@ import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL -import Development.IDE (IdeState, noLogging) +import Development.IDE (IdeState) import Development.IDE.Graph (ShakeOptions (shakeThreads)) import Development.IDE.Main hiding (Log, logToPriority) import qualified Development.IDE.Main as Ghcide @@ -60,7 +59,9 @@ import qualified Development.IDE.Main as IDEMain import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), WaitForIdeRuleResult (ideResultSuccess)) import qualified Development.IDE.Plugin.Test as Test -import Development.IDE.Types.Logger (Priority (Debug), +import Development.IDE.Types.Logger (Logger (Logger), + Priority (Debug), + Recorder (Recorder, logger_), WithPriority (WithPriority, priority), cfilter, cmap, makeDefaultStderrRecorder) @@ -193,19 +194,21 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre (inR, inW) <- createPipe (outR, outW) <- createPipe - -- this recorder may be different than the recorder in the passed in plugin - -- if you want to modify ghcide specific logging during tests then this one - -- should be modified - -- otherwise modify the recorder passed to the plugin descriptor - defaultRecorder <- makeDefaultStderrRecorder HsLogger.DEBUG + docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing HsLogger.DEBUG logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR" let - recorder = if logStdErr == "0" - then mempty - else (cmap logToDocWithPriority . cfilter (\WithPriority{ priority } -> priority >= Debug)) defaultRecorder - arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments mempty Debug + docWithFilteredPriorityRecorder@Recorder{ logger_ } = + if logStdErr == "0" then mempty + else cfilter (\WithPriority{ priority } -> priority >= Debug) docWithPriorityRecorder + + logger = Logger $ \p m -> logger_ (WithPriority p (pretty m)) + + recorder = cmap logToDocWithPriority docWithFilteredPriorityRecorder + + arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments (cmap LogIDEMain recorder) logger + hlsPlugins = idePluginsToPluginDesc argsHlsPlugins ++ [Test.blockCommandDescriptor "block-command", Test.plugin] @@ -217,8 +220,6 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre , optCheckProject = pure False , optShakeOptions = optShakeOptions{ shakeThreads = 2 } } - logger = do - if logStdErr == "0" then return noLogging else argsLogger server <- async $ @@ -228,7 +229,7 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre { argsHandleIn = pure inR , argsHandleOut = pure outW , argsDefaultHlsConfig = conf - , argsLogger = logger + , argsLogger = argsLogger , argsIdeOptions = ideOptions , argsHlsPlugins = pluginDescToIdePlugins hlsPlugins } diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index b95481136e..eae58b8978 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -130,7 +130,7 @@ runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLog when (isLSP argsCommand) $ do log $ LogLspStart ghcideArgs (map fst $ ipMap idePlugins) - IDEMain.defaultMain (cmap LogIDEMain recorder) (IDEMain.defaultArguments (cmap LogIDEMain recorder) Info) + IDEMain.defaultMain (cmap LogIDEMain recorder) (IDEMain.defaultArguments (cmap LogIDEMain recorder) hlsLogger) { IDEMain.argCommand = argsCommand , IDEMain.argsHlsPlugins = idePlugins , IDEMain.argsLogger = pure hlsLogger <> pure telemetryLogger From 24aa5f6e88243f28dff46499639ef9f50e2093d1 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Thu, 3 Feb 2022 17:03:41 -0500 Subject: [PATCH 33/43] dont log anything when diags are empty in some defineEarlyCutoff versions --- ghcide/src/Development/IDE/Core/Shake.hs | 43 ++++++++++-------------- 1 file changed, 18 insertions(+), 25 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 3a4ab3085d..22a3e54ad3 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -178,8 +178,8 @@ data Log | LogDelayedAction !(DelayedAction ()) !Seconds | LogBuildSessionFinish !(Maybe SomeException) | LogDiagsDiffButNoLspEnv ![FileDiagnostic] - | LogDefineEarlyCutoffRuleNoDiagDiags ![FileDiagnostic] - | LogDefineEarlyCutoffRuleCustomNewnessDiags ![FileDiagnostic] + | LogDefineEarlyCutoffRuleNoDiagHasDiag !FileDiagnostic + | LogDefineEarlyCutoffRuleCustomNewnessHasDiag !FileDiagnostic deriving Show instance Pretty Log where @@ -205,30 +205,23 @@ instance Pretty Log where LogDiagsDiffButNoLspEnv fileDiagnostics -> "updateFileDiagnostics published different from new diagnostics - file diagnostics:" <+> pretty (showDiagnosticsColored fileDiagnostics) - LogDefineEarlyCutoffRuleNoDiagDiags fileDiagnostics -> - "defineEarlyCutoff RuleNoDiagnostics - file diagnostics:" - <+> pretty (showDiagnosticsColored fileDiagnostics) - LogDefineEarlyCutoffRuleCustomNewnessDiags fileDiagnostics -> - "defineEarlyCutoff RuleWithCustomNewnessCheck - file diagnostics:" - <+> pretty (showDiagnosticsColored fileDiagnostics) + LogDefineEarlyCutoffRuleNoDiagHasDiag fileDiagnostic -> + "defineEarlyCutoff RuleNoDiagnostics - file diagnostic:" + <+> pretty (showDiagnosticsColored [fileDiagnostic]) + LogDefineEarlyCutoffRuleCustomNewnessHasDiag fileDiagnostic -> + "defineEarlyCutoff RuleWithCustomNewnessCheck - file diagnostic:" + <+> pretty (showDiagnosticsColored [fileDiagnostic]) logToPriority :: Log -> Logger.Priority logToPriority = \case - LogCreateHieDbExportsMapStart -> Logger.Debug - LogCreateHieDbExportsMapFinish{} -> Logger.Debug - LogBuildSessionRestart{} -> Logger.Debug - LogDelayedAction delayedAction _ -> actionPriority delayedAction - LogBuildSessionFinish{} -> Logger.Debug - LogDiagsDiffButNoLspEnv{} -> Logger.Info - LogDefineEarlyCutoffRuleNoDiagDiags diags - -- it may be worth having a priority below debug because - -- originally these were only logged if diags was nonempty - -- either that or mapM_ log diags like the original - | null diags -> Logger.Debug - | otherwise -> Logger.Warning - LogDefineEarlyCutoffRuleCustomNewnessDiags diags - | null diags -> Logger.Debug - | otherwise -> Logger.Warning + LogCreateHieDbExportsMapStart -> Logger.Debug + LogCreateHieDbExportsMapFinish{} -> Logger.Debug + LogBuildSessionRestart{} -> Logger.Debug + LogDelayedAction delayedAction _ -> actionPriority delayedAction + LogBuildSessionFinish{} -> Logger.Debug + LogDiagsDiffButNoLspEnv{} -> Logger.Info + LogDefineEarlyCutoffRuleNoDiagHasDiag{} -> Logger.Warning + LogDefineEarlyCutoffRuleCustomNewnessHasDiag{} -> Logger.Warning -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by @@ -1057,14 +1050,14 @@ defineEarlyCutoff recorder (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do let diagnostics diags = do traceDiagnostics diags - logWith recorder $ LogDefineEarlyCutoffRuleNoDiagDiags diags + mapM_ (logWith recorder . LogDefineEarlyCutoffRuleNoDiagHasDiag) diags defineEarlyCutoff' diagnostics (==) key file old mode $ second (mempty,) <$> op key file defineEarlyCutoff recorder RuleWithCustomNewnessCheck{..} = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \ traceDiagnostics -> do let diagnostics diags = do - logWith recorder $ LogDefineEarlyCutoffRuleCustomNewnessDiags diags traceDiagnostics diags + mapM_ (logWith recorder . LogDefineEarlyCutoffRuleCustomNewnessHasDiag) diags defineEarlyCutoff' diagnostics newnessCheck key file old mode $ second (mempty,) <$> build key file From 483b565801538b7064e03d9f1aee0d38f8ed3171 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Thu, 3 Feb 2022 17:12:44 -0500 Subject: [PATCH 34/43] use non-deprecated prettyprinter imports --- ghcide/src/Development/IDE/Main/HeapStats.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Main/HeapStats.hs b/ghcide/src/Development/IDE/Main/HeapStats.hs index 3e943c564e..d3953435a4 100644 --- a/ghcide/src/Development/IDE/Main/HeapStats.hs +++ b/ghcide/src/Development/IDE/Main/HeapStats.hs @@ -1,18 +1,16 @@ {-# LANGUAGE NumericUnderscores #-} --- for the sake of compiling ghc 8.6.5 prettyprinter -{-# OPTIONS_GHC -Wno-deprecations #-} -- | Logging utilities for reporting heap statistics module Development.IDE.Main.HeapStats ( withHeapStats, Log(..), logToPriority ) where import Control.Concurrent import Control.Concurrent.Async import Control.Monad -import Data.Text.Prettyprint.Doc (Pretty (pretty), (<+>)) -import qualified Data.Text.Prettyprint.Doc as Prettyprinter import Data.Word import Development.IDE.Types.Logger (Recorder, logWith) import qualified Development.IDE.Types.Logger as Logger import GHC.Stats +import Prettyprinter (Pretty (pretty), (<+>)) +import qualified Prettyprinter import Text.Printf (printf) data Log From c2d3d01b7b7b8f3b89fdfef79cca37154b0b570b Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Thu, 3 Feb 2022 17:23:58 -0500 Subject: [PATCH 35/43] fix ghcide test module --- ghcide/test/exe/Main.hs | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 679c89ef19..5cdff4adf5 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -105,7 +105,6 @@ import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), WaitForIdeRuleResult (..), blockCommandId) -import qualified HieDbRetry import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types import qualified Language.LSP.Types as LSP @@ -120,7 +119,7 @@ import Test.Tasty.QuickCheck import Text.Printf (printf) import Text.Regex.TDFA ((=~)) import qualified HieDbRetry -import Development.IDE.Types.Logger (WithPriority(WithPriority, priority), Priority (Debug), cmap, Recorder, makeDefaultStderrRecorder, cfilter) +import Development.IDE.Types.Logger (WithPriority(WithPriority, priority), Priority (Debug), cmap, Recorder (Recorder, logger_), makeDefaultStderrRecorder, cfilter, LoggingColumn (PriorityColumn, DataColumn), Logger (Logger)) import Data.Function ((&)) import qualified System.Log as HsLogger import Prettyprinter (Doc, Pretty (pretty)) @@ -171,10 +170,16 @@ waitForAllProgressDone = loop main :: IO () main = do - defaultRecorder <- makeDefaultStderrRecorder HsLogger.DEBUG + docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) HsLogger.DEBUG + + let docWithFilteredPriorityRecorder@Recorder{ logger_ } = + docWithPriorityRecorder + & cfilter (\WithPriority{ priority } -> priority >= Debug) + + -- hack so old school logging still works + let logger = Logger $ \p m -> logger_ (WithPriority p (pretty m)) - let recorder = defaultRecorder - & cfilter (\WithPriority{ priority } -> priority >= Debug) + let recorder = docWithFilteredPriorityRecorder & cmap logToDocWithPriority -- We mess with env vars so run single-threaded. @@ -200,7 +205,7 @@ main = do , thTests , symlinkTests , safeTests - , unitTests recorder + , unitTests recorder logger , haddockTests , positionMappingTests , watchedFilesTests @@ -6175,8 +6180,8 @@ findCodeActions' op errMsg doc range expectedTitles = do findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction findCodeAction doc range t = head <$> findCodeActions doc range [t] -unitTests :: Recorder Log -> TestTree -unitTests recorder = do +unitTests :: Recorder Log -> Logger -> TestTree +unitTests recorder logger = do testGroup "Unit" [ testCase "empty file path does NOT work with the empty String literal" $ uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "." @@ -6218,7 +6223,7 @@ unitTests recorder = do | i <- [(1::Int)..20] ] ++ Ghcide.descriptors (cmap LogGhcIde recorder) - testIde recorder (IDE.testing (cmap LogIDEMain recorder)){IDE.argsHlsPlugins = plugins} $ do + testIde recorder (IDE.testing (cmap LogIDEMain recorder) logger){IDE.argsHlsPlugins = plugins} $ do _ <- createDoc "haskell" "A.hs" "module A where" waitForProgressDone actualOrder <- liftIO $ readIORef orderRef From 835511113f19f5443fce3cf1bed3d5721bd86294 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Fri, 4 Feb 2022 17:08:36 -0500 Subject: [PATCH 36/43] change logWith to accept priority at call site, remove all logToPriority functions, add cmapWithPrio that contramaps through WithPriority --- exe/Main.hs | 20 +-- exe/Plugins.hs | 48 ++---- ghcide/exe/Main.hs | 26 ++-- .../session-loader/Development/IDE/Session.hs | 82 ++++------- ghcide/src/Development/IDE/Core/FileExists.hs | 29 ++-- ghcide/src/Development/IDE/Core/FileStore.hs | 41 +++--- ghcide/src/Development/IDE/Core/OfInterest.hs | 16 +- ghcide/src/Development/IDE/Core/Rules.hs | 137 ++++++++---------- ghcide/src/Development/IDE/Core/Service.hs | 21 +-- ghcide/src/Development/IDE/Core/Shake.hs | 57 +++----- ghcide/src/Development/IDE/GHC/ExactPrint.hs | 19 +-- .../src/Development/IDE/LSP/LanguageServer.hs | 33 ++--- .../src/Development/IDE/LSP/Notifications.hs | 26 ++-- ghcide/src/Development/IDE/Main.hs | 83 +++++------ ghcide/src/Development/IDE/Main/HeapStats.hs | 24 ++- .../src/Development/IDE/Plugin/Completions.hs | 25 ++-- ghcide/src/Development/IDE/Plugin/HLS.hs | 15 +- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 17 +-- .../src/Development/IDE/Plugin/TypeLenses.hs | 16 +- ghcide/src/Development/IDE/Types/Logger.hs | 77 +++++----- ghcide/test/exe/HieDbRetry.hs | 13 +- ghcide/test/exe/Main.hs | 23 ++- hls-test-utils/src/Test/Hls.hs | 18 +-- plugins/default/src/Ide/Plugin/Example.hs | 33 ++--- plugins/default/src/Ide/Plugin/Example2.hs | 29 ++-- .../src/Ide/Plugin/AlternateNumberFormat.hs | 12 +- .../hls-eval-plugin/src/Ide/Plugin/Eval.hs | 16 +- .../src/Ide/Plugin/Eval/Rules.hs | 20 +-- .../src/Ide/Plugin/ExplicitImports.hs | 13 +- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 17 +-- .../src/Ide/Plugin/RefineImports.hs | 12 +- .../src/Ide/Plugin/Tactic.hs | 2 +- .../src/Wingman/LanguageServer.hs | 15 +- .../hls-tactics-plugin/src/Wingman/Plugin.hs | 11 +- src/Ide/Main.hs | 23 +-- 35 files changed, 418 insertions(+), 651 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index 9d6e2b7fd7..ef76ec7046 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,6 +1,5 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Main(main) where @@ -8,7 +7,7 @@ module Main(main) where import Data.Function ((&)) import Development.IDE.Types.Logger (Priority (Debug, Info), WithPriority (WithPriority, priority), - cfilter, cmap, + cfilter, cmapWithPrio, makeDefaultStderrRecorder, priorityToHsLoggerPriority, withDefaultRecorder) @@ -30,20 +29,15 @@ instance Pretty Log where LogIdeMain ideMainLog -> pretty ideMainLog LogPlugins pluginsLog -> pretty pluginsLog -logToPriority :: Log -> Priority -logToPriority = \case - LogIdeMain log -> IdeMain.logToPriority log - LogPlugins log -> Plugins.logToPriority log - -logToDocWithPriority :: Log -> WithPriority (Doc a) -logToDocWithPriority log = WithPriority (logToPriority log) (pretty log) +logToDoc :: Log -> Doc a +logToDoc = pretty 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 <- cmap logToDocWithPriority <$> makeDefaultStderrRecorder Nothing (priorityToHsLoggerPriority Info) - args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmap LogPlugins pluginCliRecorder) False) + pluginCliRecorder <- cmapWithPrio logToDoc <$> makeDefaultStderrRecorder Nothing (priorityToHsLoggerPriority Info) + args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder) False) let (minPriority, logFilePath, includeExamplePlugins) = case args of @@ -57,6 +51,6 @@ main = do let recorder = textWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority) - & cmap logToDocWithPriority + & cmapWithPrio logToDoc - defaultMain (cmap LogIdeMain recorder) args (Plugins.idePlugins (cmap LogPlugins recorder) includeExamplePlugins) + defaultMain (cmapWithPrio LogIdeMain recorder) args (Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins) diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 3c9c842375..ec9d97b20f 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -3,8 +3,8 @@ {-# LANGUAGE OverloadedStrings #-} module Plugins where -import Development.IDE.Types.Logger (Recorder, cmap) -import qualified Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Logger (Recorder, WithPriority, + cmapWithPrio) import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types (IdePlugins) import Prettyprinter (Pretty (pretty)) @@ -150,30 +150,6 @@ instance Pretty Log where LogAlternateNumberFormat log -> pretty log #endif -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogGhcIde log -> GhcIde.logToPriority log - LogExample log -> Example.logToPriority log - LogExample2 log -> Example2.logToPriority log -#if tactic - LogTactic log -> Tactic.logToPriority log -#endif -#if eval - LogEval log -> Eval.logToPriority log -#endif -#if importLens - LogExplicitImports log -> ExplicitImports.logToPriority log -#endif -#if refineImports - LogRefineImports log -> RefineImports.logToPriority log -#endif -#if hlint - LogHlint log -> Hlint.logToPriority log -#endif -#if alternateNumberFormat - LogAlternateNumberFormat log -> AlternateNumberFormat.logToPriority log -#endif - -- --------------------------------------------------------------------- -- | The plugins configured for use in this instance of the language @@ -181,7 +157,7 @@ logToPriority = \case -- These can be freely added or removed to tailor the available -- features of the server. -idePlugins :: Recorder Log -> Bool -> IdePlugins IdeState +idePlugins :: Recorder (WithPriority Log) -> Bool -> IdePlugins IdeState idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins where allPlugins = if includeExamples @@ -198,7 +174,7 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins Fourmolu.descriptor "fourmolu" : #endif #if tactic - Tactic.descriptor (cmap LogTactic recorder) "tactics" : + Tactic.descriptor (cmapWithPrio LogTactic recorder) "tactics" : #endif #if ormolu Ormolu.descriptor "ormolu" : @@ -225,36 +201,36 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins HaddockComments.descriptor "haddockComments" : #endif #if eval - Eval.descriptor (cmap LogEval recorder) "eval" : + Eval.descriptor (cmapWithPrio LogEval recorder) "eval" : #endif #if importLens - ExplicitImports.descriptor (cmap LogExplicitImports recorder) "importLens" : + ExplicitImports.descriptor (cmapWithPrio LogExplicitImports recorder) "importLens" : #endif #if qualifyImportedNames QualifyImportedNames.descriptor "qualifyImportedNames" : #endif #if refineImports - RefineImports.descriptor (cmap LogRefineImports recorder) "refineImports" : + RefineImports.descriptor (cmapWithPrio LogRefineImports recorder) "refineImports" : #endif #if moduleName ModuleName.descriptor "moduleName" : #endif #if hlint - Hlint.descriptor (cmap LogHlint recorder) "hlint" : + Hlint.descriptor (cmapWithPrio LogHlint recorder) "hlint" : #endif #if splice Splice.descriptor "splice" : #endif #if alternateNumberFormat - AlternateNumberFormat.descriptor (cmap LogAlternateNumberFormat recorder) "alternateNumberFormat" : + AlternateNumberFormat.descriptor (cmapWithPrio LogAlternateNumberFormat recorder) "alternateNumberFormat" : #endif #if selectionRange SelectionRange.descriptor "selectionRange" : #endif -- The ghcide descriptors should come last so that the notification handlers -- (which restart the Shake build) run after everything else - GhcIde.descriptors (cmap LogGhcIde recorder) + GhcIde.descriptors (cmapWithPrio LogGhcIde recorder) examplePlugins = - [Example.descriptor (cmap LogExample recorder) "eg" - ,Example2.descriptor (cmap LogExample2 recorder) "eg2" + [Example.descriptor (cmapWithPrio LogExample recorder) "eg" + ,Example2.descriptor (cmapWithPrio LogExample2 recorder) "eg2" ] diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 304e1dd971..417ef56af5 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -25,7 +25,7 @@ import Development.IDE.Types.Logger (Logger (Logger), LoggingColumn (DataColumn, PriorityColumn), Recorder (Recorder), WithPriority (WithPriority, priority), - cfilter, cmap, + cfilter, cmapWithPrio, makeDefaultStderrRecorder, priorityToHsLoggerPriority) import qualified Development.IDE.Types.Logger as Logger @@ -52,14 +52,8 @@ instance Pretty Log where LogRules log -> pretty log LogGhcIde log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogIDEMain log -> IDEMain.logToPriority log - LogRules log -> Rules.logToPriority log - LogGhcIde log -> GhcIde.logToPriority log - -logToDocWithPriority :: Log -> WithPriority (Doc a) -logToDocWithPriority log = WithPriority (logToPriority log) (pretty log) +logToDoc :: Log -> Doc a +logToDoc = pretty ghcideVersion :: IO String ghcideVersion = do @@ -76,10 +70,10 @@ main :: IO () main = withTelemetryLogger $ \telemetryLogger -> do -- stderr recorder just for plugin cli commands pluginCliRecorder <- - cmap logToDocWithPriority + cmapWithPrio logToDoc <$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) (priorityToHsLoggerPriority Info) - let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmap LogGhcIde pluginCliRecorder)) + let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde pluginCliRecorder)) -- WARNING: If you write to stdout before runLanguageServer -- then the language server will not work Arguments{..} <- getArguments hlsPlugins @@ -104,21 +98,21 @@ main = withTelemetryLogger $ \telemetryLogger -> do let logger = Logger $ \p m -> logger_ (WithPriority p (pretty m)) let recorder = docWithFilteredPriorityRecorder - & cmap logToDocWithPriority + & cmapWithPrio logToDoc let arguments = if argsTesting - then IDEMain.testing (cmap LogIDEMain recorder) logger - else IDEMain.defaultArguments (cmap LogIDEMain recorder) logger + then IDEMain.testing (cmapWithPrio LogIDEMain recorder) logger + else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger - IDEMain.defaultMain (cmap LogIDEMain recorder) arguments + IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments { IDEMain.argsProjectRoot = Just argsCwd , IDEMain.argCommand = argsCommand , IDEMain.argsLogger = IDEMain.argsLogger arguments <> pure telemetryLogger , IDEMain.argsRules = do -- install the main and ghcide-plugin rules - mainRule (cmap LogRules recorder) def + mainRule (cmapWithPrio LogRules recorder) def -- install the kick action, which triggers a typecheck on every -- Shake database restart, i.e. on every user edit. unless argsDisableKick $ diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index ba18e17598..d7538d292f 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -16,7 +16,7 @@ module Development.IDE.Session ,retryOnSqliteBusy ,retryOnException ,Log(..) - , logToPriority) where + ) where -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses -- the real GHC library and the types are incompatible. Furthermore, when @@ -47,7 +47,7 @@ import Data.Time.Clock import Data.Version import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log, Priority, - logToPriority, withHieDb) + withHieDb) import qualified Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile, TargetModule, @@ -64,7 +64,8 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq, newHscEnvEqPreserveImportPaths) import Development.IDE.Types.Location import Development.IDE.Types.Logger (Priority (Debug, Error, Info, Warning), - Recorder, logWith) + Recorder, WithPriority, + logWith) import Development.IDE.Types.Options import GHC.Check import qualified HIE.Bios as HieBios @@ -184,25 +185,6 @@ instance Pretty Log where LogNewComponentCache componentCache -> "New component cache HscEnvEq:" <+> Prettyprinter.viaShow componentCache -logToPriority :: Log -> Priority -logToPriority = \case - LogSettingInitialDynFlags -> Debug - LogGetInitialGhcLibDirDefaultCradleFail{} -> Warning - LogGetInitialGhcLibDirDefaultCradleNone -> Warning - LogHieDbRetry{} -> Warning - LogHieDbRetriesExhausted{} -> Warning - LogHieDbWriterThreadSQLiteError{} -> Error - LogHieDbWriterThreadException{} -> Error - LogInterfaceFilesCacheDir{} -> Info - LogKnownFilesUpdated{} -> Debug - LogMakingNewHscEnv{} -> Info - LogDLLLoadError{} -> Error - LogCradlePath{} -> Info - LogCradleNotFound{} -> Warning - LogSessionLoadingResult{} -> Debug - LogCradle{} -> Debug - LogNewComponentCache{} -> Debug - -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String hiedbDataVersion = "1" @@ -221,7 +203,7 @@ data SessionLoadingOptions = SessionLoadingOptions -- or 'Nothing' to respect the cradle setting , getCacheDirs :: String -> [String] -> IO CacheDirs -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' - , getInitialGhcLibDir :: Recorder Log -> FilePath -> IO (Maybe LibDir) + , getInitialGhcLibDir :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir) , fakeUid :: UnitId -- ^ unit id used to tag the internal component built by ghcide -- To reuse external interface files the unit ids must match, @@ -259,7 +241,7 @@ loadWithImplicitCradle mHieYaml rootDir = do Just yaml -> HieBios.loadCradle yaml Nothing -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir -getInitialGhcLibDirDefault :: Recorder Log -> FilePath -> IO (Maybe LibDir) +getInitialGhcLibDirDefault :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir) getInitialGhcLibDirDefault recorder rootDir = do let log = logWith recorder hieYaml <- findCradle def rootDir @@ -268,18 +250,18 @@ getInitialGhcLibDirDefault recorder rootDir = do case libDirRes of CradleSuccess libdir -> pure $ Just $ LibDir libdir CradleFail err -> do - log $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle + log Warning $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle pure Nothing CradleNone -> do - log LogGetInitialGhcLibDirDefaultCradleNone + log Warning LogGetInitialGhcLibDirDefaultCradleNone pure Nothing -- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir -setInitialDynFlags :: Recorder Log -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir) +setInitialDynFlags :: Recorder (WithPriority Log) -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir) setInitialDynFlags recorder rootDir SessionLoadingOptions{..} = do libdir <- getInitialGhcLibDir recorder rootDir dynFlags <- mapM dynFlagsForPrinting libdir - logWith recorder LogSettingInitialDynFlags + logWith recorder Debug LogSettingInitialDynFlags mapM_ setUnsafeGlobalDynFlags dynFlags pure libdir @@ -292,7 +274,7 @@ setInitialDynFlags recorder rootDir SessionLoadingOptions{..} = do retryOnException :: (MonadIO m, MonadCatch m, RandomGen g, Exception e) => (e -> Maybe e) -- ^ only retry on exception if this predicate returns Just - -> Recorder Log + -> Recorder (WithPriority Log) -> Int -- ^ maximum backoff delay in microseconds -> Int -- ^ base backoff delay in microseconds -> Int -- ^ maximum number of times to retry @@ -309,13 +291,13 @@ retryOnException exceptionPred recorder maxDelay !baseDelay !maxRetryCount rng a let (delay, newRng) = Random.randomR (0, newBaseDelay) rng let newMaxRetryCount = maxRetryCount - 1 liftIO $ do - log $ LogHieDbRetry delay maxDelay newMaxRetryCount (toException e) + log Warning $ LogHieDbRetry delay maxDelay newMaxRetryCount (toException e) threadDelay delay retryOnException exceptionPred recorder maxDelay newBaseDelay newMaxRetryCount newRng action | otherwise -> do liftIO $ do - log $ LogHieDbRetriesExhausted baseDelay maxDelay maxRetryCount (toException e) + log Warning $ LogHieDbRetriesExhausted baseDelay maxDelay maxRetryCount (toException e) throwIO e Right b -> pure b @@ -335,7 +317,7 @@ maxRetryCount :: Int maxRetryCount = 10 retryOnSqliteBusy :: (MonadIO m, MonadCatch m, RandomGen g) - => Recorder Log -> g -> m a -> m a + => Recorder (WithPriority Log) -> g -> m a -> m a retryOnSqliteBusy recorder rng action = let isErrorBusy e | SQLError{ sqlError = ErrorBusy } <- e = Just e @@ -343,7 +325,7 @@ retryOnSqliteBusy recorder rng action = in retryOnException isErrorBusy recorder oneSecond oneMillisecond maxRetryCount rng action -makeWithHieDbRetryable :: RandomGen g => Recorder Log -> g -> HieDb -> WithHieDb +makeWithHieDbRetryable :: RandomGen g => Recorder (WithPriority Log) -> g -> HieDb -> WithHieDb makeWithHieDbRetryable recorder rng hieDb f = retryOnSqliteBusy recorder rng (f hieDb) @@ -351,7 +333,7 @@ makeWithHieDbRetryable recorder rng hieDb f = -- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial -- by a worker thread using a dedicated database connection. -- This is done in order to serialize writes to the database, or else SQLite becomes unhappy -runWithDb :: Recorder Log -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO () +runWithDb :: Recorder (WithPriority Log) -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO () runWithDb recorder fp k = do -- use non-deterministic seed because maybe multiple HLS start at same time -- and send bursts of requests @@ -387,9 +369,9 @@ runWithDb recorder fp k = do -- TODO: probably should let exceptions be caught/logged/handled by top level handler k withHieDbRetryable `Safe.catch` \e@SQLError{} -> do - log $ LogHieDbWriterThreadSQLiteError e + log Error $ LogHieDbWriterThreadSQLiteError e `Safe.catchAny` \e -> do - log $ LogHieDbWriterThreadException e + log Error $ LogHieDbWriterThreadException e getHieDbLoc :: FilePath -> IO FilePath @@ -413,10 +395,10 @@ getHieDbLoc dir = do -- This is the key function which implements multi-component support. All -- components mapping to the same hie.yaml file are mapped to the same -- HscEnv which is updated as new components are discovered. -loadSession :: Recorder Log -> FilePath -> IO (Action IdeGhcSession) +loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession) loadSession recorder = loadSessionWithOptions recorder def -loadSessionWithOptions :: Recorder Log -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) +loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) @@ -474,7 +456,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do logDirtyKeys <- recordDirtyKeys extras GetKnownTargets [emptyFilePath] return (logDirtyKeys >> pure hasUpdate) for_ hasUpdate $ \x -> - logWith recorder $ LogKnownFilesUpdated x + logWith recorder Debug $ LogKnownFilesUpdated x -- Create a new HscEnv from a hieYaml root and a set of options -- If the hieYaml file already has an HscEnv, the new component is @@ -529,7 +511,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- scratch again (for now) -- It's important to keep the same NameCache though for reasons -- that I do not fully understand - log $ LogMakingNewHscEnv inplace + log Info $ LogMakingNewHscEnv inplace hscEnv <- emptyHscEnv ideNc libDir newHscEnv <- -- Add the options for the current component to the HscEnv @@ -566,7 +548,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do res <- loadDLL hscEnv "libm.so.6" case res of Nothing -> pure () - Just err -> log $ LogDLLLoadError err + Just err -> log Error $ LogDLLLoadError err -- Make a map from unit-id to DynFlags, this is used when trying to @@ -615,10 +597,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do lfp <- flip makeRelative cfp <$> getCurrentDirectory - log $ LogCradlePath lfp + log Info $ LogCradlePath lfp when (isNothing hieYaml) $ - log $ LogCradleNotFound lfp + log Warning $ LogCradleNotFound lfp cradle <- loadCradle hieYaml dir lfp <- flip makeRelative cfp <$> getCurrentDirectory @@ -636,7 +618,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do addTag "result" (show res) return res - log $ LogSessionLoadingResult eopts + log Debug $ LogSessionLoadingResult eopts case eopts of -- The cradle gave us some options so get to work turning them -- into and HscEnv. @@ -705,11 +687,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the -- GHC options/dynflags needed for the session and the GHC library directory -cradleToOptsAndLibDir :: Show a => Recorder Log -> Cradle a -> FilePath +cradleToOptsAndLibDir :: Show a => Recorder (WithPriority Log) -> Cradle a -> FilePath -> IO (Either [CradleError] (ComponentOptions, FilePath)) cradleToOptsAndLibDir recorder cradle file = do -- Start off by getting the session options - logWith recorder $ LogCradle cradle + logWith recorder Debug $ LogCradle cradle cradleRes <- HieBios.getCompilerOptions file cradle case cradleRes of CradleSuccess r -> do @@ -771,7 +753,7 @@ setNameCache nc hsc = hsc { hsc_NC = nc } -- | Create a mapping from FilePaths to HscEnvEqs newComponentCache - :: Recorder Log + :: Recorder (WithPriority Log) -> [String] -- File extensions to consider -> Maybe FilePath -- Path to cradle -> NormalizedFilePath -- Path to file that caused the creation of this component @@ -789,7 +771,7 @@ newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do let targetEnv = ([], Just henv) targetDepends = componentDependencyInfo ci res = (targetEnv, targetDepends) - logWith recorder $ LogNewComponentCache res + logWith recorder Debug $ LogNewComponentCache res let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends ctargets <- concatMapM mk (componentTargets ci) @@ -857,9 +839,9 @@ should be filtered out, such that we dont have to re-compile everything. -- | Set the cache-directory based on the ComponentOptions and a list of -- internal packages. -- For the exact reason, see Note [Avoiding bad interface files]. -setCacheDirs :: MonadIO m => Recorder Log -> CacheDirs -> DynFlags -> m DynFlags +setCacheDirs :: MonadIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags setCacheDirs recorder CacheDirs{..} dflags = do - logWith recorder $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir) + logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir) pure $ dflags & maybe id setHiDir hiCacheDir & maybe id setHieDir hieCacheDir diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 2635d46dc7..21f5a648db 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -8,7 +8,7 @@ module Development.IDE.Core.FileExists , watchedGlobs , GetFileExists(..) , Log(..) - , logToPriority) + ) where import Control.Concurrent.STM.Stats (atomically, @@ -19,18 +19,16 @@ import Control.Monad.IO.Class import qualified Data.ByteString as BS import Data.List (partition) import Data.Maybe -import Development.IDE.Core.FileStore hiding (Log, LogShake, - logToPriority) +import Development.IDE.Core.FileStore hiding (Log, LogShake) import qualified Development.IDE.Core.FileStore as FileStore import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake hiding (Log, - logToPriority) +import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Recorder, cmap) -import qualified Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Logger (Recorder, WithPriority, + cmapWithPrio) import Development.IDE.Types.Options import qualified Focus import Ide.Plugin.Config (Config) @@ -100,11 +98,6 @@ instance Pretty Log where LogFileStore log -> pretty log LogShake log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogFileStore log -> FileStore.logToPriority log - LogShake log -> Shake.logToPriority log - -- | Grab the current global value of 'FileExistsMap' without acquiring a dependency getFileExistsMapUntracked :: Action FileExistsMap getFileExistsMapUntracked = do @@ -180,7 +173,7 @@ allExtensions opts = [extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext -- | Installs the 'getFileExists' rules. -- Provides a fast implementation if client supports dynamic watched files. -- Creates a global state as a side effect in that case. -fileExistsRules :: Recorder Log -> Maybe (LanguageContextEnv Config) -> VFSHandle -> Rules () +fileExistsRules :: Recorder (WithPriority Log) -> Maybe (LanguageContextEnv Config) -> VFSHandle -> Rules () fileExistsRules recorder lspEnv vfs = do supportsWatchedFiles <- case lspEnv of Nothing -> pure False @@ -205,12 +198,12 @@ fileExistsRules recorder lspEnv vfs = do then fileExistsRulesFast recorder isWatched vfs else fileExistsRulesSlow recorder vfs - fileStoreRules (cmap LogFileStore recorder) vfs isWatched + fileStoreRules (cmapWithPrio LogFileStore recorder) vfs isWatched -- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked. -fileExistsRulesFast :: Recorder Log -> (NormalizedFilePath -> Action Bool) -> VFSHandle -> Rules () +fileExistsRulesFast :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> VFSHandle -> Rules () fileExistsRulesFast recorder isWatched vfs = - defineEarlyCutoff (cmap LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> do + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> do isWF <- isWatched file if isWF then fileExistsFast vfs file @@ -248,9 +241,9 @@ fileExistsFast vfs file = do summarizeExists :: Bool -> Maybe BS.ByteString summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty -fileExistsRulesSlow :: Recorder Log -> VFSHandle -> Rules () +fileExistsRulesSlow :: Recorder (WithPriority Log) -> VFSHandle -> Rules () fileExistsRulesSlow recorder vfs = - defineEarlyCutoff (cmap LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow vfs file + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow vfs file fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, Maybe Bool) fileExistsSlow vfs file = do diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 4bbcbc8d9e..f59fd92bf0 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -23,7 +23,7 @@ module Development.IDE.Core.FileStore( isWatchSupported, registerFileWatches, Log(..) - , logToPriority) where + ) where import Control.Concurrent.STM.Stats (STM, atomically, modifyTVar') @@ -41,8 +41,7 @@ import qualified Data.Text as T import Data.Time import Data.Time.Clock.POSIX import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake hiding (Log, - logToPriority) +import Development.IDE.Core.Shake hiding (Log) import Development.IDE.GHC.Orphans () import Development.IDE.Graph import Development.IDE.Import.DependencyInformation @@ -70,9 +69,11 @@ import Data.List (foldl') import qualified Data.Text as Text import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Types.Logger (Recorder, cmap, +import Development.IDE.Types.Logger (Priority (Info), + Recorder, + WithPriority, + cmapWithPrio, logWith) -import qualified Development.IDE.Types.Logger as Logger import Language.LSP.Server hiding (getVirtualFile) import qualified Language.LSP.Server as LSP @@ -106,12 +107,6 @@ instance Pretty Log where <+> pretty (fmap (fmap show) reverseDepPaths) LogShake log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogCouldNotIdentifyReverseDeps{} -> Logger.Info - LogTypeCheckingReverseDeps{} -> Logger.Info - LogShake log -> Shake.logToPriority log - makeVFSHandle :: IO VFSHandle makeVFSHandle = do vfsVar <- newVar (1, Map.empty) @@ -133,8 +128,8 @@ makeLSPVFSHandle lspEnv = VFSHandle , setVirtualFileContents = Nothing } -addWatchedFileRule :: Recorder Log -> (NormalizedFilePath -> Action Bool) -> Rules () -addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmap LogShake recorder) $ \AddWatchedFile f -> do +addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () +addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile f -> do isAlreadyWatched <- isWatched f isWp <- isWorkspaceFile f if isAlreadyWatched then pure (Just True) else @@ -146,8 +141,8 @@ addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmap LogShake recor Nothing -> pure $ Just False -getModificationTimeRule :: Recorder Log -> VFSHandle -> Rules () -getModificationTimeRule recorder vfs = defineEarlyCutoff (cmap LogShake recorder) $ Rule $ \(GetModificationTime_ missingFileDiags) file -> +getModificationTimeRule :: Recorder (WithPriority Log) -> VFSHandle -> Rules () +getModificationTimeRule recorder vfs = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \(GetModificationTime_ missingFileDiags) file -> getModificationTimeImpl vfs missingFileDiags file getModificationTimeImpl :: VFSHandle @@ -233,8 +228,8 @@ modificationTime :: FileVersion -> Maybe UTCTime modificationTime VFSVersion{} = Nothing modificationTime (ModificationTime posix) = Just $ posixSecondsToUTCTime posix -getFileContentsRule :: Recorder Log -> VFSHandle -> Rules () -getFileContentsRule recorder vfs = define (cmap LogShake recorder) $ \GetFileContents file -> getFileContentsImpl vfs file +getFileContentsRule :: Recorder (WithPriority Log) -> VFSHandle -> Rules () +getFileContentsRule recorder vfs = define (cmapWithPrio LogShake recorder) $ \GetFileContents file -> getFileContentsImpl vfs file getFileContentsImpl :: VFSHandle @@ -272,7 +267,7 @@ getFileContents f = do pure $ posixSecondsToUTCTime posix return (modTime, txt) -fileStoreRules :: Recorder Log -> VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules () +fileStoreRules :: Recorder (WithPriority Log) -> VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules () fileStoreRules recorder vfs isWatched = do addIdeGlobal vfs getModificationTimeRule recorder vfs @@ -281,7 +276,7 @@ fileStoreRules recorder vfs isWatched = do -- | Note that some buffer for a specific file has been modified but not -- with what changes. -setFileModified :: Recorder Log +setFileModified :: Recorder (WithPriority Log) -> IdeState -> Bool -- ^ Was the file saved? -> NormalizedFilePath @@ -301,18 +296,18 @@ setFileModified recorder state saved nfp = do when checkParents $ typecheckParents recorder state nfp -typecheckParents :: Recorder Log -> IdeState -> NormalizedFilePath -> IO () +typecheckParents :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO () typecheckParents recorder state nfp = void $ shakeEnqueue (shakeExtras state) parents where parents = mkDelayedAction "ParentTC" L.Debug (typecheckParentsAction recorder nfp) -typecheckParentsAction :: Recorder Log -> NormalizedFilePath -> Action () +typecheckParentsAction :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action () typecheckParentsAction recorder nfp = do revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph let log = logWith recorder case revs of - Nothing -> log $ LogCouldNotIdentifyReverseDeps nfp + Nothing -> log Info $ LogCouldNotIdentifyReverseDeps nfp Just rs -> do - log $ LogTypeCheckingReverseDeps nfp revs + log Info $ LogTypeCheckingReverseDeps nfp revs void $ uses GetModIface rs -- | Note that some keys have been modified and restart the session diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 124b8b9fcc..fc51a90856 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -16,8 +16,8 @@ module Development.IDE.Core.OfInterest( kick, FileOfInterestStatus(..), OfInterestVar(..), scheduleGarbageCollection, - Log(..), - logToPriority) where + Log(..) + ) where import Control.Concurrent.Strict import Control.Monad @@ -34,14 +34,12 @@ import qualified Data.ByteString as BS import Data.Maybe (catMaybes) import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake hiding (Log, - logToPriority) +import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Plugin.Completions.Types import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Logger -import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options (IdeTesting (..)) import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP @@ -54,20 +52,16 @@ instance Pretty Log where pretty = \case LogShake log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogShake log -> Shake.logToPriority log - newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) instance IsIdeGlobal OfInterestVar -- | The rule that initialises the files of interest state. -ofInterestRules :: Recorder Log -> Rules () +ofInterestRules :: Recorder (WithPriority Log) -> Rules () ofInterestRules recorder = do addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty) addIdeGlobal . GarbageCollectVar =<< liftIO (newVar False) - defineEarlyCutoff (cmap LogShake recorder) $ RuleNoDiagnostics $ \IsFileOfInterest f -> do + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsFileOfInterest f -> do alwaysRerun filesOfInterest <- getFilesOfInterestUntracked let foi = maybe NotFOI IsFOI $ f `HashMap.lookup` filesOfInterest diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index e687e32adc..51c5ca4dbe 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -57,8 +57,8 @@ module Development.IDE.Core.Rules( getParsedModuleDefinition, typeCheckRuleDefinition, GhcSessionDepsConfig(..), - Log(..), - logToPriority) where + Log(..) + ) where #if !MIN_VERSION_ghc(8,8,0) import Control.Applicative (liftA2) @@ -96,16 +96,16 @@ import qualified Data.Text.Encoding as T import Data.Time (UTCTime (..)) import Data.Tuple.Extra import Development.IDE.Core.Compile -import Development.IDE.Core.FileExists hiding (LogShake, logToPriority, Log) +import Development.IDE.Core.FileExists hiding (LogShake, Log) import Development.IDE.Core.FileStore (getFileContents, modificationTime, resetInterfaceStore) import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.OfInterest hiding (LogShake, logToPriority, Log) +import Development.IDE.Core.OfInterest hiding (LogShake, Log) import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service hiding (LogShake, logToPriority, Log) -import Development.IDE.Core.Shake hiding (logToPriority, Log) +import Development.IDE.Core.Service hiding (LogShake, Log) +import Development.IDE.Core.Shake hiding (Log) import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat hiding (parseModule, @@ -116,7 +116,7 @@ import Development.IDE.GHC.Compat hiding import qualified Development.IDE.GHC.Compat as Compat import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error -import Development.IDE.GHC.ExactPrint hiding (logToPriority, Log) +import Development.IDE.GHC.ExactPrint hiding (LogShake, Log) import Development.IDE.GHC.Util hiding (modifyDynFlags) import Development.IDE.Graph @@ -151,12 +151,12 @@ import Control.Concurrent.STM.Stats (atomically) import Language.LSP.Server (LspT) import System.Info.Extra (isWindows) import HIE.Bios.Ghc.Gap (hostIsDynamic) -import Development.IDE.Types.Logger (Recorder, cmap, logWith) -import qualified Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Logger (Recorder, logWith, cmapWithPrio, WithPriority) import qualified Development.IDE.Core.Shake as Shake -import qualified Development.IDE.GHC.ExactPrint as ExactPrint +import qualified Development.IDE.GHC.ExactPrint as ExactPrint hiding (LogShake) import Prettyprinter (Pretty (pretty), (<+>)) import qualified Prettyprinter +import qualified Development.IDE.Types.Logger as Logger data Log = LogShake Shake.Log @@ -183,15 +183,6 @@ instance Pretty Log where "SUCCEEDED LOADING HIE FILE FOR" <+> pretty path LogExactPrint log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogShake log -> Shake.logToPriority log - LogReindexingHieFile{} -> Logger.Debug - LogLoadingHieFile{} -> Logger.Debug - LogLoadingHieFileFail{} -> Logger.Debug - LogLoadingHieFileSuccess{} -> Logger.Debug - LogExactPrint log -> ExactPrint.logToPriority log - templateHaskellInstructions :: T.Text templateHaskellInstructions = "https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html#static-binaries" @@ -248,10 +239,10 @@ priorityFilesOfInterest = Priority (-2) -- See https://github.com/haskell/ghcide/pull/350#discussion_r370878197 -- and https://github.com/mpickering/ghcide/pull/22#issuecomment-625070490 -- GHC wiki about: https://gitlab.haskell.org/ghc/ghc/-/wikis/api-annotations -getParsedModuleRule :: Recorder Log -> Rules () +getParsedModuleRule :: Recorder (WithPriority Log) -> Rules () getParsedModuleRule recorder = -- this rule does not have early cutoff since all its dependencies already have it - define (cmap LogShake recorder) $ \GetParsedModule file -> do + define (cmapWithPrio LogShake recorder) $ \GetParsedModule file -> do ModSummaryResult{msrModSummary = ms'} <- use_ GetModSummary file sess <- use_ GhcSession file let hsc = hscEnv sess @@ -321,11 +312,11 @@ mergeParseErrorsHaddock normal haddock = normal ++ -- | This rule provides a ParsedModule preserving all annotations, -- including keywords, punctuation and comments. -- So it is suitable for use cases where you need a perfect edit. -getParsedModuleWithCommentsRule :: Recorder Log -> Rules () +getParsedModuleWithCommentsRule :: Recorder (WithPriority Log) -> Rules () getParsedModuleWithCommentsRule recorder = -- The parse diagnostics are owned by the GetParsedModule rule -- For this reason, this rule does not produce any diagnostics - defineNoDiagnostics (cmap LogShake recorder) $ \GetParsedModuleWithComments file -> do + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetParsedModuleWithComments file -> do ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file sess <- use_ GhcSession file opt <- getIdeOptions @@ -356,9 +347,9 @@ getParsedModuleDefinition packageState opt file ms = do Nothing -> pure (diag, Nothing) Just modu -> pure (diag, Just modu) -getLocatedImportsRule :: Recorder Log -> Rules () +getLocatedImportsRule :: Recorder (WithPriority Log) -> Rules () getLocatedImportsRule recorder = - define (cmap LogShake recorder) $ \GetLocatedImports file -> do + define (cmapWithPrio LogShake recorder) $ \GetLocatedImports file -> do ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file targets <- useNoFile_ GetKnownTargets let targetsMap = HM.mapWithKey const targets @@ -515,15 +506,15 @@ rawDependencyInformation fs = do dropBootSuffix :: FilePath -> FilePath dropBootSuffix hs_src = reverse . drop (length @[] "-boot") . reverse $ hs_src -getDependencyInformationRule :: Recorder Log -> Rules () +getDependencyInformationRule :: Recorder (WithPriority Log) -> Rules () getDependencyInformationRule recorder = - define (cmap LogShake recorder) $ \GetDependencyInformation file -> do + define (cmapWithPrio LogShake recorder) $ \GetDependencyInformation file -> do rawDepInfo <- rawDependencyInformation [file] pure ([], Just $ processDependencyInformation rawDepInfo) -reportImportCyclesRule :: Recorder Log -> Rules () +reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules () reportImportCyclesRule recorder = - define (cmap LogShake recorder) $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do + define (cmapWithPrio LogShake recorder) $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do DependencyInformation{..} <- use_ GetDependencyInformation file let fileId = pathToId depPathIdMap file case IntMap.lookup (getFilePathId fileId) depErrorNodes of @@ -555,14 +546,14 @@ reportImportCyclesRule recorder = pure (moduleNameString . moduleName . ms_mod $ ms) showCycle mods = T.intercalate ", " (map T.pack mods) -getHieAstsRule :: Recorder Log -> Rules () +getHieAstsRule :: Recorder (WithPriority Log) -> Rules () getHieAstsRule recorder = - define (cmap LogShake recorder) $ \GetHieAst f -> do + define (cmapWithPrio LogShake recorder) $ \GetHieAst f -> do tmr <- use_ TypeCheck f hsc <- hscEnv <$> use_ GhcSessionDeps f getHieAstRuleDefinition f hsc tmr -persistentHieFileRule :: Recorder Log -> Rules () +persistentHieFileRule :: Recorder (WithPriority Log) -> Rules () persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybeT $ do res <- readHieFileForSrcFromDisk recorder file vfs <- asks vfs @@ -598,8 +589,8 @@ getHieAstRuleDefinition f hsc tmr = do typemap = AtPoint.computeTypeReferences . Compat.getAsts <$> masts pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> typemap <*> pure HieFresh) -getImportMapRule :: Recorder Log -> Rules () -getImportMapRule recorder = define (cmap LogShake recorder) $ \GetImportMap f -> do +getImportMapRule :: Recorder (WithPriority Log) -> Rules () +getImportMapRule recorder = define (cmapWithPrio LogShake recorder) $ \GetImportMap f -> do im <- use GetLocatedImports f let mkImports fileImports = M.fromList $ mapMaybe (\(m, mfp) -> (unLoc m,) . artifactFilePath <$> mfp) fileImports pure ([], ImportMap . mkImports <$> im) @@ -608,17 +599,17 @@ getImportMapRule recorder = define (cmap LogShake recorder) $ \GetImportMap f -> persistentImportMapRule :: Rules () persistentImportMapRule = addPersistentRule GetImportMap $ \_ -> pure $ Just (ImportMap mempty, idDelta, Nothing) -getBindingsRule :: Recorder Log -> Rules () +getBindingsRule :: Recorder (WithPriority Log) -> Rules () getBindingsRule recorder = - define (cmap LogShake recorder) $ \GetBindings f -> do + define (cmapWithPrio LogShake recorder) $ \GetBindings f -> do HAR{hieKind=kind, refMap=rm} <- use_ GetHieAst f case kind of HieFresh -> pure ([], Just $ bindings rm) HieFromDisk _ -> pure ([], Nothing) -getDocMapRule :: Recorder Log -> Rules () +getDocMapRule :: Recorder (WithPriority Log) -> Rules () getDocMapRule recorder = - define (cmap LogShake recorder) $ \GetDocMap file -> do + define (cmapWithPrio LogShake recorder) $ \GetDocMap file -> do -- Stale data for the scenario where a broken module has previously typechecked -- but we never generated a DocMap for it (tmrTypechecked -> tc, _) <- useWithStale_ TypeCheck file @@ -632,39 +623,39 @@ getDocMapRule recorder = persistentDocMapRule :: Rules () persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty, idDelta, Nothing) -readHieFileForSrcFromDisk :: Recorder Log -> NormalizedFilePath -> MaybeT IdeAction Compat.HieFile +readHieFileForSrcFromDisk :: Recorder (WithPriority Log) -> NormalizedFilePath -> MaybeT IdeAction Compat.HieFile readHieFileForSrcFromDisk recorder file = do ShakeExtras{withHieDb} <- ask row <- MaybeT $ liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb $ fromNormalizedFilePath file) let hie_loc = HieDb.hieModuleHieFile row - logWith recorder $ LogLoadingHieFile file + logWith recorder Logger.Debug $ LogLoadingHieFile file exceptToMaybeT $ readHieFileFromDisk recorder hie_loc -readHieFileFromDisk :: Recorder Log -> FilePath -> ExceptT SomeException IdeAction Compat.HieFile +readHieFileFromDisk :: Recorder (WithPriority Log) -> FilePath -> ExceptT SomeException IdeAction Compat.HieFile readHieFileFromDisk recorder hie_loc = do nc <- asks ideNc res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc let log = logWith recorder case res of - Left e -> log $ LogLoadingHieFileFail hie_loc e - Right _ -> log $ LogLoadingHieFileSuccess hie_loc + Left e -> log Logger.Debug $ LogLoadingHieFileFail hie_loc e + Right _ -> log Logger.Debug $ LogLoadingHieFileSuccess hie_loc except res -- | Typechecks a module. -typeCheckRule :: Recorder Log -> Rules () -typeCheckRule recorder = define (cmap LogShake recorder) $ \TypeCheck file -> do +typeCheckRule :: Recorder (WithPriority Log) -> Rules () +typeCheckRule recorder = define (cmapWithPrio LogShake recorder) $ \TypeCheck file -> do pm <- use_ GetParsedModule file hsc <- hscEnv <$> use_ GhcSessionDeps file typeCheckRuleDefinition hsc pm -knownFilesRule :: Recorder Log -> Rules () -knownFilesRule recorder = defineEarlyCutOffNoFile (cmap LogShake recorder) $ \GetKnownTargets -> do +knownFilesRule :: Recorder (WithPriority Log) -> Rules () +knownFilesRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetKnownTargets -> do alwaysRerun fs <- knownTargets pure (LBS.toStrict $ B.encode $ hash fs, unhashed fs) -getModuleGraphRule :: Recorder Log -> Rules () -getModuleGraphRule recorder = defineNoFile (cmap LogShake recorder) $ \GetModuleGraph -> do +getModuleGraphRule :: Recorder (WithPriority Log) -> Rules () +getModuleGraphRule recorder = defineNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do fs <- toKnownFiles <$> useNoFile_ GetKnownTargets rawDepInfo <- rawDependencyInformation (HashSet.toList fs) pure $ processDependencyInformation rawDepInfo @@ -703,11 +694,11 @@ currentLinkables = do where go (mod, time) = LM time mod [] -loadGhcSession :: Recorder Log -> GhcSessionDepsConfig -> Rules () +loadGhcSession :: Recorder (WithPriority Log) -> GhcSessionDepsConfig -> Rules () loadGhcSession recorder ghcSessionDepsConfig = do -- This function should always be rerun because it tracks changes -- to the version of the collection of HscEnv's. - defineEarlyCutOffNoFile (cmap LogShake recorder) $ \GhcSessionIO -> do + defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GhcSessionIO -> do alwaysRerun opts <- getIdeOptions res <- optGhcSession opts @@ -715,7 +706,7 @@ loadGhcSession recorder ghcSessionDepsConfig = do let fingerprint = LBS.toStrict $ B.encode $ hash (sessionVersion res) return (fingerprint, res) - defineEarlyCutoff (cmap LogShake recorder) $ Rule $ \GhcSession file -> do + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file @@ -740,7 +731,7 @@ loadGhcSession recorder ghcSessionDepsConfig = do Nothing -> LBS.toStrict $ B.encode (hash (snd val)) return (Just cutoffHash, val) - defineNoDiagnostics (cmap LogShake recorder) $ \(GhcSessionDeps_ fullModSummary) file -> do + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \(GhcSessionDeps_ fullModSummary) file -> do env <- use_ GhcSession file ghcSessionDepsDefinition fullModSummary ghcSessionDepsConfig env file @@ -778,8 +769,8 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do -- | Load a iface from disk, or generate it if there isn't one or it is out of date -- This rule also ensures that the `.hie` and `.o` (if needed) files are written out. -getModIfaceFromDiskRule :: Recorder Log -> Rules () -getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmap LogShake recorder) $ Rule $ \GetModIfaceFromDisk f -> do +getModIfaceFromDiskRule :: Recorder (WithPriority Log) -> Rules () +getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIfaceFromDisk f -> do ms <- msrModSummary <$> use_ GetModSummary f mb_session <- use GhcSessionDeps f case mb_session of @@ -802,10 +793,10 @@ getModIfaceFromDiskRule recorder = defineEarlyCutoff (cmap LogShake recorder) $ -- `.hie` file. There should be an up2date `.hie` file on -- disk since we are careful to write out the `.hie` file before writing the -- `.hi` file -getModIfaceFromDiskAndIndexRule :: Recorder Log -> Rules () +getModIfaceFromDiskAndIndexRule :: Recorder (WithPriority Log) -> Rules () getModIfaceFromDiskAndIndexRule recorder = -- doesn't need early cutoff since all its dependencies already have it - defineNoDiagnostics (cmap LogShake recorder) $ \GetModIfaceFromDiskAndIndex f -> do + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetModIfaceFromDiskAndIndex f -> do x <- use_ GetModIfaceFromDisk f se@ShakeExtras{withHieDb} <- getShakeExtras @@ -833,13 +824,13 @@ getModIfaceFromDiskAndIndexRule recorder = Left err -> fail $ "failed to read .hie file " ++ show hie_loc ++ ": " ++ displayException err -- can just re-index the file we read from disk Right hf -> liftIO $ do - logWith recorder $ LogReindexingHieFile f + logWith recorder Logger.Debug $ LogReindexingHieFile f indexHieFile se ms f hash hf return (Just x) -isHiFileStableRule :: Recorder Log -> Rules () -isHiFileStableRule recorder = defineEarlyCutoff (cmap LogShake recorder) $ RuleNoDiagnostics $ \IsHiFileStable f -> do +isHiFileStableRule :: Recorder (WithPriority Log) -> Rules () +isHiFileStableRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \IsHiFileStable f -> do ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps f let hiFile = toNormalizedFilePath' $ Compat.ml_hi_file $ ms_location ms @@ -877,13 +868,13 @@ displayTHWarning newtype DisplayTHWarning = DisplayTHWarning (IO ()) instance IsIdeGlobal DisplayTHWarning -getModSummaryRule :: Recorder Log -> Rules () +getModSummaryRule :: Recorder (WithPriority Log) -> Rules () getModSummaryRule recorder = do env <- lspEnv <$> getShakeExtrasRules displayItOnce <- liftIO $ once $ LSP.runLspT (fromJust env) displayTHWarning addIdeGlobal (DisplayTHWarning displayItOnce) - defineEarlyCutoff (cmap LogShake recorder) $ Rule $ \GetModSummary f -> do + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModSummary f -> do session' <- hscEnv <$> use_ GhcSession f modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal let session = hscSetFlags (modify_dflags $ hsc_dflags session') session' @@ -904,7 +895,7 @@ getModSummaryRule recorder = do return ( Just (fingerprintToBS fingerPrint) , ([], Just res)) Left diags -> return (Nothing, (diags, Nothing)) - defineEarlyCutoff (cmap LogShake recorder) $ RuleNoDiagnostics $ \GetModSummaryWithoutTimestamps f -> do + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetModSummaryWithoutTimestamps f -> do ms <- use GetModSummary f case ms of Just res@ModSummaryResult{..} -> do @@ -923,12 +914,12 @@ generateCore runSimplifier file = do setPriority priorityGenerateCore liftIO $ compileModule runSimplifier packageState (tmrModSummary tm) (tmrTypechecked tm) -generateCoreRule :: Recorder Log -> Rules () +generateCoreRule :: Recorder (WithPriority Log) -> Rules () generateCoreRule recorder = - define (cmap LogShake recorder) $ \GenerateCore -> generateCore (RunSimplifier True) + define (cmapWithPrio LogShake recorder) $ \GenerateCore -> generateCore (RunSimplifier True) -getModIfaceRule :: Recorder Log -> Rules () -getModIfaceRule recorder = defineEarlyCutoff (cmap LogShake recorder) $ Rule $ \GetModIface f -> do +getModIfaceRule :: Recorder (WithPriority Log) -> Rules () +getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIface f -> do fileOfInterest <- use_ IsFileOfInterest f res@(_,(_,mhmi)) <- case fileOfInterest of IsFOI status -> do @@ -1031,8 +1022,8 @@ compileToObjCodeIfNeeded hsc (Just linkableType) getGuts tmr = do (diags', !res) <- liftIO $ mkHiFileResultCompile hsc tmr guts linkableType pure (diags++diags', res) -getClientSettingsRule :: Recorder Log -> Rules () -getClientSettingsRule recorder = defineEarlyCutOffNoFile (cmap LogShake recorder) $ \GetClientSettings -> do +getClientSettingsRule :: Recorder (WithPriority Log) -> Rules () +getClientSettingsRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetClientSettings -> do alwaysRerun settings <- clientSettings <$> getIdeConfiguration return (LBS.toStrict $ B.encode $ hash settings, settings) @@ -1142,7 +1133,7 @@ data RulesConfig = RulesConfig instance Default RulesConfig where def = RulesConfig True True -- | A rule that wires per-file rules together -mainRule :: Recorder Log -> RulesConfig -> Rules () +mainRule :: Recorder (WithPriority Log) -> RulesConfig -> Rules () mainRule recorder RulesConfig{..} = do linkables <- liftIO $ newVar emptyModuleEnv addIdeGlobal $ CompiledLinkables linkables @@ -1171,12 +1162,12 @@ mainRule recorder RulesConfig{..} = do -- * Object/BCO -> NoLinkable : the prev linkable can be ignored, signal "no change" -- * otherwise : the prev linkable cannot be reused, signal "value has changed" if enableTemplateHaskell - then defineEarlyCutoff (cmap LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation file -> + then defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation file -> needsCompilationRule file - else defineNoDiagnostics (cmap LogShake recorder) $ \NeedsCompilation _ -> return $ Just Nothing + else defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \NeedsCompilation _ -> return $ Just Nothing generateCoreRule recorder getImportMapRule recorder - getAnnotatedParsedSourceRule (cmap LogExactPrint recorder) + getAnnotatedParsedSourceRule (cmapWithPrio LogExactPrint recorder) persistentHieFileRule recorder persistentDocMapRule persistentImportMapRule diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index f98dd2b13b..a0f1752431 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -16,13 +16,12 @@ module Development.IDE.Core.Service( ideLogger, updatePositionMapping, Log(..), - logToPriority) where + ) where import Control.Applicative ((<|>)) import Development.IDE.Core.Debouncer import Development.IDE.Core.FileExists (fileExistsRules) -import Development.IDE.Core.OfInterest hiding (Log, LogShake, - logToPriority) +import Development.IDE.Core.OfInterest hiding (Log, LogShake) import Development.IDE.Graph import Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options (IdeOptions (..)) @@ -33,7 +32,7 @@ import qualified Language.LSP.Types as LSP import Control.Monad import qualified Development.IDE.Core.FileExists as FileExists import qualified Development.IDE.Core.OfInterest as OfInterest -import Development.IDE.Core.Shake hiding (Log, logToPriority) +import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Shake (WithHieDb) import Prettyprinter (Pretty (pretty)) @@ -52,17 +51,11 @@ instance Pretty Log where LogOfInterest log -> pretty log LogFileExists log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogShake log -> Shake.logToPriority log - LogOfInterest log -> OfInterest.logToPriority log - LogFileExists log -> FileExists.logToPriority log - ------------------------------------------------------------ -- Exposed API -- | Initialise the Compiler Service. -initialise :: Recorder Log +initialise :: Recorder (WithPriority Log) -> Config -> Rules () -> Maybe (LSP.LanguageContextEnv Config) @@ -79,7 +72,7 @@ initialise recorder defaultConfig mainRule lspEnv logger debouncer options vfs w fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING" return $ fromConf <|> fromEnv shakeOpen - (cmap LogShake recorder) + (cmapWithPrio LogShake recorder) lspEnv defaultConfig logger @@ -93,8 +86,8 @@ initialise recorder defaultConfig mainRule lspEnv logger debouncer options vfs w (optShakeOptions options) $ do addIdeGlobal $ GlobalIdeOptions options - ofInterestRules (cmap LogOfInterest recorder) - fileExistsRules (cmap LogFileExists recorder) lspEnv vfs + ofInterestRules (cmapWithPrio LogOfInterest recorder) + fileExistsRules (cmapWithPrio LogFileExists recorder) lspEnv vfs mainRule -- | Shutdown the Compiler Service. diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 22a3e54ad3..32c1563876 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -77,8 +77,8 @@ module Development.IDE.Core.Shake( addPersistentRule, garbageCollectDirtyKeys, garbageCollectDirtyKeysOlderThan, - Log(..), - logToPriority) where + Log(..) + ) where import Control.Concurrent.Async import Control.Concurrent.STM @@ -212,17 +212,6 @@ instance Pretty Log where "defineEarlyCutoff RuleWithCustomNewnessCheck - file diagnostic:" <+> pretty (showDiagnosticsColored [fileDiagnostic]) -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogCreateHieDbExportsMapStart -> Logger.Debug - LogCreateHieDbExportsMapFinish{} -> Logger.Debug - LogBuildSessionRestart{} -> Logger.Debug - LogDelayedAction delayedAction _ -> actionPriority delayedAction - LogBuildSessionFinish{} -> Logger.Debug - LogDiagsDiffButNoLspEnv{} -> Logger.Info - LogDefineEarlyCutoffRuleNoDiagHasDiag{} -> Logger.Warning - LogDefineEarlyCutoffRuleCustomNewnessHasDiag{} -> Logger.Warning - -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by -- a worker thread. @@ -548,7 +537,7 @@ seqValue val = case val of Failed _ -> val -- | Open a 'IdeState', should be shut using 'shakeShut'. -shakeOpen :: Recorder Log +shakeOpen :: Recorder (WithPriority Log) -> Maybe (LSP.LanguageContextEnv Config) -> Config -> Logger @@ -564,7 +553,7 @@ shakeOpen :: Recorder Log -> IO IdeState shakeOpen recorder lspEnv defaultConfig logger debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue vfs opts rules = mdo - let log :: Log -> IO () + let log :: Logger.Priority -> Log -> IO () log = logWith recorder us <- mkSplitUniqSupply 'r' @@ -587,10 +576,10 @@ shakeOpen recorder lspEnv defaultConfig logger debouncer -- lazily initialize the exports map with the contents of the hiedb -- TODO: exceptions can be swallowed here? _ <- async $ do - log LogCreateHieDbExportsMapStart + log Debug LogCreateHieDbExportsMapStart em <- createExportsMapHieDb withHieDb atomically $ modifyTVar' exportsMap (<> em) - log $ LogCreateHieDbExportsMapFinish (ExportsMap.size em) + log Debug $ LogCreateHieDbExportsMapFinish (ExportsMap.size em) progress <- do let (before, after) = if testing then (0,0.1) else (0.1,0.1) @@ -642,7 +631,7 @@ startTelemetry db extras@ShakeExtras{..} -- | Must be called in the 'Initialized' handler and only once -shakeSessionInit :: Recorder Log -> IdeState -> IO () +shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO () shakeSessionInit recorder ide@IdeState{..} = do initSession <- newSession recorder shakeExtras shakeDb [] "shakeSessionInit" putMVar shakeSession initSession @@ -684,7 +673,7 @@ delayedAction a = do -- | Restart the current 'ShakeSession' with the given system actions. -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued. -shakeRestart :: Recorder Log -> IdeState -> String -> [DelayedAction ()] -> IO () +shakeRestart :: Recorder (WithPriority Log) -> IdeState -> String -> [DelayedAction ()] -> IO () shakeRestart recorder IdeState{..} reason acts = withMVar' shakeSession @@ -695,7 +684,7 @@ shakeRestart recorder IdeState{..} reason acts = backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras - log $ LogBuildSessionRestart reason queue backlog stopTime res + log Debug $ LogBuildSessionRestart reason queue backlog stopTime res let profile = case res of Just fp -> ", profile saved at " <> fp @@ -746,7 +735,7 @@ shakeEnqueue ShakeExtras{actionQueue, logger} act = do -- | Set up a new 'ShakeSession' with a set of initial actions -- Will crash if there is an existing 'ShakeSession' running. newSession - :: Recorder Log + :: Recorder (WithPriority Log) -> ShakeExtras -> ShakeDatabase -> [DelayedActionInternal] @@ -772,9 +761,7 @@ newSession recorder extras@ShakeExtras{..} shakeDb acts reason = do getAction d liftIO $ atomicallyNamed "actionQueue - done" $ doneQueue d actionQueue runTime <- liftIO start - let msg = T.pack $ "finish: " ++ actionName d - ++ " (took " ++ showDuration runTime ++ ")" - liftIO $ logWith recorder $ LogDelayedAction d runTime + logWith recorder (actionPriority d) $ LogDelayedAction d runTime -- The inferred type signature doesn't work in ghc >= 9.0.1 workRun :: (forall b. IO b -> IO b) -> IO (IO ()) @@ -794,7 +781,7 @@ newSession recorder extras@ShakeExtras{..} shakeDb acts reason = do case res of Left e -> Just e _ -> Nothing - logWith recorder $ LogBuildSessionFinish exception + logWith recorder Debug $ LogBuildSessionFinish exception notifyTestingLogMessage extras msg -- Do the work in a background thread @@ -910,12 +897,12 @@ preservedKeys checkParents = HSet.fromList $ -- | Define a new Rule without early cutoff define :: IdeRule k v - => Recorder Log -> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules () + => Recorder (WithPriority Log) -> (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules () define recorder op = defineEarlyCutoff recorder $ Rule $ \k v -> (Nothing,) <$> op k v defineNoDiagnostics :: IdeRule k v - => Recorder Log -> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules () + => Recorder (WithPriority Log) -> (k -> NormalizedFilePath -> Action (Maybe v)) -> Rules () defineNoDiagnostics recorder op = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k v -> (Nothing,) <$> op k v -- | Request a Rule result if available @@ -1038,7 +1025,7 @@ data RuleBody k v -- | Define a new Rule with early cutoff defineEarlyCutoff :: IdeRule k v - => Recorder Log + => Recorder (WithPriority Log) -> RuleBody k v -> Rules () defineEarlyCutoff recorder (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do @@ -1050,23 +1037,23 @@ defineEarlyCutoff recorder (Rule op) = addRule $ \(Q (key, file)) (old :: Maybe defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do let diagnostics diags = do traceDiagnostics diags - mapM_ (logWith recorder . LogDefineEarlyCutoffRuleNoDiagHasDiag) diags + mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleNoDiagHasDiag) diags defineEarlyCutoff' diagnostics (==) key file old mode $ second (mempty,) <$> op key file defineEarlyCutoff recorder RuleWithCustomNewnessCheck{..} = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \ traceDiagnostics -> do let diagnostics diags = do traceDiagnostics diags - mapM_ (logWith recorder . LogDefineEarlyCutoffRuleCustomNewnessHasDiag) diags + mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleCustomNewnessHasDiag) diags defineEarlyCutoff' diagnostics newnessCheck key file old mode $ second (mempty,) <$> build key file -defineNoFile :: IdeRule k v => Recorder Log -> (k -> Action v) -> Rules () +defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules () defineNoFile recorder f = defineNoDiagnostics recorder $ \k file -> do if file == emptyFilePath then do res <- f k; return (Just res) else fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" -defineEarlyCutOffNoFile :: IdeRule k v => Recorder Log -> (k -> Action (BS.ByteString, v)) -> Rules () +defineEarlyCutOffNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action (BS.ByteString, v)) -> Rules () defineEarlyCutOffNoFile recorder f = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k file -> do if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, Just res) else fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" @@ -1173,7 +1160,7 @@ data OnDiskRule = OnDiskRule -- the internals of this module that we do not want to expose. defineOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) - => Recorder Log + => Recorder (WithPriority Log) -> (k -> NormalizedFilePath -> OnDiskRule) -> Rules () defineOnDisk recorder act = addRule $ @@ -1216,7 +1203,7 @@ needOnDisks k files = do liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k) updateFileDiagnostics :: MonadIO m - => Recorder Log + => Recorder (WithPriority Log) -> NormalizedFilePath -> Key -> ShakeExtras @@ -1242,7 +1229,7 @@ updateFileDiagnostics recorder fp k ShakeExtras{diagnostics, hiddenDiagnostics, lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri publishedDiagnostics let action = when (lastPublish /= newDiags) $ case lspEnv of Nothing -> -- Print an LSP event. - logWith recorder $ LogDiagsDiffButNoLspEnv (map (fp, ShowDiag,) newDiags) + logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (fp, ShowDiag,) newDiags) Just env -> LSP.runLspT env $ LSP.sendNotification LSP.STextDocumentPublishDiagnostics $ LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) (List newDiags) diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index 2b03e47e48..b56bce9e37 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -44,8 +44,7 @@ module Development.IDE.GHC.ExactPrint ASTElement (..), ExceptStringT (..), TransformT, - Log, - logToPriority + Log(..), ) where @@ -69,8 +68,7 @@ import qualified Data.Text as T import Data.Traversable (for) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service (runAction) -import Development.IDE.Core.Shake hiding (Log, - logToPriority) +import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding (parseImport, parsePattern, @@ -78,8 +76,9 @@ import Development.IDE.GHC.Compat hiding (parseImport, import Development.IDE.Graph (RuleResult, Rules) import Development.IDE.Graph.Classes import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Recorder, cmap) -import qualified Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Logger (Recorder, + WithPriority, + cmapWithPrio) import qualified GHC.Generics as GHC import Generics.SYB import Generics.SYB.GHC @@ -114,10 +113,6 @@ instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogShake log -> Shake.logToPriority log - data GetAnnotatedParsedSource = GetAnnotatedParsedSource deriving (Eq, Show, Typeable, GHC.Generic) @@ -126,8 +121,8 @@ instance NFData GetAnnotatedParsedSource type instance RuleResult GetAnnotatedParsedSource = Annotated ParsedSource -- | Get the latest version of the annotated parse source with comments. -getAnnotatedParsedSourceRule :: Recorder Log -> Rules () -getAnnotatedParsedSourceRule recorder = define (cmap LogShake recorder) $ \GetAnnotatedParsedSource nfp -> do +getAnnotatedParsedSourceRule :: Recorder (WithPriority Log) -> Rules () +getAnnotatedParsedSourceRule recorder = define (cmapWithPrio LogShake recorder) $ \GetAnnotatedParsedSource nfp -> do pm <- use GetParsedModuleWithComments nfp return ([], fmap annotateParsedSource pm) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 36e72940aa..45d4d57a9d 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -11,7 +11,7 @@ module Development.IDE.LSP.LanguageServer ( runLanguageServer , Log(..) - , logToPriority) where + ) where import Control.Concurrent.STM import Control.Monad.Extra @@ -32,11 +32,9 @@ import UnliftIO.Concurrent import UnliftIO.Directory import UnliftIO.Exception -import Development.IDE.Core.FileStore hiding (Log, - logToPriority) +import Development.IDE.Core.FileStore hiding (Log) import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.Shake hiding (Log, - logToPriority) +import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing import Development.IDE.LSP.HoverDefinition import Development.IDE.Types.Logger @@ -76,15 +74,6 @@ instance Pretty Log where "Cancelled request" <+> Prettyprinter.viaShow requestId LogSession log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogRegisteringIdeConfig{} -> Logger.Info - LogReactorThreadException{} -> Logger.Error - LogReactorMessageActionException{} -> Logger.Error - LogReactorThreadStopped -> Logger.Info - LogCancelledRequest{} -> Logger.Debug - LogSession log -> Session.logToPriority log - issueTrackerUrl :: T.Text issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues" @@ -93,7 +82,7 @@ newtype WithHieDbShield = WithHieDbShield WithHieDb runLanguageServer :: forall config. (Show config) - => Recorder Log + => Recorder (WithPriority Log) -> LSP.Options -> Handle -- input -> Handle -- output @@ -172,7 +161,7 @@ runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigur serverDefinition where - log :: Log -> IO () + log :: Logger.Priority -> Log -> IO () log = logWith recorder handleInit @@ -193,11 +182,11 @@ runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigur let initConfig = parseConfiguration params - log $ LogRegisteringIdeConfig initConfig + log Info $ LogRegisteringIdeConfig initConfig registerIdeConfiguration (shakeExtras ide) initConfig let handleServerException (Left e) = do - log $ LogReactorThreadException e + log Error $ LogReactorThreadException e sendErrorMessage e exitClientMsg handleServerException (Right _) = pure () @@ -210,7 +199,7 @@ runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigur ] exceptionInHandler e = do - log $ LogReactorMessageActionException e + log Error $ LogReactorMessageActionException e sendErrorMessage e checkCancelled _id act k = @@ -223,14 +212,14 @@ runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigur cancelOrRes <- race (waitForCancel _id) act case cancelOrRes of Left () -> do - log $ LogCancelledRequest _id + log Debug $ LogCancelledRequest _id k $ ResponseError RequestCancelled "" Nothing Right res -> pure res ) $ \(e :: SomeException) -> do exceptionInHandler e k $ ResponseError InternalError (T.pack $ show e) Nothing _ <- flip forkFinally handleServerException $ do - untilMVar lifetime $ runWithDb (cmap LogSession recorder) dbLoc $ \withHieDb hieChan -> do + untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb hieChan -> do putMVar dbMVar (WithHieDbShield withHieDb,hieChan) forever $ do msg <- readChan clientMsgChan @@ -239,7 +228,7 @@ runLanguageServer recorder options inH outH getHieDbLoc defaultConfig onConfigur case msg of ReactorNotification act -> handle exceptionInHandler act ReactorRequest _id act k -> void $ async $ checkCancelled _id act k - log LogReactorThreadStopped + log Info LogReactorThreadStopped pure $ Right (env,ide) diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index a750c33cdc..6973f33f95 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -10,7 +10,7 @@ module Development.IDE.LSP.Notifications ( whenUriFile , descriptor , Log(..) - , logToPriority) where + ) where import Language.LSP.Types import qualified Language.LSP.Types as LSP @@ -29,13 +29,10 @@ import Development.IDE.Core.FileStore (registerFileWatches, setSomethingModified) import qualified Development.IDE.Core.FileStore as FileStore import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.OfInterest hiding (Log, LogShake, - logToPriority) +import Development.IDE.Core.OfInterest hiding (Log, LogShake) import Development.IDE.Core.RuleTypes (GetClientSettings (..)) -import Development.IDE.Core.Service hiding (Log, LogShake, - logToPriority) -import Development.IDE.Core.Shake hiding (Log, Priority, - logToPriority) +import Development.IDE.Core.Service hiding (Log, LogShake) +import Development.IDE.Core.Shake hiding (Log, Priority) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Location import Development.IDE.Types.Logger @@ -53,15 +50,10 @@ instance Pretty Log where LogShake log -> pretty log LogFileStore log -> pretty log -logToPriority :: Log -> Priority -logToPriority = \case - LogShake log -> Shake.logToPriority log - LogFileStore log -> FileStore.logToPriority log - whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' -descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = mconcat [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \ide _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do @@ -70,7 +62,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHa -- We don't know if the file actually exists, or if the contents match those on disk -- For example, vscode restores previously unsaved contents on open addFileOfInterest ide file Modified{firstOpen=True} - setFileModified (cmap LogFileStore recorder) ide False file + setFileModified (cmapWithPrio LogFileStore recorder) ide False file logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri , mkPluginNotificationHandler LSP.STextDocumentDidChange $ @@ -78,14 +70,14 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHa atomically $ updatePositionMapping ide identifier changes whenUriFile _uri $ \file -> do addFileOfInterest ide file Modified{firstOpen=False} - setFileModified (cmap LogFileStore recorder) ide False file + setFileModified (cmapWithPrio LogFileStore recorder) ide False file logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri , mkPluginNotificationHandler LSP.STextDocumentDidSave $ \ide _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do addFileOfInterest ide file OnDisk - setFileModified (cmap LogFileStore recorder) ide True file + setFileModified (cmapWithPrio LogFileStore recorder) ide True file logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri , mkPluginNotificationHandler LSP.STextDocumentDidClose $ @@ -134,7 +126,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHa , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ -> do --------- Initialize Shake session -------------------------------------------------------------------- - liftIO $ shakeSessionInit (cmap LogShake recorder) ide + liftIO $ shakeSessionInit (cmapWithPrio LogShake recorder) ide --------- Set up file watchers ------------------------------------------------------------------------ opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 3346ad8a32..15057581e5 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -10,9 +10,8 @@ module Development.IDE.Main ,defaultMain ,testing ,Log(..) -,logToPriority) where -import Control.Concurrent.Extra (newLock, withLock, - withNumCapabilities) +) where +import Control.Concurrent.Extra (withNumCapabilities) import Control.Concurrent.STM.Stats (atomically, dumpSTMStats) import Control.Exception.Safe (SomeException, catchAny, @@ -28,7 +27,6 @@ import Data.List.Extra (intercalate, isPrefixOf, nub, nubOrd, partition) import Data.Maybe (catMaybes, isJust) import qualified Data.Text as T -import qualified Data.Text.IO as T import Data.Text.Lazy.Encoding (decodeUtf8) import qualified Data.Text.Lazy.IO as LT import Data.Typeable (typeOf) @@ -79,9 +77,10 @@ import Development.IDE.Session (SessionLoadingOptions, import qualified Development.IDE.Session as Session import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath') -import Development.IDE.Types.Logger (Logger (Logger), - Recorder, cmap, logWith) -import qualified Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Logger (Logger, + Priority (Info, Warning), + Recorder, WithPriority, + cmapWithPrio, logWith) import Development.IDE.Types.Options (IdeGhcSession, IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), IdeTesting (IdeTesting), @@ -172,22 +171,6 @@ instance Pretty Log where LogPluginHLS log -> pretty log LogRules log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogHeapStats log -> HeapStats.logToPriority log - LogLspStart -> Logger.Info - LogLspStartDuration{} -> Logger.Info - LogShouldRunSubset{} -> Logger.Debug - LogOnlyPartialGhc9Support -> Logger.Warning - LogSetInitialDynFlagsException{} -> Logger.Debug - LogService log -> Service.logToPriority log - LogShake log -> Shake.logToPriority log - LogGhcIde log -> GhcIde.logToPriority log - LogLanguageServer log -> LanguageServer.logToPriority log - LogSession log -> Session.logToPriority log - LogPluginHLS log -> PluginHLS.logToPriority log - LogRules log -> Rules.logToPriority log - data Command = Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures | Db {hieOptions :: HieDb.Options, hieCommand :: HieDb.Command} @@ -253,15 +236,15 @@ data Arguments = Arguments } -defaultArguments :: Recorder Log -> Logger -> Arguments +defaultArguments :: Recorder (WithPriority Log) -> Logger -> Arguments defaultArguments recorder logger = Arguments { argsProjectRoot = Nothing , argsOTMemoryProfiling = False , argCommand = LSP , argsLogger = pure logger - , argsRules = mainRule (cmap LogRules recorder) def >> action kick + , argsRules = mainRule (cmapWithPrio LogRules recorder) def >> action kick , argsGhcidePlugin = mempty - , argsHlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmap LogGhcIde recorder)) + , argsHlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde recorder)) , argsSessionLoadingOptions = def , argsIdeOptions = \config ghcSession -> (defaultIdeOptions ghcSession) { optCheckProject = pure $ checkProject config @@ -290,7 +273,7 @@ defaultArguments recorder logger = Arguments } -testing :: Recorder Log -> Logger -> Arguments +testing :: Recorder (WithPriority Log) -> Logger -> Arguments testing recorder logger = let arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = defaultArguments recorder logger @@ -309,10 +292,10 @@ testing recorder logger = } -defaultMain :: Recorder Log -> Arguments -> IO () -defaultMain recorder Arguments{..} = withHeapStats (cmap LogHeapStats recorder) fun +defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO () +defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun where - log :: Log -> IO () + log :: Priority -> Log -> IO () log = logWith recorder fun = do @@ -321,7 +304,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmap LogHeapStats recorder) logger <- argsLogger hSetBuffering stderr LineBuffering - let hlsPlugin = asGhcIdePlugin (cmap LogPluginHLS recorder) argsHlsPlugins + let hlsPlugin = asGhcIdePlugin (cmapWithPrio LogPluginHLS recorder) argsHlsPlugins hlsCommands = allLspCmdIds' pid argsHlsPlugins plugins = hlsPlugin <> argsGhcidePlugin options = argsLspOptions { LSP.executeCommandCommands = LSP.executeCommandCommands argsLspOptions <> Just hlsCommands } @@ -341,29 +324,29 @@ defaultMain recorder Arguments{..} = withHeapStats (cmap LogHeapStats recorder) LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins LSP -> withNumCapabilities (maybe (numProcessors `div` 2) fromIntegral argsThreads) $ do t <- offsetTime - log LogLspStart + log Info LogLspStart - runLanguageServer (cmap LogLanguageServer recorder) options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath withHieDb hieChan -> do + runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath withHieDb hieChan -> do traverse_ IO.setCurrentDirectory rootPath t <- t - log $ LogLspStartDuration t + log Info $ LogLspStartDuration t dir <- maybe IO.getCurrentDirectory return rootPath -- We want to set the global DynFlags right now, so that we can use -- `unsafeGlobalDynFlags` even before the project is configured _mlibdir <- - setInitialDynFlags (cmap LogSession recorder) dir argsSessionLoadingOptions + setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions -- TODO: should probably catch/log/rethrow at top level instead - `catchAny` (\e -> log (LogSetInitialDynFlagsException e) >> pure Nothing) + `catchAny` (\e -> log Debug (LogSetInitialDynFlagsException e) >> pure Nothing) - sessionLoader <- loadSessionWithOptions (cmap LogSession recorder) argsSessionLoadingOptions dir + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir config <- LSP.runLspT env LSP.getConfig let def_options = argsIdeOptions config sessionLoader -- disable runSubset if the client doesn't support watched files runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported - log $ LogShouldRunSubset runSubset + log Debug $ LogShouldRunSubset runSubset let options = def_options { optReportProgress = clientSupportsProgress caps @@ -373,9 +356,9 @@ defaultMain recorder Arguments{..} = withHeapStats (cmap LogHeapStats recorder) caps = LSP.resClientCapabilities env -- FIXME: Remove this after GHC 9 gets fully supported when (ghcVersion == GHC90) $ - log LogOnlyPartialGhc9Support + log Warning LogOnlyPartialGhc9Support initialise - (cmap LogService recorder) + (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules (Just env) @@ -389,7 +372,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmap LogHeapStats recorder) Check argFiles -> do dir <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc dir - runWithDb (cmap LogSession recorder) dbLoc $ \hiedb hieChan -> do + runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error hSetEncoding stdout utf8 hSetEncoding stderr utf8 @@ -411,15 +394,15 @@ defaultMain recorder Arguments{..} = withHeapStats (cmap LogHeapStats recorder) when (n > 0) $ putStrLn $ " (" ++ intercalate ", " (catMaybes ucradles) ++ ")" putStrLn "\nStep 3/4: Initializing the IDE" vfs <- makeVFSHandle - sessionLoader <- loadSessionWithOptions (cmap LogSession recorder) argsSessionLoadingOptions dir + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader options = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmap LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan - shakeSessionInit (cmap LogShake recorder) ide + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan + shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) putStrLn "\nStep 4/4: Type checking the files" @@ -454,26 +437,26 @@ defaultMain recorder Arguments{..} = withHeapStats (cmap LogHeapStats recorder) root <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc root hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc - mlibdir <- setInitialDynFlags (cmap LogSession recorder) root def + mlibdir <- setInitialDynFlags (cmapWithPrio LogSession recorder) root def rng <- newStdGen case mlibdir of Nothing -> exitWith $ ExitFailure 1 - Just libdir -> retryOnSqliteBusy (cmap LogSession recorder) rng (HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd) + Just libdir -> retryOnSqliteBusy (cmapWithPrio LogSession recorder) rng (HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd) Custom (IdeCommand c) -> do root <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc root - runWithDb (cmap LogSession recorder) dbLoc $ \hiedb hieChan -> do + runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do vfs <- makeVFSHandle - sessionLoader <- loadSessionWithOptions (cmap LogSession recorder) argsSessionLoadingOptions "." + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader options = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmap LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan - shakeSessionInit (cmap LogShake recorder) ide + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan + shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide diff --git a/ghcide/src/Development/IDE/Main/HeapStats.hs b/ghcide/src/Development/IDE/Main/HeapStats.hs index d3953435a4..b7037fc741 100644 --- a/ghcide/src/Development/IDE/Main/HeapStats.hs +++ b/ghcide/src/Development/IDE/Main/HeapStats.hs @@ -1,13 +1,13 @@ {-# LANGUAGE NumericUnderscores #-} -- | Logging utilities for reporting heap statistics -module Development.IDE.Main.HeapStats ( withHeapStats, Log(..), logToPriority ) where +module Development.IDE.Main.HeapStats ( withHeapStats, Log(..)) where import Control.Concurrent import Control.Concurrent.Async import Control.Monad import Data.Word -import Development.IDE.Types.Logger (Recorder, logWith) -import qualified Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Logger (Priority (Info), Recorder, + WithPriority, logWith) import GHC.Stats import Prettyprinter (Pretty (pretty), (<+>)) import qualified Prettyprinter @@ -38,18 +38,12 @@ instance Pretty Log where toFormattedMegabytes :: Word64 -> String toFormattedMegabytes b = printf "%.2fMB" (fromIntegral @Word64 @Double b / 1e6) -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogHeapStatsPeriod{} -> Logger.Info - LogHeapStatsDisabled -> Logger.Info - LogHeapStats{} -> Logger.Info - -- | Interval at which to report the latest heap statistics. heapStatsInterval :: Int heapStatsInterval = 60_000_000 -- 60s -- | Report the live bytes and heap size at the last major collection. -logHeapStats :: Recorder Log -> IO () +logHeapStats :: Recorder (WithPriority Log) -> IO () logHeapStats l = do stats <- getRTSStats -- live_bytes is the total amount of live memory in a program @@ -58,10 +52,10 @@ logHeapStats l = do -- heap_size is the total amount of memory the RTS is using -- this corresponds closer to OS memory usage heap_size = gcdetails_mem_in_use_bytes (gc stats) - logWith l $ LogHeapStats live_bytes heap_size + logWith l Info $ LogHeapStats live_bytes heap_size -- | An action which logs heap statistics at the 'heapStatsInterval' -heapStatsThread :: Recorder Log -> IO r +heapStatsThread :: Recorder (WithPriority Log) -> IO r heapStatsThread l = forever $ do threadDelay heapStatsInterval logHeapStats l @@ -69,13 +63,13 @@ heapStatsThread l = forever $ do -- | A helper function which lauches the 'heapStatsThread' and kills it -- appropiately when the inner action finishes. It also checks to see -- if `-T` is enabled. -withHeapStats :: Recorder Log -> IO r -> IO r +withHeapStats :: Recorder (WithPriority Log) -> IO r -> IO r withHeapStats l k = do enabled <- getRTSStatsEnabled if enabled then do - logWith l $ LogHeapStatsPeriod heapStatsInterval + logWith l Info $ LogHeapStatsPeriod heapStatsInterval withAsync (heapStatsThread l) (const k) else do - logWith l LogHeapStatsDisabled + logWith l Info LogHeapStatsDisabled k diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index e192f149a6..cdaa8b1a5d 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -5,7 +5,7 @@ module Development.IDE.Plugin.Completions ( descriptor , Log(..) - , logToPriority) where + ) where import Control.Concurrent.Async (concurrently) import Control.Concurrent.STM.Stats (readTVarIO) @@ -21,10 +21,8 @@ import qualified Data.Text as T import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service hiding (Log, - LogShake, - logToPriority) -import Development.IDE.Core.Shake hiding (Log, - logToPriority) + LogShake) +import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (rangeToSrcSpan) @@ -41,8 +39,9 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq (envPack hscEnv) import qualified Development.IDE.Types.KnownTargets as KT import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Recorder, cmap) -import qualified Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Logger (Recorder, + WithPriority, + cmapWithPrio) import GHC.Exts (fromList, toList) import Ide.Plugin.Config (Config) import Ide.Types @@ -58,11 +57,7 @@ instance Pretty Log where pretty = \case LogShake log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogShake log -> Shake.logToPriority log - -descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = produceCompletions recorder , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP @@ -70,9 +65,9 @@ descriptor recorder plId = (defaultPluginDescriptor plId) , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} } -produceCompletions :: Recorder Log -> Rules () +produceCompletions :: Recorder (WithPriority Log) -> Rules () produceCompletions recorder = do - define (cmap LogShake recorder) $ \LocalCompletions file -> do + define (cmapWithPrio LogShake recorder) $ \LocalCompletions file -> do let uri = fromNormalizedUri $ normalizedFilePathToUri file pm <- useWithStale GetParsedModule file case pm of @@ -80,7 +75,7 @@ produceCompletions recorder = do let cdata = localCompletionsForParsedModule uri pm return ([], Just cdata) _ -> return ([], Nothing) - define (cmap LogShake recorder) $ \NonLocalCompletions file -> do + define (cmapWithPrio LogShake recorder) $ \NonLocalCompletions file -> do -- For non local completions we avoid depending on the parsed module, -- synthetizing a fake module with an empty body from the buffer -- in the ModSummary, which preserves all the imports diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 76e8e906d1..053d1d4102 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -7,7 +7,7 @@ module Development.IDE.Plugin.HLS ( asGhcIdePlugin , Log(..) - , logToPriority) where + ) where import Control.Exception (SomeException) import Control.Monad @@ -22,14 +22,13 @@ import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) import qualified Data.Map as Map import Data.String import qualified Data.Text as T -import Development.IDE.Core.Shake hiding (Log, logToPriority) +import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing import Development.IDE.Graph (Rules) import Development.IDE.LSP.Server import Development.IDE.Plugin import qualified Development.IDE.Plugin as P import Development.IDE.Types.Logger -import qualified Development.IDE.Types.Logger as Logger import Ide.Plugin.Config import Ide.PluginUtils (getClientConfig) import Ide.Types as HLS @@ -54,12 +53,8 @@ instance Pretty Log where LogNoEnabledPlugins -> "extensibleNotificationPlugins no enabled plugins" -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogNoEnabledPlugins -> Logger.Info - -- | Map a set of plugins to the underlying ghcide engine. -asGhcIdePlugin :: Recorder Log -> IdePlugins IdeState -> Plugin Config +asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config asGhcIdePlugin recorder (IdePlugins ls) = mkPlugin rulesPlugins HLS.pluginRules <> mkPlugin executeCommandPlugins HLS.pluginCommands <> @@ -186,7 +181,7 @@ extensiblePlugins xs = mempty { P.pluginHandlers = handlers } pure $ Right $ combineResponses m config caps params xs -- --------------------------------------------------------------------- -extensibleNotificationPlugins :: Recorder Log -> [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config +extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginNotificationHandlers IdeState)] -> Plugin Config extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers } where IdeNotificationHandlers handlers' = foldMap bakePluginId xs @@ -201,7 +196,7 @@ extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers let fs = filter (\(pid,_) -> plcGlobalOn $ configForPlugin config pid) fs' case nonEmpty fs of Nothing -> do - logWith recorder LogNoEnabledPlugins + logWith recorder Info LogNoEnabledPlugins pure () Just fs -> do -- We run the notifications in order, so the core ghcide provider diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index e9b668cd8b..be5cd76441 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -6,7 +6,7 @@ module Development.IDE.Plugin.HLS.GhcIde ( descriptors , Log(..) - , logToPriority) where + ) where import Control.Monad.IO.Class import Development.IDE import Development.IDE.LSP.HoverDefinition @@ -15,7 +15,6 @@ import Development.IDE.LSP.Outline import qualified Development.IDE.Plugin.CodeAction as CodeAction import qualified Development.IDE.Plugin.Completions as Completions import qualified Development.IDE.Plugin.TypeLenses as TypeLenses -import qualified Development.IDE.Types.Logger as Logger import Ide.Types import Language.LSP.Server (LspM) import Language.LSP.Types @@ -34,22 +33,16 @@ instance Pretty Log where LogCompletions log -> pretty log LogTypeLenses log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogNotifications log -> Notifications.logToPriority log - LogCompletions log -> Completions.logToPriority log - LogTypeLenses log -> TypeLenses.logToPriority log - -descriptors :: Recorder Log -> [PluginDescriptor IdeState] +descriptors :: Recorder (WithPriority Log) -> [PluginDescriptor IdeState] descriptors recorder = [ descriptor "ghcide-hover-and-symbols", CodeAction.iePluginDescriptor "ghcide-code-actions-imports-exports", CodeAction.typeSigsPluginDescriptor "ghcide-code-actions-type-signatures", CodeAction.bindingsPluginDescriptor "ghcide-code-actions-bindings", CodeAction.fillHolePluginDescriptor "ghcide-code-actions-fill-holes", - Completions.descriptor (cmap LogCompletions recorder) "ghcide-completions", - TypeLenses.descriptor (cmap LogTypeLenses recorder) "ghcide-type-lenses", - Notifications.descriptor (cmap LogNotifications recorder) "ghcide-core" + Completions.descriptor (cmapWithPrio LogCompletions recorder) "ghcide-completions", + TypeLenses.descriptor (cmapWithPrio LogTypeLenses recorder) "ghcide-type-lenses", + Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core" ] -- --------------------------------------------------------------------- diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index a2414e58a4..b9ffab8eeb 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -11,7 +11,7 @@ module Development.IDE.Plugin.TypeLenses ( GetGlobalBindingTypeSigs (..), GlobalBindingTypeSigsResult (..), Log(..) -, logToPriority) where + ) where import Control.Concurrent.STM.Stats (atomically) import Control.DeepSeq (rwhnf) @@ -43,8 +43,8 @@ import Development.IDE.Types.Location (Position (Position, _chara Range (Range, _end, _start), toNormalizedFilePath', uriToFilePath') -import Development.IDE.Types.Logger (Recorder, cmap) -import qualified Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Logger (Recorder, WithPriority, + cmapWithPrio) import GHC.Generics (Generic) import Ide.Plugin.Config (Config) import Ide.Plugin.Properties @@ -79,14 +79,10 @@ instance Pretty Log where pretty = \case LogShake log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogShake log -> Shake.logToPriority log - typeLensCommandId :: T.Text typeLensCommandId = "typesignature.add" -descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider @@ -254,9 +250,9 @@ instance NFData GlobalBindingTypeSigsResult where type instance RuleResult GetGlobalBindingTypeSigs = GlobalBindingTypeSigsResult -rules :: Recorder Log -> Rules () +rules :: Recorder (WithPriority Log) -> Rules () rules recorder = do - define (cmap LogShake recorder) $ \GetGlobalBindingTypeSigs nfp -> do + define (cmapWithPrio LogShake recorder) $ \GetGlobalBindingTypeSigs nfp -> do tmr <- use TypeCheck nfp -- we need session here for tidying types hsc <- use GhcSession nfp diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index 3877274c3c..1d38645cb5 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -19,41 +19,37 @@ module Development.IDE.Types.Logger , withDefaultRecorder , makeDefaultStderrRecorder , priorityToHsLoggerPriority - , LoggingColumn(..)) where - -import Control.Concurrent (myThreadId) -import Control.Concurrent.Extra (Lock, newLock, withLock) -import Control.Exception (IOException) -import Control.Monad (forM_, when, (>=>)) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Functor.Contravariant (Contravariant (contramap)) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Data.Text.Prettyprint.Doc (Doc, Pretty (pretty), - defaultLayoutOptions, - layoutPretty, vcat, - (<+>)) -import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) -import Data.Time (defaultTimeLocale, - formatTime, - getCurrentTime) -import GHC.Stack (HasCallStack, - withFrozenCallStack) -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 -import UnliftIO (MonadUnliftIO, - displayException, - finally, try) + , LoggingColumn(..) + , cmapWithPrio + ) where + +import Control.Concurrent (myThreadId) +import Control.Concurrent.Extra (Lock, newLock, withLock) +import Control.Exception (IOException) +import Control.Monad (forM_, when, (>=>)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Functor.Contravariant (Contravariant (contramap)) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Time (defaultTimeLocale, formatTime, + getCurrentTime) +import GHC.Stack (HasCallStack, withFrozenCallStack) +import Prettyprinter (Doc, Pretty (pretty), + defaultLayoutOptions, layoutPretty, + vcat, (<+>)) +import Prettyprinter.Render.Text (renderStrict) +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 +import UnliftIO (MonadUnliftIO, displayException, + finally, try) data Priority -- Don't change the ordering of this type or you will mess up the Ord @@ -106,8 +102,8 @@ data WithPriority a = WithPriority { priority :: Priority, payload :: a } derivi data Recorder msg = Recorder { logger_ :: forall m. (HasCallStack, MonadIO m) => msg -> m () } -logWith :: (HasCallStack, MonadIO m) => Recorder msg -> msg -> m () -logWith recorder msg = withFrozenCallStack $ logger_ recorder msg +logWith :: (HasCallStack, MonadIO m) => Recorder (WithPriority msg) -> Priority -> msg -> m () +logWith recorder priority msg = withFrozenCallStack $ logger_ recorder (WithPriority priority msg) instance Semigroup (Recorder msg) where (<>) Recorder{ logger_ = logger_1 } Recorder{ logger_ = logger_2 } = @@ -127,6 +123,9 @@ instance Contravariant Recorder where cmap :: (a -> b) -> Recorder b -> Recorder a cmap = contramap +cmapWithPrio :: (a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a) +cmapWithPrio f = cmap (fmap f) + cmapIO :: (a -> IO b) -> Recorder b -> Recorder a cmapIO f Recorder{ logger_ } = Recorder @@ -164,7 +163,7 @@ withDefaultRecorder path columns hsLoggerMinPriority action = do Nothing -> do recorder <- makeHandleRecorder stderr let message = "No log file specified; using stderr." - logWith recorder (WithPriority Info message) + logWith recorder Info message action recorder Just path -> do fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode) @@ -173,7 +172,7 @@ withDefaultRecorder path columns hsLoggerMinPriority action = do recorder <- makeHandleRecorder stderr let exceptionMessage = pretty $ displayException e let message = vcat [exceptionMessage, "Couldn't open log file" <+> pretty path <> "; falling back to stderr."] - logWith recorder (WithPriority Warning message) + logWith recorder Warning message action recorder Right fileHandle -> finally (makeHandleRecorder fileHandle >>= action) (liftIO $ hClose fileHandle) diff --git a/ghcide/test/exe/HieDbRetry.hs b/ghcide/test/exe/HieDbRetry.hs index f76da0cb44..c51c8bbebc 100644 --- a/ghcide/test/exe/HieDbRetry.hs +++ b/ghcide/test/exe/HieDbRetry.hs @@ -12,7 +12,8 @@ import Development.IDE.Session (retryOnException, retryOnSqliteBusy) import qualified Development.IDE.Session as Session import Development.IDE.Types.Logger (Recorder (Recorder, logger_), - cmap) + WithPriority (WithPriority, payload), + cmapWithPrio) import qualified System.Random as Random import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) @@ -21,17 +22,17 @@ data Log = LogSession Session.Log deriving Show -makeLogger :: Var [Log] -> Recorder Log +makeLogger :: Var [Log] -> Recorder (WithPriority Log) makeLogger msgsVar = Recorder { - logger_ = \msg -> liftIO $ modifyVar msgsVar (\msgs -> pure (msg : msgs, ())) + logger_ = \WithPriority{ payload = msg } -> liftIO $ modifyVar msgsVar (\msgs -> pure (msg : msgs, ())) } rng :: Random.StdGen rng = Random.mkStdGen 0 -retryOnSqliteBusyForTest :: Recorder Log -> Int -> IO a -> IO a -retryOnSqliteBusyForTest recorder maxRetryCount = retryOnException isErrorBusy (cmap LogSession recorder) 1 1 maxRetryCount rng +retryOnSqliteBusyForTest :: Recorder (WithPriority Log) -> Int -> IO a -> IO a +retryOnSqliteBusyForTest recorder maxRetryCount = retryOnException isErrorBusy (cmapWithPrio LogSession recorder) 1 1 maxRetryCount rng isErrorBusy :: SQLite.SQLError -> Maybe SQLite.SQLError isErrorBusy e @@ -122,7 +123,7 @@ tests = testGroup "RetryHieDb" let maxRetryCount = 6 let logger = makeLogger logMsgsVar - result <- tryJust isErrorBusy (retryOnException isErrorBusy (cmap LogSession logger) maxDelay baseDelay maxRetryCount rng (throwIO errorBusy)) + result <- tryJust isErrorBusy (retryOnException isErrorBusy (cmapWithPrio LogSession logger) maxDelay baseDelay maxRetryCount rng (throwIO errorBusy)) case result of Left _ -> do diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 5cdff4adf5..ab7a5a8176 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -119,7 +119,7 @@ import Test.Tasty.QuickCheck import Text.Printf (printf) import Text.Regex.TDFA ((=~)) import qualified HieDbRetry -import Development.IDE.Types.Logger (WithPriority(WithPriority, priority), Priority (Debug), cmap, Recorder (Recorder, logger_), makeDefaultStderrRecorder, cfilter, LoggingColumn (PriorityColumn, DataColumn), Logger (Logger)) +import Development.IDE.Types.Logger (WithPriority(WithPriority, priority), Priority (Debug), cmapWithPrio, Recorder (Recorder, logger_), makeDefaultStderrRecorder, cfilter, LoggingColumn (PriorityColumn, DataColumn), Logger (Logger)) import Data.Function ((&)) import qualified System.Log as HsLogger import Prettyprinter (Doc, Pretty (pretty)) @@ -134,13 +134,8 @@ instance Pretty Log where LogGhcIde log -> pretty log LogIDEMain log -> pretty log -logToPriority :: Log -> Priority -logToPriority = \case - LogGhcIde log -> Ghcide.logToPriority log - LogIDEMain log -> IDE.logToPriority log - -logToDocWithPriority :: Log -> WithPriority (Doc a) -logToDocWithPriority log = WithPriority (logToPriority log) (pretty log) +logToDoc :: Log -> Doc a +logToDoc = pretty -- | Wait for the next progress begin step waitForProgressBegin :: Session () @@ -180,7 +175,7 @@ main = do let logger = Logger $ \p m -> logger_ (WithPriority p (pretty m)) let recorder = docWithFilteredPriorityRecorder - & cmap logToDocWithPriority + & cmapWithPrio logToDoc -- We mess with env vars so run single-threaded. defaultMainWithRerun $ testGroup "ghcide" @@ -6180,7 +6175,7 @@ findCodeActions' op errMsg doc range expectedTitles = do findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction findCodeAction doc range t = head <$> findCodeActions doc range [t] -unitTests :: Recorder Log -> Logger -> TestTree +unitTests :: Recorder (WithPriority Log) -> Logger -> TestTree unitTests recorder logger = do testGroup "Unit" [ testCase "empty file path does NOT work with the empty String literal" $ @@ -6221,9 +6216,9 @@ unitTests recorder logger = do ] } | i <- [(1::Int)..20] - ] ++ Ghcide.descriptors (cmap LogGhcIde recorder) + ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder) - testIde recorder (IDE.testing (cmap LogIDEMain recorder) logger){IDE.argsHlsPlugins = plugins} $ do + testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger){IDE.argsHlsPlugins = plugins} $ do _ <- createDoc "haskell" "A.hs" "module A where" waitForProgressDone actualOrder <- liftIO $ readIORef orderRef @@ -6321,14 +6316,14 @@ findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do if t /= t' then return delay_us else findResolution_us (delay_us * 10) -testIde :: Recorder Log -> IDE.Arguments -> Session () -> IO () +testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () testIde recorder arguments session = do config <- getConfigFromEnv cwd <- getCurrentDirectory (hInRead, hInWrite) <- createPipe (hOutRead, hOutWrite) <- createPipe let projDir = "." - let server = IDE.defaultMain (cmap LogIDEMain recorder) arguments + let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments { IDE.argsHandleIn = pure hInRead , IDE.argsHandleOut = pure hOutWrite } diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index b9f7587cc1..e2a0c86f2c 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -53,7 +53,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Development.IDE (IdeState) import Development.IDE.Graph (ShakeOptions (shakeThreads)) -import Development.IDE.Main hiding (Log, logToPriority) +import Development.IDE.Main hiding (Log) import qualified Development.IDE.Main as Ghcide import qualified Development.IDE.Main as IDEMain import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), @@ -63,7 +63,7 @@ import Development.IDE.Types.Logger (Logger (Logger), Priority (Debug), Recorder (Recorder, logger_), WithPriority (WithPriority, priority), - cfilter, cmap, + cfilter, cmapWithPrio, makeDefaultStderrRecorder) import Development.IDE.Types.Options import GHC.IO.Handle @@ -100,12 +100,8 @@ instance Pretty Log where pretty = \case LogIDEMain log -> pretty log -logToPriority :: Log -> Priority -logToPriority = \case - LogIDEMain log -> IDEMain.logToPriority log - -logToDocWithPriority :: Log -> WithPriority (Doc a) -logToDocWithPriority log = WithPriority (logToPriority log) (pretty log) +logToDoc :: Log -> Doc a +logToDoc = pretty -- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes defaultTestRunner :: TestTree -> IO () @@ -205,9 +201,9 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre logger = Logger $ \p m -> logger_ (WithPriority p (pretty m)) - recorder = cmap logToDocWithPriority docWithFilteredPriorityRecorder + recorder = cmapWithPrio logToDoc docWithFilteredPriorityRecorder - arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments (cmap LogIDEMain recorder) logger + arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments (cmapWithPrio LogIDEMain recorder) logger hlsPlugins = idePluginsToPluginDesc argsHlsPlugins @@ -224,7 +220,7 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre server <- async $ Ghcide.defaultMain - (cmap LogIDEMain recorder) + (cmapWithPrio LogIDEMain recorder) arguments { argsHandleIn = pure inR , argsHandleOut = pure outW diff --git a/plugins/default/src/Ide/Plugin/Example.hs b/plugins/default/src/Ide/Plugin/Example.hs index 31485d0379..166fedf911 100644 --- a/plugins/default/src/Ide/Plugin/Example.hs +++ b/plugins/default/src/Ide/Plugin/Example.hs @@ -14,32 +14,31 @@ module Ide.Plugin.Example ( descriptor , Log(..) - , logToPriority) where + ) where import Control.Concurrent.STM -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData) import Control.Monad.IO.Class import Control.Monad.Trans.Maybe import Data.Aeson import Data.Functor -import qualified Data.HashMap.Strict as Map +import qualified Data.HashMap.Strict as Map import Data.Hashable -import qualified Data.Text as T +import qualified Data.Text as T import Data.Typeable -import Development.IDE as D -import Development.IDE.Core.Shake (getDiagnostics, - getHiddenDiagnostics) -import qualified Development.IDE.Core.Shake as Shake +import Development.IDE as D +import Development.IDE.Core.Shake (getDiagnostics, + getHiddenDiagnostics) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat -import qualified Development.IDE.Types.Logger as Logger import GHC.Generics import Ide.PluginUtils import Ide.Types import Language.LSP.Server import Language.LSP.Types -import Options.Applicative (ParserInfo, info) -import Prettyprinter (Pretty (pretty)) -import Text.Regex.TDFA.Text () +import Options.Applicative (ParserInfo, info) +import Prettyprinter (Pretty (pretty)) +import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- @@ -49,11 +48,7 @@ instance Pretty Log where pretty = \case LogShake log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogShake log -> Shake.logToPriority log - -descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = exampleRules recorder , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] @@ -89,9 +84,9 @@ instance NFData Example type instance RuleResult Example = () -exampleRules :: Recorder Log -> Rules () +exampleRules :: Recorder (WithPriority Log) -> Rules () exampleRules recorder = do - define (cmap LogShake recorder) $ \Example file -> do + define (cmapWithPrio LogShake recorder) $ \Example file -> do _pm <- getParsedModule file let diag = mkDiag file "example" DsError (Range (Position 0 0) (Position 1 0)) "example diagnostic, hello world" return ([diag], Just ()) diff --git a/plugins/default/src/Ide/Plugin/Example2.hs b/plugins/default/src/Ide/Plugin/Example2.hs index 647dfb45a6..3b2293855d 100644 --- a/plugins/default/src/Ide/Plugin/Example2.hs +++ b/plugins/default/src/Ide/Plugin/Example2.hs @@ -14,29 +14,28 @@ module Ide.Plugin.Example2 ( descriptor , Log(..) - , logToPriority) where + ) where import Control.Concurrent.STM -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData) import Control.Monad.IO.Class import Control.Monad.Trans.Maybe import Data.Aeson import Data.Functor -import qualified Data.HashMap.Strict as Map +import qualified Data.HashMap.Strict as Map import Data.Hashable -import qualified Data.Text as T +import qualified Data.Text as T import Data.Typeable -import Development.IDE as D -import Development.IDE.Core.Shake hiding (Log, logToPriority) -import qualified Development.IDE.Core.Shake as Shake -import qualified Development.IDE.Types.Logger as Logger +import Development.IDE as D +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import GHC.Generics import Ide.PluginUtils import Ide.Types import Language.LSP.Server import Language.LSP.Types -import Prettyprinter (Pretty (pretty)) -import Text.Regex.TDFA.Text () +import Prettyprinter (Pretty (pretty)) +import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- @@ -46,11 +45,7 @@ instance Pretty Log where pretty = \case LogShake log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogShake log -> Shake.logToPriority log - -descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = exampleRules recorder , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] @@ -81,9 +76,9 @@ instance NFData Example2 type instance RuleResult Example2 = () -exampleRules :: Recorder Log -> Rules () +exampleRules :: Recorder (WithPriority Log) -> Rules () exampleRules recorder = do - define (cmap LogShake recorder) $ \Example2 file -> do + define (cmapWithPrio LogShake recorder) $ \Example2 file -> do _pm <- getParsedModule file let diag = mkDiag file "example2" DsError (Range (Position 0 0) (Position 1 0)) "example2 diagnostic, hello world" return ([diag], Just ()) diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs index e774f58eb6..422ed06e0f 100644 --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Ide.Plugin.AlternateNumberFormat (descriptor, Log(..), logToPriority) where +module Ide.Plugin.AlternateNumberFormat (descriptor, Log(..)) where import Control.Lens ((^.)) import Control.Monad.Except (ExceptT, MonadIO, liftIO) @@ -37,11 +37,7 @@ instance Pretty Log where pretty = \case LogShake log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogShake log -> Shake.logToPriority log - -descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionHandler , pluginRules = collectLiteralsRule recorder @@ -65,8 +61,8 @@ instance Show CollectLiteralsResult where instance NFData CollectLiteralsResult -collectLiteralsRule :: Recorder Log -> Rules () -collectLiteralsRule recorder = define (cmap LogShake recorder) $ \CollectLiterals nfp -> do +collectLiteralsRule :: Recorder (WithPriority Log) -> Rules () +collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectLiterals nfp -> do pm <- use GetParsedModule nfp -- get the current extensions active and transform them into FormatTypes let fmts = getFormatTypes <$> pm diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs index 11b6d2f489..8ad2feb017 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs @@ -8,12 +8,12 @@ Eval Plugin entry point. -} module Ide.Plugin.Eval ( descriptor, - Log(..), - logToPriority) where + Log(..) + ) where import Development.IDE (IdeState) -import Development.IDE.Types.Logger (Recorder, cmap) -import qualified Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Logger (Recorder, WithPriority, + cmapWithPrio) import qualified Ide.Plugin.Eval.CodeLens as CL import Ide.Plugin.Eval.Config import Ide.Plugin.Eval.Rules (rules) @@ -32,17 +32,13 @@ instance Pretty Log where pretty = \case LogEvalRules log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogEvalRules log -> EvalRules.logToPriority log - -- |Plugin descriptor -descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeLens CL.codeLens , pluginCommands = [CL.evalCommand plId] - , pluginRules = rules (cmap LogEvalRules recorder) + , pluginRules = rules (cmapWithPrio LogEvalRules recorder) , pluginConfigDescriptor = defaultConfigDescriptor { configCustomConfig = mkCustomConfig properties } diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs index 78bc45d8ba..ca1e7bc28f 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -5,7 +5,7 @@ -- To avoid warning "Pattern match has inaccessible right hand side" {-# OPTIONS_GHC -Wno-overlapping-patterns #-} -module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, Log, logToPriority) where +module Ide.Plugin.Eval.Rules (GetEvalComments(..), rules,queueForEvaluation, Log) where import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.HashSet (HashSet) @@ -38,8 +38,8 @@ import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat as SrcLoc import qualified Development.IDE.GHC.Compat.Util as FastString import Development.IDE.Graph (alwaysRerun) -import Development.IDE.Types.Logger (Recorder, cmap) -import qualified Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Logger (Recorder, WithPriority, + cmapWithPrio) import Ide.Plugin.Eval.Types import Prettyprinter (Pretty (pretty)) @@ -49,11 +49,7 @@ instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogShake log -> Shake.logToPriority log - -rules :: Recorder Log -> Rules () +rules :: Recorder (WithPriority Log) -> Rules () rules recorder = do evalParsedModuleRule recorder redefinedNeedsCompilation recorder @@ -80,8 +76,8 @@ pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing #endif -evalParsedModuleRule :: Recorder Log -> Rules () -evalParsedModuleRule recorder = defineEarlyCutoff (cmap LogShake recorder) $ RuleNoDiagnostics $ \GetEvalComments nfp -> do +evalParsedModuleRule :: Recorder (WithPriority Log) -> Rules () +evalParsedModuleRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetEvalComments nfp -> do (ParsedModule{..}, posMap) <- useWithStale_ GetParsedModuleWithComments nfp let comments = foldMap (\case L (RealSrcSpanAlready real) bdy @@ -112,8 +108,8 @@ evalParsedModuleRule recorder = defineEarlyCutoff (cmap LogShake recorder) $ Rul -- This will ensure that the modules are loaded with linkables -- and the interactive session won't try to compile them on the fly, -- leading to much better performance of the evaluate code lens -redefinedNeedsCompilation :: Recorder Log -> Rules () -redefinedNeedsCompilation recorder = defineEarlyCutoff (cmap LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do +redefinedNeedsCompilation :: Recorder (WithPriority Log) -> Rules () +redefinedNeedsCompilation recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do alwaysRerun EvaluatingVar var <- getIdeGlobalAction diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 52e158a43d..31d7c7d5e7 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -15,7 +15,6 @@ module Ide.Plugin.ExplicitImports , extractMinimalImports , within , Log(..) - , logToPriority ) where import Control.DeepSeq @@ -54,18 +53,14 @@ instance Pretty Log where pretty = \case LogShake log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogShake log -> Shake.logToPriority log - -- | The "main" function of a plugin -descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder = -- (almost) no one wants to see an explicit import list for Prelude descriptorForModules recorder (/= moduleName pRELUDE) descriptorForModules - :: Recorder Log + :: Recorder (WithPriority Log) -> (ModuleName -> Bool) -- ^ Predicate to select modules that will be annotated -> PluginId @@ -204,8 +199,8 @@ exportedModuleStrings ParsedModule{pm_parsed_source = L _ HsModule{..}} = map prettyPrint exports exportedModuleStrings _ = [] -minimalImportsRule :: Recorder Log -> Rules () -minimalImportsRule recorder = define (cmap LogShake recorder) $ \MinimalImports nfp -> do +minimalImportsRule :: Recorder (WithPriority Log) -> Rules () +minimalImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \MinimalImports nfp -> do -- Get the typechecking artifacts from the module tmr <- use TypeCheck nfp -- We also need a GHC session with all the dependencies diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index daccd3a93c..cf4795080b 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -28,7 +28,7 @@ module Ide.Plugin.Hlint ( descriptor , Log(..) - , logToPriority) where + ) where import Control.Arrow ((&&&)) import Control.Concurrent.STM import Control.DeepSeq @@ -119,7 +119,6 @@ import Development.IDE.Spans.Pragmas (LineSplitTe lineSplitInsertTextEdit, lineSplitTextEdits, nextPragmaLine) -import qualified Development.IDE.Types.Logger as Logger import GHC.Generics (Generic) import Prettyprinter (Pretty (pretty)) import System.Environment (setEnv, @@ -135,10 +134,6 @@ instance Pretty Log where pretty = \case LogShake log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogShake log -> Shake.logToPriority log - #ifdef HLINT_ON_GHC_LIB -- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib pattern RealSrcSpan :: GHC.RealSrcSpan -> Maybe BufSpan -> GHC.SrcSpan @@ -150,7 +145,7 @@ pattern RealSrcSpan x y <- ((,Nothing) -> (GHC.RealSrcSpan x, y)) {-# COMPLETE RealSrcSpan, UnhelpfulSpan #-} #endif -descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = rules recorder plId , pluginCommands = @@ -180,15 +175,15 @@ type instance RuleResult GetHlintDiagnostics = () -- | - `getIdeas` -> `getFileContents` if the hls ghc does not match the hlint default ghc -- | - The client settings have changed, to honour the `hlintOn` setting, via `getClientConfigAction` -- | - The hlint specific settings have changed, via `getHlintSettingsRule` -rules :: Recorder Log -> PluginId -> Rules () +rules :: Recorder (WithPriority Log) -> PluginId -> Rules () rules recorder plugin = do - define (cmap LogShake recorder) $ \GetHlintDiagnostics file -> do + define (cmapWithPrio LogShake recorder) $ \GetHlintDiagnostics file -> do config <- getClientConfigAction def let hlintOn = pluginEnabledConfig plcDiagnosticsOn plugin config ideas <- if hlintOn then getIdeas file else return (Right []) return (diagnostics file ideas, Just ()) - defineNoFile (cmap LogShake recorder) $ \GetHlintSettings -> do + defineNoFile (cmapWithPrio LogShake recorder) $ \GetHlintSettings -> do (Config flags) <- getHlintConfig plugin liftIO $ argsSettings flags @@ -536,7 +531,7 @@ applyHint ide nfp mhint = liftIO $ logm $ "applyHint:apply=" ++ show commands let fp = fromNormalizedFilePath nfp (_, mbOldContent) <- liftIO $ runAction' $ getFileContents nfp - oldContent <- maybe (liftIO $ fmap T.decodeUtf8 $ BS.readFile fp) return mbOldContent + oldContent <- maybe (liftIO $ fmap T.decodeUtf8 (BS.readFile fp)) return mbOldContent modsum <- liftIO $ runAction' $ use_ GetModSummary nfp let dflags = ms_hspp_opts $ msrModSummary modsum -- Setting a environment variable with the libdir used by ghc-exactprint. diff --git a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs index 35c69e61cb..c862a25aa6 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -8,7 +8,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -module Ide.Plugin.RefineImports (descriptor, Log(..), logToPriority) where +module Ide.Plugin.RefineImports (descriptor, Log(..)) where import Control.Arrow (Arrow (second)) import Control.DeepSeq (rwhnf) @@ -56,12 +56,8 @@ instance Pretty Log where pretty = \case LogShake log -> pretty log -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogShake log -> Shake.logToPriority log - -- | plugin declaration -descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginCommands = [refineImportCommand] , pluginRules = refineImportsRule recorder @@ -177,8 +173,8 @@ newtype RefineImportsResult = RefineImportsResult instance Show RefineImportsResult where show _ = "" instance NFData RefineImportsResult where rnf = rwhnf -refineImportsRule :: Recorder Log -> Rules () -refineImportsRule recorder = define (cmap LogShake recorder) $ \RefineImports nfp -> do +refineImportsRule :: Recorder (WithPriority Log) -> Rules () +refineImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \RefineImports nfp -> do -- Get the typechecking artifacts from the module tmr <- use TypeCheck nfp -- We also need a GHC session with all the dependencies diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs index dcc6d30b15..cf326ee653 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs @@ -1,5 +1,5 @@ -- | A plugin that uses tactics to synthesize code -module Ide.Plugin.Tactic (descriptor, Log(..), logToPriority) where +module Ide.Plugin.Tactic (descriptor, Log(..)) where import Wingman.Plugin diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index 8cdbbac417..0f6bfcb137 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -36,7 +36,7 @@ import Development.IDE.Core.UseStale import Development.IDE.GHC.Compat hiding (empty) import qualified Development.IDE.GHC.Compat.Util as FastString import Development.IDE.GHC.Error (realSrcSpanToRange) -import Development.IDE.GHC.ExactPrint hiding (Log) +import Development.IDE.GHC.ExactPrint hiding (LogShake, Log) import Development.IDE.Graph (Action, RuleResult, Rules, action) import Development.IDE.Graph.Classes (Hashable, NFData) import Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings) @@ -63,10 +63,9 @@ import Wingman.Judgements.Theta import Wingman.Range import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax) import Wingman.Types -import Development.IDE.Types.Logger (Recorder, cmap) +import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority) import qualified Development.IDE.Core.Shake as Shake import Prettyprinter (Pretty (pretty)) -import qualified Development.IDE.Types.Logger as Logger newtype Log @@ -77,10 +76,6 @@ instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogShake log -> Shake.logToPriority log - tacticDesc :: T.Text -> T.Text tacticDesc name = "fill the hole using the " <> name <> " tactic" @@ -566,9 +561,9 @@ instance NFData GetMetaprograms type instance RuleResult GetMetaprograms = [(Tracked 'Current RealSrcSpan, T.Text)] -wingmanRules :: Recorder Log -> PluginId -> Rules () +wingmanRules :: Recorder (WithPriority Log) -> PluginId -> Rules () wingmanRules recorder plId = do - define (cmap LogShake recorder) $ \WriteDiagnostics nfp -> + define (cmapWithPrio LogShake recorder) $ \WriteDiagnostics nfp -> usePropertyAction #hole_severity plId properties >>= \case Nothing -> pure (mempty, Just ()) Just severity -> @@ -601,7 +596,7 @@ wingmanRules recorder plId = do , Just () ) - defineNoDiagnostics (cmap LogShake recorder) $ \GetMetaprograms nfp -> do + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetMetaprograms nfp -> do TrackedStale tcg tcg_map <- fmap tmrTypechecked <$> useWithStale_ TypeCheck nfp let scrutinees = traverse (metaprogramQ . tcg_binds) tcg return $ Just $ flip mapMaybe scrutinees $ \aged@(unTrack -> (ss, program)) -> do diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index 63ba9fec02..cfab420268 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -13,9 +13,8 @@ import Wingman.LanguageServer hiding (Log) import qualified Wingman.LanguageServer as WingmanLanguageServer import Wingman.LanguageServer.Metaprogram (hoverProvider) import Wingman.StaticPlugin -import Development.IDE.Types.Logger (Recorder, cmap) +import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority) import Prettyprinter (Pretty (pretty)) -import qualified Development.IDE.Types.Logger as Logger newtype Log = LogWingmanLanguageServer WingmanLanguageServer.Log @@ -24,12 +23,8 @@ newtype Log instance Pretty Log where pretty = \case LogWingmanLanguageServer log -> pretty log - -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogWingmanLanguageServer log -> WingmanLanguageServer.logToPriority log -descriptor :: Recorder Log -> PluginId -> PluginDescriptor IdeState +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = installInteractions ( emptyCaseInteraction @@ -37,7 +32,7 @@ descriptor recorder plId ) $ (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentHover hoverProvider - , pluginRules = wingmanRules (cmap LogWingmanLanguageServer recorder) plId + , pluginRules = wingmanRules (cmapWithPrio LogWingmanLanguageServer recorder) plId , pluginConfigDescriptor = defaultConfigDescriptor { configCustomConfig = mkCustomConfig properties diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index eae58b8978..70a911cbac 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -2,14 +2,13 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -module Ide.Main(defaultMain, runLspMode, Log(..), logToPriority) where +module Ide.Main(defaultMain, runLspMode, Log(..)) where import Control.Monad.Extra import qualified Data.Aeson.Encode.Pretty as A @@ -26,7 +25,6 @@ import Development.IDE.Main (isLSP) import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Session as Session import Development.IDE.Types.Logger as G -import qualified Development.IDE.Types.Logger as Logger import qualified Development.IDE.Types.Options as Ghcide import Ide.Arguments import Ide.Logger @@ -58,14 +56,7 @@ instance Pretty Log where , "PluginIds:" <+> pretty (coerce @_ @[Text] pluginIds) ] LogIDEMain iDEMainLog -> pretty iDEMainLog -logToPriority :: Log -> Logger.Priority -logToPriority = \case - LogVersion{} -> Logger.Info - LogDirectory{} -> Logger.Info - LogLspStart{} -> Logger.Info - LogIDEMain log -> IDEMain.logToPriority log - -defaultMain :: Recorder Log -> Arguments -> IdePlugins IdeState -> IO () +defaultMain :: Recorder (WithPriority Log) -> Arguments -> IdePlugins IdeState -> IO () defaultMain recorder args idePlugins = do -- WARNING: If you write to stdout before runLanguageServer -- then the language server will not work @@ -98,7 +89,7 @@ defaultMain recorder args idePlugins = do Ghcide ghcideArgs -> do {- see WARNING above -} - logWith recorder $ LogVersion hlsVer + logWith recorder Info $ LogVersion hlsVer runLspMode recorder ghcideArgs idePlugins VSCodeExtensionSchemaMode -> do @@ -120,17 +111,17 @@ hlsLogger = G.Logger $ \pri txt -> -- --------------------------------------------------------------------- -runLspMode :: Recorder Log -> GhcideArguments -> IdePlugins IdeState -> IO () +runLspMode :: Recorder (WithPriority Log) -> GhcideArguments -> IdePlugins IdeState -> IO () runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLogger $ \telemetryLogger -> do let log = logWith recorder whenJust argsCwd IO.setCurrentDirectory dir <- IO.getCurrentDirectory - log $ LogDirectory dir + log Info $ LogDirectory dir when (isLSP argsCommand) $ do - log $ LogLspStart ghcideArgs (map fst $ ipMap idePlugins) + log Info $ LogLspStart ghcideArgs (map fst $ ipMap idePlugins) - IDEMain.defaultMain (cmap LogIDEMain recorder) (IDEMain.defaultArguments (cmap LogIDEMain recorder) hlsLogger) + IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) (IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) hlsLogger) { IDEMain.argCommand = argsCommand , IDEMain.argsHlsPlugins = idePlugins , IDEMain.argsLogger = pure hlsLogger <> pure telemetryLogger From 6666995919a47f52300f74672b48ef5f0e75696f Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Fri, 4 Feb 2022 19:29:44 -0500 Subject: [PATCH 37/43] remove useless hiding import list, add comments to default recorder makers --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- ghcide/src/Development/IDE/Types/Logger.hs | 8 ++++++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index d7538d292f..dcefdffad2 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -52,7 +52,7 @@ import qualified Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile, TargetModule, Var, Warning) -import qualified Development.IDE.GHC.Compat.Core as GHC hiding (Warning) +import qualified Development.IDE.GHC.Compat.Core as GHC import Development.IDE.GHC.Compat.Env hiding (Logger) import Development.IDE.GHC.Compat.Units (UnitId) import Development.IDE.GHC.Util diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index 1d38645cb5..d71fc84085 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -152,9 +152,13 @@ makeDefaultStderrRecorder columns hsLoggerMinPriority = do withDefaultRecorder :: MonadUnliftIO m => Maybe FilePath + -- ^ log file path -> Maybe [LoggingColumn] + -- ^ logging columns to display -> HsLogger.Priority + -- ^ min priority for hslogger -> (Recorder (WithPriority (Doc d)) -> m a) + -- ^ action given a recorder -> m a withDefaultRecorder path columns hsLoggerMinPriority action = do lock <- liftIO newLock @@ -179,9 +183,13 @@ withDefaultRecorder path columns hsLoggerMinPriority action = do makeDefaultHandleRecorder :: MonadIO m => Maybe [LoggingColumn] + -- ^ built-in logging columns to display -> HsLogger.Priority + -- ^ min priority for hslogger -> Lock + -- ^ lock to take when outputting to handle -> Handle + -- ^ handle to output to -> m (Recorder (WithPriority (Doc a))) makeDefaultHandleRecorder columns hsLoggerMinPriority lock handle = do let Recorder{ logger_ } = textHandleRecorder handle From 52c5a55b7bd58364fb571ba0549725377d486067 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Sat, 5 Feb 2022 14:19:41 -0500 Subject: [PATCH 38/43] make cradleToOptsAndLibDir take concrete cradle to remove existential type var in Log constructor --- ghcide/session-loader/Development/IDE/Session.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index dcefdffad2..0090fa74c2 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -115,7 +115,7 @@ data Log | LogCradlePath !FilePath | LogCradleNotFound !FilePath | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath)) - | forall a. Show a => LogCradle !(Cradle a) + | LogCradle !(Cradle Void) | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) deriving instance Show Log @@ -687,7 +687,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- | Run the specific cradle on a specific FilePath via hie-bios. -- This then builds dependencies or whatever based on the cradle, gets the -- GHC options/dynflags needed for the session and the GHC library directory -cradleToOptsAndLibDir :: Show a => Recorder (WithPriority Log) -> Cradle a -> FilePath +cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> Cradle Void -> FilePath -> IO (Either [CradleError] (ComponentOptions, FilePath)) cradleToOptsAndLibDir recorder cradle file = do -- Start off by getting the session options From cc7dd2b96a888666dfc064bcc6112fee50302a5a Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Sat, 5 Feb 2022 17:33:47 -0500 Subject: [PATCH 39/43] Types.Logger now re-exports prettyprinter, remove unused dependencies on prettyprinter and hslogger --- exe/Main.hs | 6 +-- exe/Plugins.hs | 5 +- ghcide/exe/Main.hs | 15 +++--- ghcide/ghcide.cabal | 4 -- .../session-loader/Development/IDE/Session.hs | 46 +++++++++---------- ghcide/src/Development/IDE/Core/FileExists.hs | 4 +- ghcide/src/Development/IDE/Core/FileStore.hs | 13 +++--- ghcide/src/Development/IDE/Core/OfInterest.hs | 7 ++- ghcide/src/Development/IDE/Core/Rules.hs | 12 ++--- ghcide/src/Development/IDE/Core/Service.hs | 8 +++- ghcide/src/Development/IDE/Core/Shake.hs | 8 ++-- ghcide/src/Development/IDE/GHC/ExactPrint.hs | 4 +- .../src/Development/IDE/LSP/LanguageServer.hs | 10 ++-- .../src/Development/IDE/LSP/Notifications.hs | 1 - ghcide/src/Development/IDE/Main.hs | 9 ++-- ghcide/src/Development/IDE/Main/HeapStats.hs | 9 ++-- .../src/Development/IDE/Plugin/Completions.hs | 4 +- ghcide/src/Development/IDE/Plugin/HLS.hs | 1 - .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 1 - .../src/Development/IDE/Plugin/TypeLenses.hs | 4 +- ghcide/src/Development/IDE/Types/Logger.hs | 27 ++++++----- ghcide/test/exe/Main.hs | 6 +-- hls-test-utils/hls-test-utils.cabal | 2 - hls-test-utils/src/Test/Hls.hs | 7 ++- plugins/default/src/Ide/Plugin/Example.hs | 1 - plugins/default/src/Ide/Plugin/Example2.hs | 1 - .../hls-alternate-number-format-plugin.cabal | 1 - .../src/Ide/Plugin/AlternateNumberFormat.hs | 1 - plugins/hls-eval-plugin/hls-eval-plugin.cabal | 1 - .../hls-eval-plugin/src/Ide/Plugin/Eval.hs | 5 +- .../src/Ide/Plugin/Eval/Rules.hs | 4 +- .../hls-explicit-imports-plugin.cabal | 1 - .../src/Ide/Plugin/ExplicitImports.hs | 3 +- .../hls-hlint-plugin/hls-hlint-plugin.cabal | 1 - .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 1 - .../hls-refine-imports-plugin.cabal | 1 - .../src/Ide/Plugin/RefineImports.hs | 1 - .../src/Wingman/LanguageServer.hs | 3 +- .../hls-tactics-plugin/src/Wingman/Plugin.hs | 3 +- src/Ide/Main.hs | 8 ++-- 40 files changed, 107 insertions(+), 142 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index ef76ec7046..11bc732301 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -9,7 +9,6 @@ import Development.IDE.Types.Logger (Priority (Debug, Info), WithPriority (WithPriority, priority), cfilter, cmapWithPrio, makeDefaultStderrRecorder, - priorityToHsLoggerPriority, withDefaultRecorder) import Ide.Arguments (Arguments (..), GhcideArguments (..), @@ -36,7 +35,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 logToDoc <$> makeDefaultStderrRecorder Nothing (priorityToHsLoggerPriority Info) + pluginCliRecorder <- cmapWithPrio logToDoc <$> makeDefaultStderrRecorder Nothing Info args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder) False) let (minPriority, logFilePath, includeExamplePlugins) = @@ -45,9 +44,8 @@ main = do let minPriority = if argsDebugOn || argsTesting then Debug else Info in (minPriority, argsLogFile, argsExamplePlugin) _ -> (Info, Nothing, False) - let hsLoggerMinPriority = priorityToHsLoggerPriority minPriority - withDefaultRecorder logFilePath Nothing hsLoggerMinPriority $ \textWithPriorityRecorder -> do + withDefaultRecorder logFilePath Nothing minPriority $ \textWithPriorityRecorder -> do let recorder = textWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority) diff --git a/exe/Plugins.hs b/exe/Plugins.hs index ec9d97b20f..96be295f35 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -3,11 +3,10 @@ {-# LANGUAGE OverloadedStrings #-} module Plugins where -import Development.IDE.Types.Logger (Recorder, WithPriority, - cmapWithPrio) +import Development.IDE.Types.Logger (Pretty (pretty), Recorder, + WithPriority, cmapWithPrio) import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types (IdePlugins) -import Prettyprinter (Pretty (pretty)) -- fixed plugins import Development.IDE (IdeState) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 417ef56af5..46b2956c4f 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -12,8 +12,7 @@ import Data.Default (def) import Data.Function ((&)) import Data.Version (showVersion) import Development.GitRev (gitHash) -import Development.IDE (Priority (Debug, Info), - action) +import Development.IDE (action) import Development.IDE.Core.OfInterest (kick) import Development.IDE.Core.Rules (mainRule) import qualified Development.IDE.Core.Rules as Rules @@ -21,19 +20,19 @@ import Development.IDE.Core.Tracing (withTelemetryLogger) import Development.IDE.Graph (ShakeOptions (shakeThreads)) import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde -import Development.IDE.Types.Logger (Logger (Logger), +import Development.IDE.Types.Logger (Doc, Logger (Logger), LoggingColumn (DataColumn, PriorityColumn), + Pretty (pretty), + Priority (Debug, Info), Recorder (Recorder), WithPriority (WithPriority, priority), cfilter, cmapWithPrio, - makeDefaultStderrRecorder, - priorityToHsLoggerPriority) + makeDefaultStderrRecorder) import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options import Ide.Plugin.Config (Config (checkParents, checkProject)) import Ide.PluginUtils (pluginDescToIdePlugins) import Paths_ghcide (version) -import Prettyprinter (Doc, Pretty (pretty)) import qualified System.Directory.Extra as IO import System.Environment (getExecutablePath) import System.Exit (exitSuccess) @@ -71,7 +70,7 @@ main = withTelemetryLogger $ \telemetryLogger -> do -- stderr recorder just for plugin cli commands pluginCliRecorder <- cmapWithPrio logToDoc - <$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) (priorityToHsLoggerPriority Info) + <$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Info let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde pluginCliRecorder)) -- WARNING: If you write to stdout before runLanguageServer @@ -88,7 +87,7 @@ main = withTelemetryLogger $ \telemetryLogger -> do let minPriority = if argsVerbose then Debug else Info - docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) (priorityToHsLoggerPriority minPriority) + docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) minPriority let docWithFilteredPriorityRecorder@Recorder{ logger_ } = docWithPriorityRecorder diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 7e99a94078..a315037302 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -306,7 +306,6 @@ executable ghcide "-with-rtsopts=-I0 -A128M -T" main-is: Main.hs build-depends: - hslogger, hiedb, aeson, base == 4.*, @@ -329,7 +328,6 @@ executable ghcide hls-graph, text, unordered-containers, - prettyprinter other-modules: Arguments Paths_ghcide @@ -387,13 +385,11 @@ test-suite ghcide-tests lsp, lsp-types, hls-plugin-api, - hslogger, network-uri, lens, list-t, lsp-test ^>= 0.14, optparse-applicative, - prettyprinter, process, QuickCheck, quickcheck-instances, diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 0090fa74c2..91fe972608 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -63,9 +63,11 @@ import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq, newHscEnvEqPreserveImportPaths) import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Priority (Debug, Error, Info, Warning), +import Development.IDE.Types.Logger (Pretty (pretty), + Priority (Debug, Error, Info, Warning), Recorder, WithPriority, - logWith) + logWith, nest, vcat, + viaShow, (<+>)) import Development.IDE.Types.Options import GHC.Check import qualified HIE.Bios as HieBios @@ -95,8 +97,6 @@ import Development.IDE.Types.Shake (WithHieDb) import HieDb.Create import HieDb.Types import HieDb.Utils -import Prettyprinter (Pretty (pretty), (<+>)) -import qualified Prettyprinter import System.Random (RandomGen) import qualified System.Random as Random @@ -124,48 +124,48 @@ instance Pretty Log where LogSettingInitialDynFlags -> "Setting initial dynflags..." LogGetInitialGhcLibDirDefaultCradleFail cradleError rootDirPath hieYamlPath cradle -> - Prettyprinter.nest 2 $ - Prettyprinter.vcat + nest 2 $ + vcat [ "Couldn't load cradle for ghc libdir." - , "Cradle error:" <+> Prettyprinter.viaShow cradleError + , "Cradle error:" <+> viaShow cradleError , "Root dir path:" <+> pretty rootDirPath , "hie.yaml path:" <+> pretty hieYamlPath - , "Cradle:" <+> Prettyprinter.viaShow cradle ] + , "Cradle:" <+> viaShow cradle ] LogGetInitialGhcLibDirDefaultCradleNone -> "Couldn't load cradle. Cradle not found." LogHieDbRetry delay maxDelay maxRetryCount e -> - Prettyprinter.nest 2 $ - Prettyprinter.vcat + nest 2 $ + vcat [ "Retrying hiedb action..." , "delay:" <+> pretty delay , "maximum delay:" <+> pretty maxDelay , "retries remaining:" <+> pretty maxRetryCount , "SQLite error:" <+> pretty (displayException e) ] LogHieDbRetriesExhausted baseDelay maxDelay maxRetryCount e -> - Prettyprinter.nest 2 $ - Prettyprinter.vcat + nest 2 $ + vcat [ "Retries exhausted for hiedb action." , "base delay:" <+> pretty baseDelay , "maximum delay:" <+> pretty maxDelay , "retries remaining:" <+> pretty maxRetryCount , "Exception:" <+> pretty (displayException e) ] LogHieDbWriterThreadSQLiteError e -> - Prettyprinter.nest 2 $ - Prettyprinter.vcat + nest 2 $ + vcat [ "HieDb writer thread SQLite error:" , pretty (displayException e) ] LogHieDbWriterThreadException e -> - Prettyprinter.nest 2 $ - Prettyprinter.vcat + nest 2 $ + vcat [ "HieDb writer thread exception:" , pretty (displayException e) ] LogInterfaceFilesCacheDir path -> "Interface files cache directory:" <+> pretty path LogKnownFilesUpdated targetToPathsMap -> - Prettyprinter.nest 2 $ - Prettyprinter.vcat + nest 2 $ + vcat [ "Known files updated:" - , Prettyprinter.viaShow $ (HM.map . Set.map) fromNormalizedFilePath targetToPathsMap + , viaShow $ (HM.map . Set.map) fromNormalizedFilePath targetToPathsMap ] LogMakingNewHscEnv inPlaceUnitIds -> "Making new HscEnv. In-place unit ids:" <+> pretty (map show inPlaceUnitIds) @@ -174,16 +174,16 @@ instance Pretty Log where LogCradlePath path -> "Cradle path:" <+> pretty path LogCradleNotFound path -> - Prettyprinter.vcat + vcat [ "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for" <+> pretty path <> "." , "Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie)." , "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ] LogSessionLoadingResult e -> - "Session loading result:" <+> Prettyprinter.viaShow e + "Session loading result:" <+> viaShow e LogCradle cradle -> - "Cradle:" <+> Prettyprinter.viaShow cradle + "Cradle:" <+> viaShow cradle LogNewComponentCache componentCache -> - "New component cache HscEnvEq:" <+> Prettyprinter.viaShow componentCache + "New component cache HscEnvEq:" <+> viaShow componentCache -- | Bump this version number when making changes to the format of the data stored in hiedb hiedbDataVersion :: String diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 21f5a648db..d30f8047f2 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -27,14 +27,14 @@ import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Recorder, WithPriority, +import Development.IDE.Types.Logger (Pretty (pretty), + Recorder, WithPriority, cmapWithPrio) import Development.IDE.Types.Options import qualified Focus import Ide.Plugin.Config (Config) import Language.LSP.Server hiding (getVirtualFile) import Language.LSP.Types -import Prettyprinter (Pretty (pretty)) import qualified StmContainers.Map as STM import qualified System.Directory as Dir import qualified System.FilePath.Glob as Glob diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index f59fd92bf0..81a2fea695 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -69,11 +69,13 @@ import Data.List (foldl') import qualified Data.Text as Text import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Types.Logger (Priority (Info), +import Development.IDE.Types.Logger (Pretty (pretty), + Priority (Info), Recorder, WithPriority, cmapWithPrio, - logWith) + logWith, viaShow, + (<+>)) import Language.LSP.Server hiding (getVirtualFile) import qualified Language.LSP.Server as LSP @@ -85,9 +87,6 @@ import Language.LSP.Types (DidChangeWatchedF import qualified Language.LSP.Types as LSP import qualified Language.LSP.Types.Capabilities as LSP import Language.LSP.VFS -import Prettyprinter (Pretty (pretty), - (<+>)) -import qualified Prettyprinter import System.FilePath data Log @@ -99,10 +98,10 @@ data Log instance Pretty Log where pretty = \case LogCouldNotIdentifyReverseDeps path -> - "Could not identify reverse dependencies for" <+> Prettyprinter.viaShow path + "Could not identify reverse dependencies for" <+> viaShow path (LogTypeCheckingReverseDeps path reverseDepPaths) -> "Typechecking reverse dependecies for" - <+> Prettyprinter.viaShow path + <+> viaShow path <> ":" <+> pretty (fmap (fmap show) reverseDepPaths) LogShake log -> pretty log diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index fc51a90856..3d50287c3b 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -39,11 +39,14 @@ import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Plugin.Completions.Types import Development.IDE.Types.Exports import Development.IDE.Types.Location -import Development.IDE.Types.Logger +import Development.IDE.Types.Logger (Pretty (pretty), + Recorder, + WithPriority, + cmapWithPrio, + logDebug) import Development.IDE.Types.Options (IdeTesting (..)) import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP -import Prettyprinter (Pretty (pretty)) data Log = LogShake Shake.Log deriving Show diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 51c5ca4dbe..324abec6be 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -108,12 +108,12 @@ import Development.IDE.Core.Service hiding (LogShake, Log) import Development.IDE.Core.Shake hiding (Log) import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat hiding - (parseModule, + (vcat, nest, parseModule, TargetId(..), loadInterface, Var, (<+>)) -import qualified Development.IDE.GHC.Compat as Compat +import qualified Development.IDE.GHC.Compat as Compat hiding (vcat, nest) import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint hiding (LogShake, Log) @@ -151,11 +151,9 @@ import Control.Concurrent.STM.Stats (atomically) import Language.LSP.Server (LspT) import System.Info.Extra (isWindows) import HIE.Bios.Ghc.Gap (hostIsDynamic) -import Development.IDE.Types.Logger (Recorder, logWith, cmapWithPrio, WithPriority) +import Development.IDE.Types.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat) import qualified Development.IDE.Core.Shake as Shake import qualified Development.IDE.GHC.ExactPrint as ExactPrint hiding (LogShake) -import Prettyprinter (Pretty (pretty), (<+>)) -import qualified Prettyprinter import qualified Development.IDE.Types.Logger as Logger data Log @@ -175,8 +173,8 @@ instance Pretty Log where LogLoadingHieFile path -> "LOADING HIE FILE FOR" <+> pretty (fromNormalizedFilePath path) LogLoadingHieFileFail path e -> - Prettyprinter.nest 2 $ - Prettyprinter.vcat + nest 2 $ + vcat [ "FAILED LOADING HIE FILE FOR" <+> pretty path , pretty (displayException e) ] LogLoadingHieFileSuccess path -> diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index a0f1752431..e3bbc1faec 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -23,7 +23,12 @@ import Development.IDE.Core.Debouncer import Development.IDE.Core.FileExists (fileExistsRules) import Development.IDE.Core.OfInterest hiding (Log, LogShake) import Development.IDE.Graph -import Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Logger as Logger (Logger, + Pretty (pretty), + Priority (Info), + Recorder, + WithPriority, + cmapWithPrio) import Development.IDE.Types.Options (IdeOptions (..)) import Ide.Plugin.Config import qualified Language.LSP.Server as LSP @@ -35,7 +40,6 @@ import qualified Development.IDE.Core.OfInterest as OfInterest import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Shake (WithHieDb) -import Prettyprinter (Pretty (pretty)) import System.Environment (lookupEnv) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 32c1563876..fec940731a 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -167,8 +167,6 @@ import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS import Ide.Types (PluginId) import qualified "list-t" ListT -import Prettyprinter (Pretty (pretty), (<+>)) -import qualified Prettyprinter import qualified StmContainers.Map as STM data Log @@ -189,17 +187,17 @@ instance Pretty Log where LogCreateHieDbExportsMapFinish exportsMapSize -> "Done initializing exports map from hiedb. Size:" <+> pretty exportsMapSize LogBuildSessionRestart reason actionQueue keyBackLog abortDuration shakeProfilePath -> - Prettyprinter.vcat + vcat [ "Restarting build session due to" <+> pretty reason , "Action Queue:" <+> pretty (map actionName actionQueue) , "Keys:" <+> pretty (map show $ HSet.toList keyBackLog) , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ] LogDelayedAction delayedAction duration -> - Prettyprinter.hsep + hsep [ "Finished:" <+> pretty (actionName delayedAction) , "Took:" <+> pretty (showDuration duration) ] LogBuildSessionFinish e -> - Prettyprinter.vcat + vcat [ "Finished build session" , pretty (fmap displayException e) ] LogDiagsDiffButNoLspEnv fileDiagnostics -> diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index b56bce9e37..3b02df38bc 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -76,7 +76,8 @@ import Development.IDE.GHC.Compat hiding (parseImport, import Development.IDE.Graph (RuleResult, Rules) import Development.IDE.Graph.Classes import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Recorder, +import Development.IDE.Types.Logger (Pretty (pretty), + Recorder, WithPriority, cmapWithPrio) import qualified GHC.Generics as GHC @@ -86,7 +87,6 @@ import Ide.PluginUtils import Language.Haskell.GHC.ExactPrint.Parsers import Language.LSP.Types import Language.LSP.Types.Capabilities (ClientCapabilities) -import Prettyprinter (Pretty (pretty)) import Retrie.ExactPrint hiding (Annotated (..), parseDecl, parseExpr, parsePattern, diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 45d4d57a9d..9f16788c3b 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -43,8 +43,6 @@ import Control.Monad.IO.Unlift (MonadUnliftIO) import qualified Development.IDE.Session as Session import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Shake (WithHieDb) -import Prettyprinter (Pretty (pretty), (<+>)) -import qualified Prettyprinter import System.IO.Unsafe (unsafeInterleaveIO) data Log @@ -59,19 +57,19 @@ data Log instance Pretty Log where pretty = \case LogRegisteringIdeConfig ideConfig -> - "Registering IDE configuration:" <+> Prettyprinter.viaShow ideConfig + "Registering IDE configuration:" <+> viaShow ideConfig LogReactorThreadException e -> - Prettyprinter.vcat + vcat [ "ReactorThreadException" , pretty $ displayException e ] LogReactorMessageActionException e -> - Prettyprinter.vcat + vcat [ "ReactorMessageActionException" , pretty $ displayException e ] LogReactorThreadStopped -> "Reactor thread stopped" LogCancelledRequest requestId -> - "Cancelled request" <+> Prettyprinter.viaShow requestId + "Cancelled request" <+> viaShow requestId LogSession log -> pretty log issueTrackerUrl :: T.Text diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 6973f33f95..6b25942ba2 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -38,7 +38,6 @@ import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Shake (toKey) import Ide.Types -import Prettyprinter (Pretty (pretty)) data Log = LogShake Shake.Log diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 15057581e5..061a1fc364 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -77,10 +77,11 @@ import Development.IDE.Session (SessionLoadingOptions, import qualified Development.IDE.Session as Session import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath') -import Development.IDE.Types.Logger (Logger, +import Development.IDE.Types.Logger (Logger, Pretty (pretty), Priority (Info, Warning), Recorder, WithPriority, - cmapWithPrio, logWith) + cmapWithPrio, logWith, + vsep, (<+>)) import Development.IDE.Types.Options (IdeGhcSession, IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), IdeTesting (IdeTesting), @@ -113,8 +114,6 @@ import qualified Language.LSP.Server as LSP import qualified "list-t" ListT import Numeric.Natural (Natural) import Options.Applicative hiding (action) -import Prettyprinter (Pretty (pretty), (<+>)) -import qualified Prettyprinter import qualified StmContainers.Map as STM import qualified System.Directory.Extra as IO import System.Exit (ExitCode (ExitFailure), @@ -152,7 +151,7 @@ instance Pretty Log where pretty = \case LogHeapStats log -> pretty log LogLspStart -> - Prettyprinter.vsep + vsep [ "Staring LSP server..." , "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"] LogLspStartDuration duration -> diff --git a/ghcide/src/Development/IDE/Main/HeapStats.hs b/ghcide/src/Development/IDE/Main/HeapStats.hs index 86ca18d2ae..c998630f6a 100644 --- a/ghcide/src/Development/IDE/Main/HeapStats.hs +++ b/ghcide/src/Development/IDE/Main/HeapStats.hs @@ -6,11 +6,10 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Monad import Data.Word -import Development.IDE.Types.Logger (Priority (Info), Recorder, - WithPriority, logWith) +import Development.IDE.Types.Logger (Pretty (pretty), Priority (Info), + Recorder, WithPriority, hsep, + logWith, (<+>)) import GHC.Stats -import Prettyprinter (Pretty (pretty), (<+>)) -import qualified Prettyprinter import Text.Printf (printf) data Log @@ -26,7 +25,7 @@ instance Pretty Log where LogHeapStatsDisabled -> "Heap statistics are not enabled (RTS option -T is needed)" LogHeapStats liveBytes heapSize -> - Prettyprinter.hsep + hsep [ "Live bytes:" , pretty (toFormattedMegabytes liveBytes) , "Heap size:" diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index cdaa8b1a5d..edc656ada0 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -39,7 +39,8 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq (envPack hscEnv) import qualified Development.IDE.Types.KnownTargets as KT import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Recorder, +import Development.IDE.Types.Logger (Pretty (pretty), + Recorder, WithPriority, cmapWithPrio) import GHC.Exts (fromList, toList) @@ -48,7 +49,6 @@ import Ide.Types import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.VFS as VFS -import Prettyprinter (Pretty (pretty)) import Text.Fuzzy.Parallel (Scored (..)) data Log = LogShake Shake.Log deriving Show diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 053d1d4102..a7c64a024f 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -35,7 +35,6 @@ import Ide.Types as HLS import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.Types as J -import Prettyprinter (Pretty (pretty)) import Text.Regex.TDFA.Text () import UnliftIO (MonadUnliftIO) import UnliftIO.Async (forConcurrently) diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index be5cd76441..c1393b1f4b 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -18,7 +18,6 @@ import qualified Development.IDE.Plugin.TypeLenses as TypeLenses import Ide.Types import Language.LSP.Server (LspM) import Language.LSP.Types -import Prettyprinter (Pretty (pretty)) import Text.Regex.TDFA.Text () data Log diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index b9ffab8eeb..ecfdd35449 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -43,7 +43,8 @@ import Development.IDE.Types.Location (Position (Position, _chara Range (Range, _end, _start), toNormalizedFilePath', uriToFilePath') -import Development.IDE.Types.Logger (Recorder, WithPriority, +import Development.IDE.Types.Logger (Pretty (pretty), Recorder, + WithPriority, cmapWithPrio) import GHC.Generics (Generic) import Ide.Plugin.Config (Config) @@ -70,7 +71,6 @@ import Language.LSP.Types (ApplyWorkspaceEditParams ( TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit)) -import Prettyprinter (Pretty (pretty)) import Text.Regex.TDFA ((=~), (=~~)) data Log = LogShake Shake.Log deriving Show diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index d71fc84085..88e5c3af57 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -21,6 +21,7 @@ module Development.IDE.Types.Logger , priorityToHsLoggerPriority , LoggingColumn(..) , cmapWithPrio + , module PrettyPrinterModule ) where import Control.Concurrent (myThreadId) @@ -37,9 +38,7 @@ import qualified Data.Text.IO as Text import Data.Time (defaultTimeLocale, formatTime, getCurrentTime) import GHC.Stack (HasCallStack, withFrozenCallStack) -import Prettyprinter (Doc, Pretty (pretty), - defaultLayoutOptions, layoutPretty, - vcat, (<+>)) +import Prettyprinter as PrettyPrinterModule import Prettyprinter.Render.Text (renderStrict) import System.IO (Handle, IOMode (AppendMode), hClose, hFlush, hSetEncoding, @@ -63,7 +62,6 @@ data Priority | Error -- ^ Such log messages must never occur in expected usage. deriving (Eq, Show, Ord, Enum, Bounded) - -- | Note that this is logging actions _of the program_, not of the user. -- You shouldn't call warning/error if the user has caused an error, only -- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). @@ -141,10 +139,11 @@ textHandleRecorder handle = Recorder { logger_ = \text -> liftIO $ Text.hPutStrLn handle text *> hFlush handle } -makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> HsLogger.Priority -> m (Recorder (WithPriority (Doc a))) -makeDefaultStderrRecorder columns hsLoggerMinPriority = do +-- | Priority is actually for hslogger compatibility +makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> Priority -> m (Recorder (WithPriority (Doc a))) +makeDefaultStderrRecorder columns minPriority = do lock <- liftIO newLock - makeDefaultHandleRecorder columns hsLoggerMinPriority lock stderr + makeDefaultHandleRecorder columns minPriority lock stderr -- | If no path given then use stderr, otherwise use file. -- kinda complicated because we are logging with both hslogger and our own @@ -155,14 +154,14 @@ withDefaultRecorder -- ^ log file path -> Maybe [LoggingColumn] -- ^ logging columns to display - -> HsLogger.Priority + -> Priority -- ^ min priority for hslogger -> (Recorder (WithPriority (Doc d)) -> m a) -- ^ action given a recorder -> m a -withDefaultRecorder path columns hsLoggerMinPriority action = do +withDefaultRecorder path columns minPriority action = do lock <- liftIO newLock - let makeHandleRecorder = makeDefaultHandleRecorder columns hsLoggerMinPriority lock + let makeHandleRecorder = makeDefaultHandleRecorder columns minPriority lock case path of Nothing -> do recorder <- makeHandleRecorder stderr @@ -184,19 +183,19 @@ makeDefaultHandleRecorder :: MonadIO m => Maybe [LoggingColumn] -- ^ built-in logging columns to display - -> HsLogger.Priority - -- ^ min priority for hslogger + -> 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 hsLoggerMinPriority lock handle = do +makeDefaultHandleRecorder columns minPriority 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 - liftIO $ setupHsLogger lock handle ["hls", "hie-bios"] hsLoggerMinPriority + liftIO $ setupHsLogger lock handle ["hls", "hie-bios"] (priorityToHsLoggerPriority minPriority) pure (cmap docToText textWithPriorityRecorder) where docToText = fmap (renderStrict . layoutPretty defaultLayoutOptions) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index d98f4dbb74..bb9ae7035c 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -119,10 +119,8 @@ import Test.Tasty.QuickCheck import Text.Printf (printf) import Text.Regex.TDFA ((=~)) import qualified HieDbRetry -import Development.IDE.Types.Logger (WithPriority(WithPriority, priority), Priority (Debug), cmapWithPrio, Recorder (Recorder, logger_), makeDefaultStderrRecorder, cfilter, LoggingColumn (PriorityColumn, DataColumn), Logger (Logger)) +import Development.IDE.Types.Logger (WithPriority(WithPriority, priority), Priority (Debug), cmapWithPrio, Recorder (Recorder, logger_), makeDefaultStderrRecorder, cfilter, LoggingColumn (PriorityColumn, DataColumn), Logger (Logger), Pretty (pretty), Doc) import Data.Function ((&)) -import qualified System.Log as HsLogger -import Prettyprinter (Doc, Pretty (pretty)) data Log = LogGhcIde Ghcide.Log @@ -165,7 +163,7 @@ waitForAllProgressDone = loop main :: IO () main = do - docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) HsLogger.DEBUG + docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Debug let docWithFilteredPriorityRecorder@Recorder{ logger_ } = docWithPriorityRecorder diff --git a/hls-test-utils/hls-test-utils.cabal b/hls-test-utils/hls-test-utils.cabal index 51f558d58e..a6913ac6f9 100644 --- a/hls-test-utils/hls-test-utils.cabal +++ b/hls-test-utils/hls-test-utils.cabal @@ -43,14 +43,12 @@ library , filepath , ghcide ^>=1.6 , hls-graph - , hslogger , hls-plugin-api ^>=1.3 , hspec <2.8 , hspec-core , lens , lsp ^>=1.4 , lsp-test ^>=0.14 - , prettyprinter , lsp-types ^>=1.4.0.1 , tasty , tasty-expected-failure diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index e2a0c86f2c..372e26692e 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -59,7 +59,8 @@ import qualified Development.IDE.Main as IDEMain import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), WaitForIdeRuleResult (ideResultSuccess)) import qualified Development.IDE.Plugin.Test as Test -import Development.IDE.Types.Logger (Logger (Logger), +import Development.IDE.Types.Logger (Doc, Logger (Logger), + Pretty (pretty), Priority (Debug), Recorder (Recorder, logger_), WithPriority (WithPriority, priority), @@ -78,13 +79,11 @@ import Language.LSP.Types hiding SemanticTokensEdit (_start)) import Language.LSP.Types.Capabilities (ClientCapabilities) import Prelude hiding (log) -import Prettyprinter (Doc, Pretty (pretty)) import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.Environment (lookupEnv) import System.FilePath import System.IO.Unsafe (unsafePerformIO) -import qualified System.Log as HsLogger import System.Process.Extra (createPipe) import System.Time.Extra import Test.Hls.Util @@ -190,7 +189,7 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre (inR, inW) <- createPipe (outR, outW) <- createPipe - docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing HsLogger.DEBUG + docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing Debug logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR" diff --git a/plugins/default/src/Ide/Plugin/Example.hs b/plugins/default/src/Ide/Plugin/Example.hs index 166fedf911..0416cbe8d1 100644 --- a/plugins/default/src/Ide/Plugin/Example.hs +++ b/plugins/default/src/Ide/Plugin/Example.hs @@ -37,7 +37,6 @@ import Ide.Types import Language.LSP.Server import Language.LSP.Types import Options.Applicative (ParserInfo, info) -import Prettyprinter (Pretty (pretty)) import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- diff --git a/plugins/default/src/Ide/Plugin/Example2.hs b/plugins/default/src/Ide/Plugin/Example2.hs index 3b2293855d..6595ce58a6 100644 --- a/plugins/default/src/Ide/Plugin/Example2.hs +++ b/plugins/default/src/Ide/Plugin/Example2.hs @@ -34,7 +34,6 @@ import Ide.PluginUtils import Ide.Types import Language.LSP.Server import Language.LSP.Types -import Prettyprinter (Pretty (pretty)) import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- diff --git a/plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal b/plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal index 873d8de6a6..98b7552a13 100644 --- a/plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal +++ b/plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal @@ -37,7 +37,6 @@ library , syb , text , unordered-containers - , prettyprinter default-language: Haskell2010 default-extensions: diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs index 422ed06e0f..e1c4d064dc 100644 --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs @@ -29,7 +29,6 @@ import Ide.PluginUtils (handleMaybe, handleMaybeM, import Ide.Types import Language.LSP.Types import Language.LSP.Types.Lens (uri) -import Prettyprinter (Pretty (pretty)) newtype Log = LogShake Shake.Log deriving Show diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index 6f75f6ff2e..23817901d1 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -76,7 +76,6 @@ library , megaparsec >=9.0 , mtl , parser-combinators - , prettyprinter , pretty-simple , QuickCheck , safe-exceptions diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs index 8ad2feb017..c00022fd13 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs @@ -12,8 +12,8 @@ module Ide.Plugin.Eval ( ) where import Development.IDE (IdeState) -import Development.IDE.Types.Logger (Recorder, WithPriority, - cmapWithPrio) +import Development.IDE.Types.Logger (Pretty (pretty), Recorder, + WithPriority, cmapWithPrio) import qualified Ide.Plugin.Eval.CodeLens as CL import Ide.Plugin.Eval.Config import Ide.Plugin.Eval.Rules (rules) @@ -24,7 +24,6 @@ import Ide.Types (ConfigDescriptor (..), defaultPluginDescriptor, mkCustomConfig, mkPluginHandler) import Language.LSP.Types -import Prettyprinter (Pretty (pretty)) newtype Log = LogEvalRules EvalRules.Log deriving Show diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs index ca1e7bc28f..3b937b1b1e 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -38,10 +38,10 @@ import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat as SrcLoc import qualified Development.IDE.GHC.Compat.Util as FastString import Development.IDE.Graph (alwaysRerun) -import Development.IDE.Types.Logger (Recorder, WithPriority, +import Development.IDE.Types.Logger (Pretty (pretty), + Recorder, WithPriority, cmapWithPrio) import Ide.Plugin.Eval.Types -import Prettyprinter (Pretty (pretty)) newtype Log = LogShake Shake.Log deriving Show diff --git a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal index 6648b279ca..8061dd7148 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -30,7 +30,6 @@ library , lsp , text , unordered-containers - , prettyprinter default-language: Haskell2010 default-extensions: diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 31d7c7d5e7..6f42430748 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -34,13 +34,12 @@ import Development.IDE.Core.PositionMapping import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.Graph.Classes -import qualified Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Logger as Logger (Pretty (pretty)) import GHC.Generics (Generic) import Ide.PluginUtils (mkLspCommand) import Ide.Types import Language.LSP.Server import Language.LSP.Types -import Prettyprinter (Pretty (pretty)) importCommandId :: CommandId importCommandId = "ImportLensCommand" diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index 2471da0ab2..8f7f496b3b 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -72,7 +72,6 @@ library -- and https://github.com/haskell/haskell-language-server/pull/2464#issue-1077133441 is updated -- accordingly , ghc-lib-parser-ex - , prettyprinter if (flag(hlint33)) -- This mirrors the logic in hlint.cabal for hlint-3.3 diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index cf4795080b..a5ba0b9c2e 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -120,7 +120,6 @@ import Development.IDE.Spans.Pragmas (LineSplitTe lineSplitTextEdits, nextPragmaLine) import GHC.Generics (Generic) -import Prettyprinter (Pretty (pretty)) import System.Environment (setEnv, unsetEnv) import Text.Regex.TDFA.Text () diff --git a/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal b/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal index aa8d51b4c7..610c9aba13 100644 --- a/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal +++ b/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal @@ -31,7 +31,6 @@ library , lsp , text , unordered-containers - , prettyprinter default-language: Haskell2010 default-extensions: diff --git a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs index c862a25aa6..2519ce1366 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -48,7 +48,6 @@ import Ide.PluginUtils (mkLspCommand) import Ide.Types import Language.LSP.Server import Language.LSP.Types -import Prettyprinter (Pretty (pretty)) newtype Log = LogShake Shake.Log deriving Show diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index 0f6bfcb137..ed896a99eb 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -63,9 +63,8 @@ import Wingman.Judgements.Theta import Wingman.Range import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax) import Wingman.Types -import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority) +import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) import qualified Development.IDE.Core.Shake as Shake -import Prettyprinter (Pretty (pretty)) newtype Log diff --git a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs index cfab420268..6473a725d5 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -13,8 +13,7 @@ import Wingman.LanguageServer hiding (Log) import qualified Wingman.LanguageServer as WingmanLanguageServer import Wingman.LanguageServer.Metaprogram (hoverProvider) import Wingman.StaticPlugin -import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority) -import Prettyprinter (Pretty (pretty)) +import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) newtype Log = LogWingmanLanguageServer WingmanLanguageServer.Log diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 70a911cbac..94beffebe8 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -33,8 +33,6 @@ import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, import Ide.Types (IdePlugins, PluginId (PluginId), ipMap) import Ide.Version -import Prettyprinter (Pretty, pretty, (<+>)) -import qualified Prettyprinter import qualified System.Directory.Extra as IO data Log @@ -49,10 +47,10 @@ instance Pretty Log where LogVersion version -> pretty version LogDirectory path -> "Directory:" <+> pretty path LogLspStart ghcideArgs pluginIds -> - Prettyprinter.nest 2 $ - Prettyprinter.vsep + nest 2 $ + vsep [ "Starting (haskell-language-server) LSP server..." - , Prettyprinter.viaShow ghcideArgs + , viaShow ghcideArgs , "PluginIds:" <+> pretty (coerce @_ @[Text] pluginIds) ] LogIDEMain iDEMainLog -> pretty iDEMainLog From 88ae7e2225c9c77c00056104c07aeeb77149341e Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Sat, 5 Feb 2022 23:53:11 -0500 Subject: [PATCH 40/43] existential type var to remove boilerplate in Plugins.hs, remove a few Show instances --- exe/Main.hs | 1 - exe/Plugins.hs | 73 ++++++++-------------------------- ghcide/exe/Main.hs | 1 - ghcide/test/exe/Main.hs | 1 - hls-test-utils/src/Test/Hls.hs | 2 +- 5 files changed, 17 insertions(+), 61 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index 11bc732301..407d007746 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -21,7 +21,6 @@ import Prettyprinter (Doc, Pretty (pretty)) data Log = LogIdeMain IdeMain.Log | LogPlugins Plugins.Log - deriving Show instance Pretty Log where pretty log = case log of diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 96be295f35..7a55c5ea00 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} module Plugins where import Development.IDE.Types.Logger (Pretty (pretty), Recorder, @@ -101,53 +101,10 @@ import qualified Ide.Plugin.StylishHaskell as StylishHaskell import qualified Ide.Plugin.Brittany as Brittany #endif -data Log - = LogGhcIde GhcIde.Log - | LogExample Example.Log - | LogExample2 Example2.Log -#if tactic - | LogTactic Tactic.Log -#endif -#if eval - | LogEval Eval.Log -#endif -#if importLens - | LogExplicitImports ExplicitImports.Log -#endif -#if refineImports - | LogRefineImports RefineImports.Log -#endif -#if hlint - | LogHlint Hlint.Log -#endif -#if alternateNumberFormat - | LogAlternateNumberFormat AlternateNumberFormat.Log -#endif - deriving Show +data Log = forall a. (Pretty a) => Log a instance Pretty Log where - pretty = \case - LogGhcIde log -> pretty log - LogExample log -> pretty log - LogExample2 log -> pretty log -#if tactic - LogTactic log -> pretty log -#endif -#if eval - LogEval log -> pretty log -#endif -#if importLens - LogExplicitImports log -> pretty log -#endif -#if refineImports - LogRefineImports log -> pretty log -#endif -#if hlint - LogHlint log -> pretty log -#endif -#if alternateNumberFormat - LogAlternateNumberFormat log -> pretty log -#endif + pretty (Log a) = pretty a -- --------------------------------------------------------------------- @@ -159,6 +116,8 @@ instance Pretty Log where idePlugins :: Recorder (WithPriority Log) -> Bool -> IdePlugins IdeState idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins where + pluginRecorder :: forall log. (Pretty log) => Recorder (WithPriority log) + pluginRecorder = cmapWithPrio Log recorder allPlugins = if includeExamples then basePlugins ++ examplePlugins else basePlugins @@ -173,7 +132,7 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins Fourmolu.descriptor "fourmolu" : #endif #if tactic - Tactic.descriptor (cmapWithPrio LogTactic recorder) "tactics" : + Tactic.descriptor pluginRecorder "tactics" : #endif #if ormolu Ormolu.descriptor "ormolu" : @@ -200,36 +159,36 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins HaddockComments.descriptor "haddockComments" : #endif #if eval - Eval.descriptor (cmapWithPrio LogEval recorder) "eval" : + Eval.descriptor pluginRecorder "eval" : #endif #if importLens - ExplicitImports.descriptor (cmapWithPrio LogExplicitImports recorder) "importLens" : + ExplicitImports.descriptor pluginRecorder "importLens" : #endif #if qualifyImportedNames QualifyImportedNames.descriptor "qualifyImportedNames" : #endif #if refineImports - RefineImports.descriptor (cmapWithPrio LogRefineImports recorder) "refineImports" : + RefineImports.descriptor pluginRecorder "refineImports" : #endif #if moduleName ModuleName.descriptor "moduleName" : #endif #if hlint - Hlint.descriptor (cmapWithPrio LogHlint recorder) "hlint" : + Hlint.descriptor pluginRecorder "hlint" : #endif #if splice Splice.descriptor "splice" : #endif #if alternateNumberFormat - AlternateNumberFormat.descriptor (cmapWithPrio LogAlternateNumberFormat recorder) "alternateNumberFormat" : + AlternateNumberFormat.descriptor pluginRecorder "alternateNumberFormat" : #endif #if selectionRange SelectionRange.descriptor "selectionRange" : #endif -- The ghcide descriptors should come last so that the notification handlers -- (which restart the Shake build) run after everything else - GhcIde.descriptors (cmapWithPrio LogGhcIde recorder) + GhcIde.descriptors pluginRecorder examplePlugins = - [Example.descriptor (cmapWithPrio LogExample recorder) "eg" - ,Example2.descriptor (cmapWithPrio LogExample2 recorder) "eg2" + [Example.descriptor pluginRecorder "eg" + ,Example2.descriptor pluginRecorder "eg2" ] diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 46b2956c4f..c1947ce60d 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -43,7 +43,6 @@ data Log = LogIDEMain IDEMain.Log | LogRules Rules.Log | LogGhcIde GhcIde.Log - deriving Show instance Pretty Log where pretty = \case diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index bb9ae7035c..2e77f709d1 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -125,7 +125,6 @@ import Data.Function ((&)) data Log = LogGhcIde Ghcide.Log | LogIDEMain IDE.Log - deriving Show instance Pretty Log where pretty = \case diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 372e26692e..43635ca86e 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -93,7 +93,7 @@ import Test.Tasty.Golden import Test.Tasty.HUnit import Test.Tasty.Ingredients.Rerun -newtype Log = LogIDEMain IDEMain.Log deriving Show +newtype Log = LogIDEMain IDEMain.Log instance Pretty Log where pretty = \case From 1fd42ae050a9c7b451960a122ea2cb6446bf09d2 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Sun, 6 Feb 2022 18:17:47 -0500 Subject: [PATCH 41/43] add SourceLoc logging column, inline logToDoc functions, add comment explaining hslogger setup existence --- exe/Main.hs | 9 ++-- ghcide/exe/Main.hs | 14 +++-- ghcide/src/Development/IDE/Types/Logger.hs | 61 ++++++++++++++++------ ghcide/test/exe/Main.hs | 12 ++--- hls-test-utils/src/Test/Hls.hs | 11 ++-- 5 files changed, 65 insertions(+), 42 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index 407d007746..d3f8af8d00 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -16,7 +16,7 @@ import Ide.Arguments (Arguments (..), import Ide.Main (defaultMain) import qualified Ide.Main as IdeMain import qualified Plugins -import Prettyprinter (Doc, Pretty (pretty)) +import Prettyprinter (Pretty (pretty)) data Log = LogIdeMain IdeMain.Log @@ -27,14 +27,11 @@ instance Pretty Log where LogIdeMain ideMainLog -> pretty ideMainLog LogPlugins pluginsLog -> pretty pluginsLog -logToDoc :: Log -> Doc a -logToDoc = pretty - 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 logToDoc <$> makeDefaultStderrRecorder Nothing Info + pluginCliRecorder <- cmapWithPrio pretty <$> makeDefaultStderrRecorder Nothing Info args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder) False) let (minPriority, logFilePath, includeExamplePlugins) = @@ -48,6 +45,6 @@ main = do let recorder = textWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority) - & cmapWithPrio logToDoc + & cmapWithPrio pretty defaultMain (cmapWithPrio LogIdeMain recorder) args (Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index c1947ce60d..178052da71 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -20,7 +20,7 @@ import Development.IDE.Core.Tracing (withTelemetryLogger) import Development.IDE.Graph (ShakeOptions (shakeThreads)) import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde -import Development.IDE.Types.Logger (Doc, Logger (Logger), +import Development.IDE.Types.Logger (Logger (Logger), LoggingColumn (DataColumn, PriorityColumn), Pretty (pretty), Priority (Debug, Info), @@ -30,6 +30,7 @@ import Development.IDE.Types.Logger (Doc, Logger (Logger), makeDefaultStderrRecorder) import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Options +import GHC.Stack (emptyCallStack) import Ide.Plugin.Config (Config (checkParents, checkProject)) import Ide.PluginUtils (pluginDescToIdePlugins) import Paths_ghcide (version) @@ -50,9 +51,6 @@ instance Pretty Log where LogRules log -> pretty log LogGhcIde log -> pretty log -logToDoc :: Log -> Doc a -logToDoc = pretty - ghcideVersion :: IO String ghcideVersion = do path <- getExecutablePath @@ -68,7 +66,7 @@ main :: IO () main = withTelemetryLogger $ \telemetryLogger -> do -- stderr recorder just for plugin cli commands pluginCliRecorder <- - cmapWithPrio logToDoc + cmapWithPrio pretty <$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Info let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde pluginCliRecorder)) @@ -92,11 +90,11 @@ main = withTelemetryLogger $ \telemetryLogger -> do docWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= minPriority) - -- hack so old-school logging still works - let logger = Logger $ \p m -> logger_ (WithPriority p (pretty m)) + -- exists so old-style logging works. intended to be phased out + let logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) let recorder = docWithFilteredPriorityRecorder - & cmapWithPrio logToDoc + & cmapWithPrio pretty let arguments = if argsTesting diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index 88e5c3af57..9f696210e2 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -37,7 +37,10 @@ import qualified Data.Text as Text import qualified Data.Text.IO as Text import Data.Time (defaultTimeLocale, formatTime, getCurrentTime) -import GHC.Stack (HasCallStack, withFrozenCallStack) +import GHC.Stack (CallStack, HasCallStack, + SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine), + callStack, getCallStack, + withFrozenCallStack) import Prettyprinter as PrettyPrinterModule import Prettyprinter.Render.Text (renderStrict) import System.IO (Handle, IOMode (AppendMode), @@ -92,16 +95,16 @@ logTelemetry x = logPriority x Telemetry noLogging :: Logger noLogging = Logger $ \_ _ -> return () -data WithPriority a = WithPriority { priority :: Priority, payload :: a } deriving Functor +data WithPriority a = WithPriority { priority :: Priority, callStack_ :: CallStack, payload :: a } deriving Functor -- | Note that this is logging actions _of the program_, not of the user. -- You shouldn't call warning/error if the user has caused an error, only -- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). data Recorder msg = Recorder - { logger_ :: forall m. (HasCallStack, MonadIO m) => msg -> m () } + { logger_ :: forall m. (MonadIO m) => msg -> m () } logWith :: (HasCallStack, MonadIO m) => Recorder (WithPriority msg) -> Priority -> msg -> m () -logWith recorder priority msg = withFrozenCallStack $ logger_ recorder (WithPriority priority msg) +logWith recorder priority msg = withFrozenCallStack $ logger_ recorder (WithPriority priority callStack msg) instance Semigroup (Recorder msg) where (<>) Recorder{ logger_ = logger_1 } Recorder{ logger_ = logger_2 } = @@ -146,16 +149,18 @@ makeDefaultStderrRecorder columns minPriority = do makeDefaultHandleRecorder columns minPriority lock stderr -- | If no path given then use stderr, otherwise use file. --- kinda complicated because we are logging with both hslogger and our own --- logger simultaneously +-- 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 + -- ^ Log file path. `Nothing` uses stderr -> Maybe [LoggingColumn] - -- ^ logging columns to display + -- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns` -> Priority - -- ^ min priority for hslogger + -- ^ min priority for hslogger compatibility -> (Recorder (WithPriority (Doc d)) -> m a) -- ^ action given a recorder -> m a @@ -182,7 +187,7 @@ withDefaultRecorder path columns minPriority action = do makeDefaultHandleRecorder :: MonadIO m => Maybe [LoggingColumn] - -- ^ built-in logging columns to display + -- ^ built-in logging columns to display. Nothing uses the default -> Priority -- ^ min priority for hslogger compatibility -> Lock @@ -195,6 +200,7 @@ makeDefaultHandleRecorder columns minPriority lock handle = do 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 @@ -208,8 +214,17 @@ priorityToHsLoggerPriority = \case Warning -> HsLogger.WARNING Error -> HsLogger.ERROR --- taken from LSP.setupLogger --- used until contravariant logging system is fully in place +-- | 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 @@ -238,27 +253,43 @@ data LoggingColumn | ThreadIdColumn | PriorityColumn | DataColumn + | SourceLocColumn defaultLoggingColumns :: [LoggingColumn] defaultLoggingColumns = [TimeColumn, PriorityColumn, DataColumn] textWithPriorityToText :: [LoggingColumn] -> WithPriority Text -> IO Text -textWithPriorityToText columns WithPriority{ priority, payload } = do +textWithPriorityToText columns WithPriority{ priority, callStack_, payload } = do textColumns <- mapM loggingColumnToText columns pure $ Text.intercalate " | " textColumns where + showAsText :: Show a => a -> Text + showAsText = Text.pack . show + utcTimeToText utcTime = Text.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime priorityToText :: Priority -> Text - priorityToText = Text.pack . show + priorityToText = showAsText + + threadIdToText = showAsText + + callStackToSrcLoc :: CallStack -> Maybe SrcLoc + callStackToSrcLoc callStack = + case getCallStack callStack of + (_, srcLoc) : _ -> Just srcLoc + _ -> Nothing - threadIdToText = Text.pack . show + srcLocToText = \case + Nothing -> "" + Just SrcLoc{ srcLocModule, srcLocStartLine, srcLocStartCol } -> + Text.pack srcLocModule <> "#" <> showAsText srcLocStartLine <> ":" <> showAsText srcLocStartCol loggingColumnToText :: LoggingColumn -> IO Text loggingColumnToText = \case TimeColumn -> do utcTime <- getCurrentTime pure (utcTimeToText utcTime) + SourceLocColumn -> pure $ (srcLocToText . callStackToSrcLoc) callStack_ ThreadIdColumn -> do threadId <- myThreadId pure (threadIdToText threadId) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 2e77f709d1..77e8da7c2b 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -119,8 +119,9 @@ import Test.Tasty.QuickCheck import Text.Printf (printf) import Text.Regex.TDFA ((=~)) import qualified HieDbRetry -import Development.IDE.Types.Logger (WithPriority(WithPriority, priority), Priority (Debug), cmapWithPrio, Recorder (Recorder, logger_), makeDefaultStderrRecorder, cfilter, LoggingColumn (PriorityColumn, DataColumn), Logger (Logger), Pretty (pretty), Doc) +import Development.IDE.Types.Logger (WithPriority(WithPriority, priority), Priority (Debug), cmapWithPrio, Recorder (Recorder, logger_), makeDefaultStderrRecorder, cfilter, LoggingColumn (PriorityColumn, DataColumn), Logger (Logger), Pretty (pretty)) import Data.Function ((&)) +import GHC.Stack (emptyCallStack) data Log = LogGhcIde Ghcide.Log @@ -131,9 +132,6 @@ instance Pretty Log where LogGhcIde log -> pretty log LogIDEMain log -> pretty log -logToDoc :: Log -> Doc a -logToDoc = pretty - -- | Wait for the next progress begin step waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case @@ -168,11 +166,11 @@ main = do docWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= Debug) - -- hack so old school logging still works - let logger = Logger $ \p m -> logger_ (WithPriority p (pretty m)) + -- exists so old-style logging works. intended to be phased out + let logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) let recorder = docWithFilteredPriorityRecorder - & cmapWithPrio logToDoc + & cmapWithPrio pretty -- We mess with env vars so run single-threaded. defaultMainWithRerun $ testGroup "ghcide" diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 43635ca86e..02ece9efb4 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -59,7 +59,7 @@ import qualified Development.IDE.Main as IDEMain import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), WaitForIdeRuleResult (ideResultSuccess)) import qualified Development.IDE.Plugin.Test as Test -import Development.IDE.Types.Logger (Doc, Logger (Logger), +import Development.IDE.Types.Logger (Logger (Logger), Pretty (pretty), Priority (Debug), Recorder (Recorder, logger_), @@ -68,6 +68,7 @@ import Development.IDE.Types.Logger (Doc, Logger (Logger), makeDefaultStderrRecorder) import Development.IDE.Types.Options import GHC.IO.Handle +import GHC.Stack (emptyCallStack) import Ide.Plugin.Config (Config, formattingProvider) import Ide.PluginUtils (idePluginsToPluginDesc, pluginDescToIdePlugins) @@ -99,9 +100,6 @@ instance Pretty Log where pretty = \case LogIDEMain log -> pretty log -logToDoc :: Log -> Doc a -logToDoc = pretty - -- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes defaultTestRunner :: TestTree -> IO () defaultTestRunner = defaultMainWithRerun . adjustOption (const $ mkTimeout 600000000) @@ -198,9 +196,10 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre if logStdErr == "0" then mempty else cfilter (\WithPriority{ priority } -> priority >= Debug) docWithPriorityRecorder - logger = Logger $ \p m -> logger_ (WithPriority p (pretty m)) + -- exists until old logging style is phased out + logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) - recorder = cmapWithPrio logToDoc docWithFilteredPriorityRecorder + recorder = cmapWithPrio pretty docWithFilteredPriorityRecorder arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments (cmapWithPrio LogIDEMain recorder) logger From c1f1f3da9ca126f4430a8dc30a44e05d95f622cd Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Sat, 19 Feb 2022 19:15:06 -0500 Subject: [PATCH 42/43] qualify a name to match original source --- ghcide/src/Development/IDE/Core/Service.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index cdbfac2478..d190a0d6cf 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -103,4 +103,4 @@ shutdown = shakeShut -- e.g., the ofInterestRule. runAction :: String -> IdeState -> Action a -> IO a runAction herald ide act = - join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Debug act) + join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug act) From 3d7134817fa2123edf1cc3bf9ff80986c1ed2584 Mon Sep 17 00:00:00 2001 From: Jon Shen Date: Sun, 20 Feb 2022 12:27:06 -0500 Subject: [PATCH 43/43] fix -WError --- src/Ide/Main.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 225582fd16..73acc2a922 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -35,12 +35,9 @@ import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, import Ide.Types (IdePlugins, PluginId (PluginId), ipMap) import Ide.Version -import qualified Language.LSP.Server as LSP import System.Directory import qualified System.Directory.Extra as IO import System.FilePath -import System.IO -import qualified System.Log.Logger as L data Log = LogVersion !String