From 5deb99605fc570673bd0436c12b8b5246dd10605 Mon Sep 17 00:00:00 2001 From: fendor Date: Tue, 16 Apr 2024 09:43:26 +0200 Subject: [PATCH] Drop Logger from HLS code base. (#4171) Move ghcide completely to colog-logging style. Move plugins that were relying on `ideLogger` to colog style logging. Move opentelemetry to colog-logging style. This allows us to drop legacy code and unify the logging experience in HLS. We add a bunch of new Log constructors at various locations that aim to be identical to their previous `Logger` statements. --- exe/Wrapper.hs | 11 +- ghcide/exe/Main.hs | 19 ++-- ghcide/src/Development/IDE/Core/OfInterest.hs | 11 +- ghcide/src/Development/IDE/Core/RuleTypes.hs | 5 + ghcide/src/Development/IDE/Core/Service.hs | 7 +- ghcide/src/Development/IDE/Core/Shake.hs | 48 +++++---- ghcide/src/Development/IDE/Core/Tracing.hs | 22 ++-- .../Development/IDE/LSP/HoverDefinition.hs | 59 +++++----- .../src/Development/IDE/LSP/LanguageServer.hs | 10 +- .../src/Development/IDE/LSP/Notifications.hs | 25 +++-- ghcide/src/Development/IDE/Main.hs | 29 +++-- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 29 ++--- ghcide/test/exe/ExceptionTests.hs | 32 +++--- ghcide/test/exe/Main.hs | 87 +++++++-------- ghcide/test/exe/UnitTests.hs | 10 +- hls-plugin-api/src/Ide/Logger.hs | 29 ----- hls-test-utils/src/Test/Hls.hs | 27 ++--- .../hls-eval-plugin/src/Ide/Plugin/Eval.hs | 21 ++-- .../src/Ide/Plugin/Eval/CodeLens.hs | 102 ++++++++---------- .../src/Ide/Plugin/Eval/Rules.hs | 9 +- .../src/Ide/Plugin/Eval/Types.hs | 94 +++++++++++++--- .../src/Ide/Plugin/Eval/Util.hs | 53 ++++----- .../src/Ide/Plugin/Retrie.hs | 49 +++++---- plugins/hls-retrie-plugin/test/Main.hs | 23 ++-- .../src/Ide/Plugin/StylishHaskell.hs | 22 ++-- .../hls-stylish-haskell-plugin/test/Main.hs | 4 +- src/HlsPlugins.hs | 4 +- src/Ide/Main.hs | 17 ++- 28 files changed, 454 insertions(+), 404 deletions(-) diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 020f842dd4..6de88abcc0 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -41,11 +41,8 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Development.IDE.LSP.LanguageServer (runLanguageServer) import qualified Development.IDE.Main as Main -import GHC.Stack.Types (emptyCallStack) -import Ide.Logger (Doc, Logger (Logger), - Pretty (pretty), - Recorder (logger_), - WithPriority (WithPriority), +import Ide.Logger (Doc, Pretty (pretty), + Recorder, WithPriority, cmapWithPrio, makeDefaultStderrRecorder) import Ide.Plugin.Config (Config) @@ -272,9 +269,7 @@ newtype ErrorLSPM c a = ErrorLSPM { unErrorLSPM :: (LspM c) a } -- to shut down the LSP. launchErrorLSP :: Recorder (WithPriority (Doc ())) -> T.Text -> IO () launchErrorLSP recorder errorMsg = do - let logger = Logger $ \p m -> logger_ recorder (WithPriority p emptyCallStack (pretty m)) - - let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) logger (IdePlugins []) + let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) (IdePlugins []) inH <- Main.argsHandleIn defaultArguments diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index a563f3532b..a38c5909f3 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -16,14 +16,12 @@ import Development.IDE (action) 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.Core.Tracing (withTelemetryRecorder) import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde import Development.IDE.Types.Options -import GHC.Stack (emptyCallStack) -import Ide.Logger (Logger (Logger), - LoggingColumn (DataColumn, PriorityColumn), +import Ide.Logger (LoggingColumn (DataColumn, PriorityColumn), Pretty (pretty), Priority (Debug, Error, Info), WithPriority (WithPriority, priority), @@ -71,7 +69,7 @@ ghcideVersion = do <> gitHashSection main :: IO () -main = withTelemetryLogger $ \telemetryLogger -> do +main = withTelemetryRecorder $ \telemetryRecorder -> do -- stderr recorder just for plugin cli commands pluginCliRecorder <- cmapWithPrio pretty @@ -109,23 +107,20 @@ main = withTelemetryLogger $ \telemetryLogger -> do (lspLogRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions) & cfilter (\WithPriority{ priority } -> priority >= minPriority)) <> (lspMessageRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions) - & cfilter (\WithPriority{ priority } -> priority >= Error)) - - -- exists so old-style logging works. intended to be phased out - let logger = Logger $ \p m -> Logger.logger_ docWithFilteredPriorityRecorder (WithPriority p emptyCallStack (pretty m)) + & cfilter (\WithPriority{ priority } -> priority >= Error)) <> + telemetryRecorder let recorder = docWithFilteredPriorityRecorder & cmapWithPrio pretty let arguments = if argsTesting - then IDEMain.testing (cmapWithPrio LogIDEMain recorder) logger hlsPlugins - else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger hlsPlugins + then IDEMain.testing (cmapWithPrio LogIDEMain recorder) hlsPlugins + else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) hlsPlugins IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments { IDEMain.argsProjectRoot = Just argsCwd , IDEMain.argCommand = argsCommand - , IDEMain.argsLogger = IDEMain.argsLogger arguments <> pure telemetryLogger , IDEMain.argsHlsPlugins = IDEMain.argsHlsPlugins arguments <> pluginDescToIdePlugins [lspRecorderPlugin] , IDEMain.argsRules = do diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 950c27bcbb..0be869b45a 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -42,10 +42,11 @@ import Development.IDE.Types.Location import Development.IDE.Types.Options (IdeTesting (..)) import GHC.TypeLits (KnownSymbol) import Ide.Logger (Pretty (pretty), + Priority (..), Recorder, WithPriority, cmapWithPrio, - logDebug) + logWith) import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Server as LSP @@ -110,16 +111,16 @@ addFileOfInterest state f v = do pure (new, (prev, new)) when (prev /= Just v) $ do join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] - logDebug (ideLogger state) $ - "Set files of interest to: " <> T.pack (show files) + logWith (ideLogger state) Debug $ + LogSetFilesOfInterest (HashMap.toList files) deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO () deleteFileOfInterest state f = do OfInterestVar var <- getIdeGlobalState state files <- modifyVar' var $ HashMap.delete f join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] - logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files) - + logWith (ideLogger state) Debug $ + LogSetFilesOfInterest (HashMap.toList files) scheduleGarbageCollection :: IdeState -> IO () scheduleGarbageCollection state = do GarbageCollectVar var <- getIdeGlobalState state diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index fc977cea8a..605420d3b6 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -41,6 +41,8 @@ import Development.IDE.Spans.Common import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Diagnostics import GHC.Serialized (Serialized) +import Ide.Logger (Pretty (..), + viaShow) import Language.LSP.Protocol.Types (Int32, NormalizedFilePath) @@ -340,6 +342,9 @@ data FileOfInterestStatus instance Hashable FileOfInterestStatus instance NFData FileOfInterestStatus +instance Pretty FileOfInterestStatus where + pretty = viaShow + data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus deriving (Eq, Show, Typeable, Generic) instance Hashable IsFileOfInterestResult diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index 43a7fc5bef..cdb5ba72cb 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -22,8 +22,7 @@ import Development.IDE.Core.FileExists (fileExistsRules) import Development.IDE.Core.OfInterest hiding (Log, LogShake) import Development.IDE.Graph import Development.IDE.Types.Options (IdeOptions (..)) -import Ide.Logger as Logger (Logger, - Pretty (pretty), +import Ide.Logger as Logger (Pretty (pretty), Priority (Debug), Recorder, WithPriority, @@ -63,14 +62,13 @@ initialise :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Rules () -> Maybe (LSP.LanguageContextEnv Config) - -> Logger -> Debouncer LSP.NormalizedUri -> IdeOptions -> WithHieDb -> IndexQueue -> Monitoring -> IO IdeState -initialise recorder defaultConfig plugins mainRule lspEnv logger debouncer options withHieDb hiedbChan metrics = do +initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics = do shakeProfiling <- do let fromConf = optShakeProfiling options fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING" @@ -80,7 +78,6 @@ initialise recorder defaultConfig plugins mainRule lspEnv logger debouncer optio lspEnv defaultConfig plugins - logger debouncer shakeProfiling (optReportProgress options) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 5d5eb511d2..bd32a30a3d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -168,11 +168,11 @@ import qualified Language.LSP.Server as LSP import Language.LSP.VFS hiding (start) import qualified "list-t" ListT import OpenTelemetry.Eventlog hiding (addEvent) +import qualified Prettyprinter as Pretty import qualified StmContainers.Map as STM import System.FilePath hiding (makeRelative) import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra - -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] #if !MIN_VERSION_ghc(9,3,0) @@ -191,6 +191,12 @@ data Log | LogDiagsDiffButNoLspEnv ![FileDiagnostic] | LogDefineEarlyCutoffRuleNoDiagHasDiag !FileDiagnostic | LogDefineEarlyCutoffRuleCustomNewnessHasDiag !FileDiagnostic + | LogCancelledAction !T.Text + | LogSessionInitialised + | LogLookupPersistentKey !T.Text + | LogShakeGarbageCollection !T.Text !Int !Seconds + -- * OfInterest Log messages + | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)] deriving Show instance Pretty Log where @@ -224,6 +230,16 @@ instance Pretty Log where LogDefineEarlyCutoffRuleCustomNewnessHasDiag fileDiagnostic -> "defineEarlyCutoff RuleWithCustomNewnessCheck - file diagnostic:" <+> pretty (showDiagnosticsColored [fileDiagnostic]) + LogCancelledAction action -> + pretty action <+> "was cancelled" + LogSessionInitialised -> "Shake session initialized" + LogLookupPersistentKey key -> + "LOOKUP PERSISTENT FOR:" <+> pretty key + LogShakeGarbageCollection label number duration -> + pretty label <+> "of" <+> pretty number <+> "keys (took " <+> pretty (showDuration duration) <> ")" + LogSetFilesOfInterest ofInterest -> + "Set files of interst to" <> Pretty.line + <> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest) -- | 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 @@ -254,7 +270,7 @@ data ShakeExtras = ShakeExtras { --eventer :: LSP.FromServerMessage -> IO () lspEnv :: Maybe (LSP.LanguageContextEnv Config) ,debouncer :: Debouncer NormalizedUri - ,logger :: Logger + ,shakeRecorder :: Recorder (WithPriority Log) ,idePlugins :: IdePlugins IdeState ,globals :: TVar (HMap.HashMap TypeRep Dynamic) -- ^ Registry of global state used by rules. @@ -439,7 +455,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do | otherwise = do pmap <- readTVarIO persistentKeys mv <- runMaybeT $ do - liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP PERSISTENT FOR: " ++ show k + liftIO $ logWith (shakeRecorder s) Debug $ LogLookupPersistentKey (T.pack $ show k) f <- MaybeT $ pure $ lookupKeyMap (newKey k) pmap (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file MaybeT $ pure $ (,del,ver) <$> fromDynamic dv @@ -602,7 +618,6 @@ shakeOpen :: Recorder (WithPriority Log) -> Maybe (LSP.LanguageContextEnv Config) -> Config -> IdePlugins IdeState - -> Logger -> Debouncer NormalizedUri -> Maybe FilePath -> IdeReportProgress @@ -613,7 +628,7 @@ shakeOpen :: Recorder (WithPriority Log) -> Monitoring -> Rules () -> IO IdeState -shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer +shakeOpen recorder lspEnv defaultConfig idePlugins debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue opts monitoring rules = mdo @@ -660,7 +675,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer dirtyKeys <- newTVarIO mempty -- Take one VFS snapshot at the start vfsVar <- newTVarIO =<< vfsSnapshot lspEnv - pure ShakeExtras{..} + pure ShakeExtras{shakeRecorder = recorder, ..} shakeDb <- shakeNewDatabase opts { shakeExtra = newShakeExtra shakeExtras } @@ -707,7 +722,7 @@ shakeSessionInit recorder ide@IdeState{..} = do vfs <- vfsSnapshot (lspEnv shakeExtras) initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit" putMVar shakeSession initSession - logDebug (ideLogger ide) "Shake session initialized" + logWith recorder Debug LogSessionInitialised shakeShut :: IdeState -> IO () shakeShut IdeState{..} = do @@ -775,7 +790,7 @@ shakeRestart recorder IdeState{..} vfs reason acts = -- -- Appropriate for user actions other than edits. shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a) -shakeEnqueue ShakeExtras{actionQueue, logger} act = do +shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do (b, dai) <- instantiateDelayedAction act atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue let wait' barrier = @@ -784,7 +799,7 @@ shakeEnqueue ShakeExtras{actionQueue, logger} act = do fail $ "internal bug: forever blocked on MVar for " <> actionName act) , Handler (\e@AsyncCancelled -> do - logPriority logger Debug $ T.pack $ actionName act <> " was cancelled" + logWith shakeRecorder Debug $ LogCancelledAction (T.pack $ actionName act) atomicallyNamed "actionQueue - abort" $ abortQueue dai actionQueue throw e) @@ -908,13 +923,12 @@ garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key] garbageCollectKeys label maxAge checkParents agedKeys = do start <- liftIO offsetTime - ShakeExtras{state, dirtyKeys, lspEnv, logger, ideTesting} <- getShakeExtras + ShakeExtras{state, dirtyKeys, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras (n::Int, garbage) <- liftIO $ foldM (removeDirtyKey dirtyKeys state) (0,[]) agedKeys t <- liftIO start when (n>0) $ liftIO $ do - logDebug logger $ T.pack $ - label <> " of " <> show n <> " keys (took " <> showDuration t <> ")" + logWith shakeRecorder Debug $ LogShakeGarbageCollection (T.pack label) n t when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $ LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC")) (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage) @@ -1305,13 +1319,11 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti | otherwise = c -ideLogger :: IdeState -> Logger -ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger +ideLogger :: IdeState -> Recorder (WithPriority Log) +ideLogger IdeState{shakeExtras=ShakeExtras{shakeRecorder}} = shakeRecorder -actionLogger :: Action Logger -actionLogger = do - ShakeExtras{logger} <- getShakeExtras - return logger +actionLogger :: Action (Recorder (WithPriority Log)) +actionLogger = shakeRecorder <$> getShakeExtras -------------------------------------------------------------------------------- type STMDiagnosticStore = STM.Map NormalizedUri StoreItem diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index ed30a174af..86212f0e83 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -7,7 +7,7 @@ module Development.IDE.Core.Tracing , otTracedGarbageCollection , withTrace , withEventTrace - , withTelemetryLogger + , withTelemetryRecorder ) where @@ -26,7 +26,7 @@ import Development.IDE.Graph.Rule import Development.IDE.Types.Diagnostics (FileDiagnostic, showDiagnostics) import Development.IDE.Types.Location (Uri (..)) -import Ide.Logger (Logger (Logger)) +import Ide.Logger import Ide.Types (PluginId (..)) import Language.LSP.Protocol.Types (NormalizedFilePath, fromNormalizedFilePath) @@ -51,16 +51,20 @@ withEventTrace name act | otherwise = act (\_ -> pure ()) -- | Returns a logger that produces telemetry events in a single span -withTelemetryLogger :: (MonadIO m, MonadMask m) => (Logger -> m a) -> m a -withTelemetryLogger k = withSpan "Logger" $ \sp -> +withTelemetryRecorder :: (MonadIO m, MonadMask m) => (Recorder (WithPriority (Doc a)) -> m c) -> m c +withTelemetryRecorder k = withSpan "Logger" $ \sp -> -- Tracy doesn't like when we create a new span for every log line. -- To workaround that, we create a single span for all log events. -- This is fine since we don't care about the span itself, only about the events - k $ Logger $ \p m -> - addEvent sp (fromString $ show p) (encodeUtf8 $ trim m) - where - -- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX - trim = T.take (fromIntegral(maxBound :: Word16) - 10) + k $ telemetryLogRecorder sp + +-- | Returns a logger that produces telemetry events in a single span. +telemetryLogRecorder :: SpanInFlight -> Recorder (WithPriority (Doc a)) +telemetryLogRecorder sp = Recorder $ \WithPriority {..} -> + liftIO $ addEvent sp (fromString $ show priority) (encodeUtf8 $ trim $ renderStrict $ layoutCompact $ payload) + where + -- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX + trim = T.take (fromIntegral(maxBound :: Word16) - 10) -- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span. otTracedHandler diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index c561243bf7..0401247ac5 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -4,9 +4,9 @@ -- | Display information on hover. module Development.IDE.LSP.HoverDefinition - ( + ( Log(..) -- * For haskell-language-server - hover + , hover , gotoDefinition , gotoTypeDefinition , documentHighlight @@ -18,8 +18,9 @@ import Control.Monad.Except (ExceptT) import Control.Monad.IO.Class import Data.Maybe (fromMaybe) import Development.IDE.Core.Actions -import Development.IDE.Core.Rules -import Development.IDE.Core.Shake +import qualified Development.IDE.Core.Rules as Shake +import Development.IDE.Core.Shake (IdeAction, IdeState (..), + ideLogger, runIdeAction) import Development.IDE.Types.Location import Ide.Logger import Ide.Plugin.Error @@ -30,26 +31,37 @@ import qualified Language.LSP.Server as LSP import qualified Data.Text as T -gotoDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentDefinition) -hover :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (Hover |? Null) -gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentTypeDefinition) -documentHighlight :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) ([DocumentHighlight] |? Null) + +data Log + = LogWorkspaceSymbolRequest !T.Text + | LogRequest !T.Text !Position !NormalizedFilePath + deriving (Show) + +instance Pretty Log where + pretty = \case + LogWorkspaceSymbolRequest query -> "Workspace symbols request:" <+> pretty query + LogRequest label pos nfp -> + pretty label <+> "request at position" <+> pretty (showPosition pos) <+> + "in file:" <+> pretty (fromNormalizedFilePath nfp) + +gotoDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentDefinition) +hover :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (Hover |? Null) +gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentTypeDefinition) +documentHighlight :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) ([DocumentHighlight] |? Null) gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR) gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR) hover = request "Hover" getAtPoint (InR Null) foundHover documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL -references :: PluginMethodHandler IdeState Method_TextDocumentReferences -references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do +references :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentReferences +references recorder ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do nfp <- getNormalizedFilePathE uri - liftIO $ logDebug (ideLogger ide) $ - "References request at position " <> T.pack (showPosition pos) <> - " in file: " <> T.pack (show nfp) - InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos) + liftIO $ logWith recorder Debug $ LogRequest "References" pos nfp + InL <$> (liftIO $ Shake.runAction "references" ide $ refsAtPoint nfp pos) -wsSymbols :: PluginMethodHandler IdeState Method_WorkspaceSymbol -wsSymbols ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do - logDebug (ideLogger ide) $ "Workspace symbols request: " <> query +wsSymbols :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_WorkspaceSymbol +wsSymbols recorder ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do + logWith recorder Debug $ LogWorkspaceSymbolRequest query runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ InL . fromMaybe [] <$> workspaceSymbols query foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null @@ -62,19 +74,18 @@ request -> (NormalizedFilePath -> Position -> IdeAction (Maybe a)) -> b -> (a -> b) + -> Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) b -request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do +request label getResults notFound found recorder ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do mbResult <- case uriToFilePath' uri of - Just path -> logAndRunRequest label getResults ide pos path + Just path -> logAndRunRequest recorder label getResults ide pos path Nothing -> pure Nothing pure $ maybe notFound found mbResult -logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b -logAndRunRequest label getResults ide pos path = do +logAndRunRequest :: Recorder (WithPriority Log) -> T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b +logAndRunRequest recorder label getResults ide pos path = do let filePath = toNormalizedFilePath' path - logDebug (ideLogger ide) $ - label <> " request at position " <> T.pack (showPosition pos) <> - " in file: " <> T.pack path + logWith recorder Debug $ LogRequest label pos filePath runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 3a3ddd7d87..e4493436cb 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -50,6 +50,7 @@ data Log | LogCancelledRequest !SomeLspId | LogSession Session.Log | LogLspServer LspServerLog + | LogServerShutdownMessage deriving Show instance Pretty Log where @@ -73,6 +74,7 @@ instance Pretty Log where "Cancelled request" <+> viaShow requestId LogSession msg -> pretty msg LogLspServer msg -> pretty msg + LogServerShutdownMessage -> "Received shutdown message" -- used to smuggle RankNType WithHieDb through dbMVar newtype WithHieDbShield = WithHieDbShield WithHieDb @@ -169,7 +171,7 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do [ userHandlers , cancelHandler cancelRequest , exitHandler exit - , shutdownHandler stopReactorLoop + , shutdownHandler recorder stopReactorLoop ] -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. @@ -256,10 +258,10 @@ cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \T toLspId (InL x) = IdInt x toLspId (InR y) = IdString y -shutdownHandler :: IO () -> LSP.Handlers (ServerM c) -shutdownHandler stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do +shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM c) +shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do (_, ide) <- ask - liftIO $ logDebug (ideLogger ide) "Received shutdown message" + liftIO $ logWith recorder Debug LogServerShutdownMessage -- stop the reactor to free up the hiedb connection liftIO stopReactor -- flush out the Shake session to record a Shake profile if applicable diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 91a518800c..1772612e2d 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -41,12 +41,25 @@ import Numeric.Natural data Log = LogShake Shake.Log | LogFileStore FileStore.Log + | LogOpenTextDocument !Uri + | LogOpenedTextDocument !Uri + | LogModifiedTextDocument !Uri + | LogSavedTextDocument !Uri + | LogClosedTextDocument !Uri + | LogWatchedFileEvents !Text.Text + | LogWarnNoWatchedFilesSupport deriving Show instance Pretty Log where pretty = \case LogShake msg -> pretty msg LogFileStore msg -> pretty msg + LogOpenedTextDocument uri -> "Opened text document:" <+> pretty (getUri uri) + LogModifiedTextDocument uri -> "Modified text document:" <+> pretty (getUri uri) + LogSavedTextDocument uri -> "Saved text document:" <+> pretty (getUri uri) + LogClosedTextDocument uri -> "Closed text document:" <+> pretty (getUri uri) + LogWatchedFileEvents msg -> "Watched file events:" <+> pretty msg + LogWarnNoWatchedFilesSupport -> "Client does not support watched files. Falling back to OS polling" whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' @@ -61,7 +74,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat -- For example, vscode restores previously unsaved contents on open addFileOfInterest ide file Modified{firstOpen=True} setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file - logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri + logWith recorder Debug $ LogOpenedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ \ide vfs _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do @@ -69,14 +82,14 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat whenUriFile _uri $ \file -> do addFileOfInterest ide file Modified{firstOpen=False} setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file - logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri + logWith recorder Debug $ LogModifiedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do addFileOfInterest ide file OnDisk setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file - logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri + logWith recorder Debug $ LogSavedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do @@ -85,7 +98,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat let msg = "Closed text document: " <> getUri _uri scheduleGarbageCollection ide setSomethingModified (VFSModified vfs) ide [] $ Text.unpack msg - logDebug (ideLogger ide) msg + logWith recorder Debug $ LogClosedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWatchedFiles $ \ide vfs _ (DidChangeWatchedFilesParams fileEvents) -> liftIO $ do @@ -102,7 +115,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat ] unless (null fileEvents') $ do let msg = show fileEvents' - logDebug (ideLogger ide) $ "Watched file events: " <> Text.pack msg + logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg) modifyFileExists ide fileEvents' resetFileStore ide fileEvents' setSomethingModified (VFSModified vfs) ide [] msg @@ -133,7 +146,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat let globs = watchedGlobs opts success <- registerFileWatches globs unless success $ - liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling" + liftIO $ logWith recorder Warning LogWarnNoWatchedFilesSupport ], -- The ghcide descriptors should come last'ish so that the notification handlers diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index a05ab88e2a..0c7581f75d 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -94,14 +94,13 @@ import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Handle (hDuplicate) import HIE.Bios.Cradle (findCradle) import qualified HieDb.Run as HieDb -import Ide.Logger (Logger, - Pretty (pretty), +import Ide.Logger (Pretty (pretty), Priority (Info), Recorder, WithPriority, cmapWithPrio, - logDebug, logWith, - nest, vsep, (<+>)) + logWith, nest, vsep, + (<+>)) import Ide.Plugin.Config (CheckParents (NeverCheck), Config, checkParents, checkProject, @@ -139,6 +138,7 @@ data Log | LogLspStartDuration !Seconds | LogShouldRunSubset !Bool | LogSetInitialDynFlagsException !SomeException + | LogConfigurationChange T.Text | LogService Service.Log | LogShake Shake.Log | LogGhcIde GhcIde.Log @@ -163,6 +163,7 @@ instance Pretty Log where "shouldRunSubset:" <+> pretty shouldRunSubset LogSetInitialDynFlagsException e -> "setInitialDynFlags:" <+> pretty (displayException e) + LogConfigurationChange msg -> "Configuration changed:" <+> pretty msg LogService msg -> pretty msg LogShake msg -> pretty msg LogGhcIde msg -> pretty msg @@ -209,7 +210,6 @@ commandP plugins = data Arguments = Arguments { argsProjectRoot :: Maybe FilePath , argCommand :: Command - , argsLogger :: IO Logger , argsRules :: Rules () , argsHlsPlugins :: IdePlugins IdeState , argsGhcidePlugin :: Plugin Config -- ^ Deprecated @@ -225,11 +225,10 @@ data Arguments = Arguments , argsMonitoring :: IO Monitoring } -defaultArguments :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> Arguments -defaultArguments recorder logger plugins = Arguments +defaultArguments :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments +defaultArguments recorder plugins = Arguments { argsProjectRoot = Nothing , argCommand = LSP - , argsLogger = pure logger , argsRules = mainRule (cmapWithPrio LogRules recorder) def >> action kick , argsGhcidePlugin = mempty , argsHlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde recorder)) <> plugins @@ -262,11 +261,11 @@ defaultArguments recorder logger plugins = Arguments } -testing :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> Arguments -testing recorder logger plugins = +testing :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments +testing recorder plugins = let arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = - defaultArguments recorder logger plugins + defaultArguments recorder plugins hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc argsHlsPlugins ++ [Test.blockCommandDescriptor "block-command", Test.plugin] @@ -287,7 +286,6 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re fun = do setLocaleEncoding utf8 pid <- T.pack . show <$> getProcessID - logger <- argsLogger hSetBuffering stderr LineBuffering let hlsPlugin = asGhcIdePlugin (cmapWithPrio LogPluginHLS recorder) argsHlsPlugins @@ -346,7 +344,6 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re argsHlsPlugins rules (Just env) - logger debouncer ideOptions withHieDb @@ -365,7 +362,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re Nothing -> pure () Just ide -> liftIO $ do let msg = T.pack $ show cfg - logDebug (Shake.ideLogger ide) $ "Configuration changed: " <> msg + logWith recorder Debug $ LogConfigurationChange msg modifyClientSettings ide (const $ Just cfgObj) setSomethingModified Shake.VFSUnmodified ide [toKey Rules.GetClientSettings emptyFilePath] "config change" @@ -402,7 +399,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer ideOptions hiedb hieChan mempty + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -440,7 +437,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer ideOptions hiedb hieChan mempty + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index b3c7457275..319b75d031 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -9,7 +9,7 @@ module Development.IDE.Plugin.HLS.GhcIde ) where import Control.Monad.IO.Class import Development.IDE -import Development.IDE.LSP.HoverDefinition +import qualified Development.IDE.LSP.HoverDefinition as Hover import qualified Development.IDE.LSP.Notifications as Notifications import Development.IDE.LSP.Outline import qualified Development.IDE.Plugin.Completions as Completions @@ -23,6 +23,7 @@ data Log = LogNotifications Notifications.Log | LogCompletions Completions.Log | LogTypeLenses TypeLenses.Log + | LogHover Hover.Log deriving Show instance Pretty Log where @@ -30,10 +31,11 @@ instance Pretty Log where LogNotifications msg -> pretty msg LogCompletions msg -> pretty msg LogTypeLenses msg -> pretty msg + LogHover msg -> pretty msg descriptors :: Recorder (WithPriority Log) -> [PluginDescriptor IdeState] descriptors recorder = - [ descriptor "ghcide-hover-and-symbols", + [ descriptor (cmapWithPrio LogHover recorder) "ghcide-hover-and-symbols", Completions.descriptor (cmapWithPrio LogCompletions recorder) "ghcide-completions", TypeLenses.descriptor (cmapWithPrio LogTypeLenses recorder) "ghcide-type-lenses", Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core" @@ -41,18 +43,18 @@ descriptors recorder = -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId desc) - { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover hover' +descriptor :: Recorder (WithPriority Hover.Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId desc) + { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover (hover' recorder) <> mkPluginHandler SMethod_TextDocumentDocumentSymbol moduleOutline <> mkPluginHandler SMethod_TextDocumentDefinition (\ide _ DefinitionParams{..} -> - gotoDefinition ide TextDocumentPositionParams{..}) + Hover.gotoDefinition recorder ide TextDocumentPositionParams{..}) <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} -> - gotoTypeDefinition ide TextDocumentPositionParams{..}) + Hover.gotoTypeDefinition recorder ide TextDocumentPositionParams{..}) <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> - documentHighlight ide TextDocumentPositionParams{..}) - <> mkPluginHandler SMethod_TextDocumentReferences references - <> mkPluginHandler SMethod_WorkspaceSymbol wsSymbols, + Hover.documentHighlight recorder ide TextDocumentPositionParams{..}) + <> mkPluginHandler SMethod_TextDocumentReferences (Hover.references recorder) + <> mkPluginHandler SMethod_WorkspaceSymbol (Hover.wsSymbols recorder), pluginConfigDescriptor = defaultConfigDescriptor } @@ -61,7 +63,6 @@ descriptor plId = (defaultPluginDescriptor plId desc) -- --------------------------------------------------------------------- -hover' :: PluginMethodHandler IdeState Method_TextDocumentHover -hover' ideState _ HoverParams{..} = do - liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ - hover ideState TextDocumentPositionParams{..} +hover' :: Recorder (WithPriority Hover.Log) -> PluginMethodHandler IdeState Method_TextDocumentHover +hover' recorder ideState _ HoverParams{..} = + Hover.hover recorder ideState TextDocumentPositionParams{..} diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs index 44d2844d74..0de78ee562 100644 --- a/ghcide/test/exe/ExceptionTests.hs +++ b/ghcide/test/exe/ExceptionTests.hs @@ -15,8 +15,8 @@ import Development.IDE.Plugin.HLS (toResponseError) import Development.IDE.Plugin.Test as Test import Development.IDE.Types.Options import GHC.Base (coerce) -import Ide.Logger (Logger, Recorder, - WithPriority, cmapWithPrio) +import Ide.Logger (Recorder, WithPriority, + cmapWithPrio) import Ide.Plugin.Error import Ide.Plugin.HandleRequestTypes (RejectionReason (DisabledGlobally)) import Ide.PluginUtils (idePluginsToPluginDesc, @@ -35,8 +35,8 @@ import Test.Tasty import Test.Tasty.HUnit import TestUtils -tests :: Recorder (WithPriority Log) -> Logger -> TestTree -tests recorder logger = do +tests :: Recorder (WithPriority Log) -> TestTree +tests recorder = do testGroup "Exceptions and PluginError" [ testGroup "Testing that IO Exceptions are caught in..." [ testCase "PluginHandlers" $ do @@ -49,7 +49,7 @@ tests recorder logger = do pure (InL []) ] }] - testIde recorder (testingLite recorder logger plugins) $ do + testIde recorder (testingLite recorder plugins) $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) @@ -70,7 +70,7 @@ tests recorder logger = do pure (InR Null) ] }] - testIde recorder (testingLite recorder logger plugins) $ do + testIde recorder (testingLite recorder plugins) $ do _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone let cmd = mkLspCommand (coerce pluginId) commandId "" (Just [A.toJSON (1::Int)]) @@ -95,7 +95,7 @@ tests recorder logger = do pure (InL []) ] }] - testIde recorder (testingLite recorder logger plugins) $ do + testIde recorder (testingLite recorder plugins) $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) @@ -107,17 +107,17 @@ tests recorder logger = do _ -> liftIO $ assertFailure $ "We should have had an empty list" <> show lens] , testGroup "Testing PluginError order..." - [ pluginOrderTestCase recorder logger "InternalError over InvalidParams" (PluginInternalError "error test") (PluginInvalidParams "error test") - , pluginOrderTestCase recorder logger "InvalidParams over InvalidUserState" (PluginInvalidParams "error test") (PluginInvalidUserState "error test") - , pluginOrderTestCase recorder logger "InvalidUserState over RequestRefused" (PluginInvalidUserState "error test") (PluginRequestRefused DisabledGlobally) + [ pluginOrderTestCase recorder "InternalError over InvalidParams" (PluginInternalError "error test") (PluginInvalidParams "error test") + , pluginOrderTestCase recorder "InvalidParams over InvalidUserState" (PluginInvalidParams "error test") (PluginInvalidUserState "error test") + , pluginOrderTestCase recorder "InvalidUserState over RequestRefused" (PluginInvalidUserState "error test") (PluginRequestRefused DisabledGlobally) ] ] -testingLite :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> IDE.Arguments -testingLite recorder logger plugins = +testingLite :: Recorder (WithPriority Log) -> IdePlugins IdeState -> IDE.Arguments +testingLite recorder plugins = let arguments@IDE.Arguments{ argsIdeOptions } = - IDE.defaultArguments (cmapWithPrio LogIDEMain recorder) logger plugins + IDE.defaultArguments (cmapWithPrio LogIDEMain recorder) plugins hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc plugins ++ [Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] @@ -133,8 +133,8 @@ testingLite recorder logger plugins = , IDE.argsIdeOptions = ideOptions } -pluginOrderTestCase :: Recorder (WithPriority Log) -> Logger -> TestName -> PluginError -> PluginError -> TestTree -pluginOrderTestCase recorder logger msg err1 err2 = +pluginOrderTestCase :: Recorder (WithPriority Log) -> TestName -> PluginError -> PluginError -> TestTree +pluginOrderTestCase recorder msg err1 err2 = testCase msg $ do let pluginId = "error-order-test" plugins = pluginDescToIdePlugins $ @@ -146,7 +146,7 @@ pluginOrderTestCase recorder logger msg err1 err2 = throwError err2 ] }] - testIde recorder (testingLite recorder logger plugins) $ do + testIde recorder (testingLite recorder plugins) $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 412a6969fe..7031065aba 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -30,63 +30,56 @@ module Main (main) where -- import Test.QuickCheck.Instances () -import Data.Function ((&)) -import Ide.Logger (Logger (Logger), - LoggingColumn (DataColumn, PriorityColumn), - Pretty (pretty), - Priority (Debug), - Recorder (Recorder, logger_), - WithPriority (WithPriority, priority), - cfilter, - cmapWithPrio, - makeDefaultStderrRecorder) -import GHC.Stack (emptyCallStack) +import Data.Function ((&)) import qualified HieDbRetry +import Ide.Logger (LoggingColumn (DataColumn, PriorityColumn), + Pretty (pretty), + Priority (Debug), + WithPriority (WithPriority, priority), + cfilter, cmapWithPrio, + makeDefaultStderrRecorder) import Test.Tasty import Test.Tasty.Ingredients.Rerun -import LogType () -import OpenCloseTest -import InitializeResponseTests -import CompletionTests -import CPPTests -import DiagnosticTests -import CodeLensTests -import OutlineTests -import HighlightTests -import FindDefinitionAndHoverTests -import PluginSimpleTests -import PreprocessorTests -import THTests -import SymlinkTests -import SafeTests -import UnitTests -import HaddockTests -import PositionMappingTests -import WatchedFileTests -import CradleTests -import DependentFileTest -import NonLspCommandLine -import IfaceTests -import BootTests -import RootUriTests -import AsyncTests -import ClientSettingsTests -import ReferenceTests -import GarbageCollectionTests -import ExceptionTests +import AsyncTests +import BootTests +import ClientSettingsTests +import CodeLensTests +import CompletionTests +import CPPTests +import CradleTests +import DependentFileTest +import DiagnosticTests +import ExceptionTests +import FindDefinitionAndHoverTests +import GarbageCollectionTests +import HaddockTests +import HighlightTests +import IfaceTests +import InitializeResponseTests +import LogType () +import NonLspCommandLine +import OpenCloseTest +import OutlineTests +import PluginSimpleTests +import PositionMappingTests +import PreprocessorTests +import ReferenceTests +import RootUriTests +import SafeTests +import SymlinkTests +import THTests +import UnitTests +import WatchedFileTests main :: IO () main = do docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) - let docWithFilteredPriorityRecorder@Recorder{ logger_ } = + let docWithFilteredPriorityRecorder = docWithPriorityRecorder & cfilter (\WithPriority{ priority } -> priority >= Debug) - -- 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 pretty @@ -106,7 +99,7 @@ main = do , THTests.tests , SymlinkTests.tests , SafeTests.tests - , UnitTests.tests recorder logger + , UnitTests.tests recorder , HaddockTests.tests , PositionMappingTests.tests , WatchedFileTests.tests @@ -121,5 +114,5 @@ main = do , ReferenceTests.tests , GarbageCollectionTests.tests , HieDbRetry.tests - , ExceptionTests.tests recorder logger + , ExceptionTests.tests recorder ] diff --git a/ghcide/test/exe/UnitTests.hs b/ghcide/test/exe/UnitTests.hs index e818b92491..b798146fb0 100644 --- a/ghcide/test/exe/UnitTests.hs +++ b/ghcide/test/exe/UnitTests.hs @@ -14,8 +14,8 @@ import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location import qualified FuzzySearch -import Ide.Logger (Logger, Recorder, - WithPriority, cmapWithPrio) +import Ide.Logger (Recorder, WithPriority, + cmapWithPrio) import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types import Language.LSP.Protocol.Message @@ -36,8 +36,8 @@ import Test.Tasty.HUnit import TestUtils import Text.Printf (printf) -tests :: Recorder (WithPriority Log) -> Logger -> TestTree -tests recorder logger = do +tests :: Recorder (WithPriority Log) -> TestTree +tests recorder = do testGroup "Unit" [ testCase "empty file path does NOT work with the empty String literal" $ uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "." @@ -82,7 +82,7 @@ tests recorder logger = do ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder) priorityPluginDescriptor i = (defaultPluginDescriptor (fromString $ show i) ""){pluginPriority = i} - testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger plugins) $ do + testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) plugins) $ do _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone actualOrder <- liftIO $ reverse <$> readIORef orderRef diff --git a/hls-plugin-api/src/Ide/Logger.hs b/hls-plugin-api/src/Ide/Logger.hs index 9c5387584c..0a6cb5237f 100644 --- a/hls-plugin-api/src/Ide/Logger.hs +++ b/hls-plugin-api/src/Ide/Logger.hs @@ -10,10 +10,7 @@ -- framework they want to. module Ide.Logger ( Priority(..) - , Logger(..) , Recorder(..) - , logError, logWarning, logInfo, logDebug - , noLogging , WithPriority(..) , logWith , cmap @@ -81,32 +78,6 @@ data Priority | Error -- ^ Such log messages must never occur in expected usage. deriving (Eq, Show, Read, 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). -newtype Logger = Logger {logPriority :: Priority -> T.Text -> IO ()} - -instance Semigroup Logger where - l1 <> l2 = Logger $ \p t -> logPriority l1 p t >> logPriority l2 p t - -instance Monoid Logger where - mempty = Logger $ \_ _ -> pure () - -logError :: Logger -> T.Text -> IO () -logError x = logPriority x Error - -logWarning :: Logger -> T.Text -> IO () -logWarning x = logPriority x Warning - -logInfo :: Logger -> T.Text -> IO () -logInfo x = logPriority x Info - -logDebug :: Logger -> T.Text -> IO () -logDebug x = logPriority x Debug - -noLogging :: Logger -noLogging = Logger $ \_ _ -> return () - 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. diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 38c4b9b7ae..9c4c33cad2 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -89,12 +89,9 @@ import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBu import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Types.Options import GHC.IO.Handle -import GHC.Stack (emptyCallStack) import GHC.TypeLits -import Ide.Logger (Doc, Logger (Logger), - Pretty (pretty), - Priority (..), - Recorder (Recorder, logger_), +import Ide.Logger (Pretty (pretty), + Priority (..), Recorder, WithPriority (WithPriority, priority), cfilter, cmapWithPrio, logWith, @@ -338,8 +335,7 @@ mkPluginTestDescriptor' pluginDesc plId _recorder = IdePlugins [pluginDesc plId] -- @ pluginTestRecorder :: Pretty a => IO (Recorder (WithPriority a)) pluginTestRecorder = do - (recorder, _) <- initialiseTestRecorder ["HLS_TEST_PLUGIN_LOG_STDERR", "HLS_TEST_LOG_STDERR"] - pure recorder + initialiseTestRecorder ["HLS_TEST_PLUGIN_LOG_STDERR", "HLS_TEST_LOG_STDERR"] -- | Generic recorder initialisation for plugins and the HLS server for test-cases. -- @@ -350,7 +346,7 @@ pluginTestRecorder = do -- -- We have to return the base logger function for HLS server logging initialisation. -- See 'runSessionWithServer'' for details. -initialiseTestRecorder :: Pretty a => [String] -> IO (Recorder (WithPriority a), WithPriority (Doc ann) -> IO ()) +initialiseTestRecorder :: Pretty a => [String] -> IO (Recorder (WithPriority a)) initialiseTestRecorder envVars = do docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing -- There are potentially multiple environment variables that enable this logger @@ -361,9 +357,7 @@ initialiseTestRecorder envVars = do if logStdErr then cfilter (\WithPriority{ priority } -> priority >= Debug) docWithPriorityRecorder else mempty - Recorder {logger_} = docWithFilteredPriorityRecorder - - pure (cmapWithPrio pretty docWithFilteredPriorityRecorder, logger_) + pure (cmapWithPrio pretty docWithFilteredPriorityRecorder) -- ------------------------------------------------------------ -- Run an HLS server testing a specific plugin @@ -426,7 +420,7 @@ runSessionWithServerInTmpDir' :: IO a runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = withLock lockForTempDirs $ do testRoot <- setupTestEnvironment - (recorder, _) <- initialiseTestRecorder + recorder <- initialiseTestRecorder ["LSP_TEST_LOG_STDERR", "HLS_TEST_HARNESS_STDERR", "HLS_TEST_LOG_STDERR"] -- Do not clean up the temporary directory if this variable is set to anything but '0'. @@ -608,18 +602,16 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurr -- It is also in better accordance with 'pluginTestRecorder' which uses "HLS_TEST_PLUGIN_LOG_STDERR". -- At last, "HLS_TEST_LOG_STDERR" is intended to enable all logging for the server and the plugins -- under test. - (recorder, logger_) <- initialiseTestRecorder + recorder <- initialiseTestRecorder ["LSP_TEST_LOG_STDERR", "HLS_TEST_SERVER_LOG_STDERR", "HLS_TEST_LOG_STDERR"] let sconf' = sconf { lspConfig = hlsConfigToClientConfig conf } - -- exists until old logging style is phased out - logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) hlsPlugins = IdePlugins [Test.blockCommandDescriptor "block-command"] <> plugins - arguments@Arguments{ argsIdeOptions, argsLogger } = - testing (cmapWithPrio LogIDEMain recorder) logger hlsPlugins + arguments@Arguments{ argsIdeOptions } = + testing (cmapWithPrio LogIDEMain recorder) hlsPlugins ideOptions config ghcSession = let defIdeOptions = argsIdeOptions config ghcSession @@ -634,7 +626,6 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurr { argsHandleIn = pure inR , argsHandleOut = pure outW , argsDefaultHlsConfig = conf - , argsLogger = argsLogger , argsIdeOptions = ideOptions , argsProjectRoot = Just root } diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs index 7a02214589..eaf97e4a58 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs @@ -8,16 +8,15 @@ Eval Plugin entry point. -} module Ide.Plugin.Eval ( descriptor, - Log(..) + Eval.Log(..) ) where import Development.IDE (IdeState) -import Ide.Logger (Pretty (pretty), Recorder, - WithPriority, cmapWithPrio) +import Ide.Logger (Recorder, WithPriority) import qualified Ide.Plugin.Eval.CodeLens as CL import Ide.Plugin.Eval.Config import Ide.Plugin.Eval.Rules (rules) -import qualified Ide.Plugin.Eval.Rules as EvalRules +import qualified Ide.Plugin.Eval.Types as Eval import Ide.Types (ConfigDescriptor (..), PluginDescriptor (..), PluginId, defaultConfigDescriptor, @@ -25,19 +24,13 @@ import Ide.Types (ConfigDescriptor (..), mkCustomConfig, mkPluginHandler) import Language.LSP.Protocol.Message -newtype Log = LogEvalRules EvalRules.Log deriving Show - -instance Pretty Log where - pretty = \case - LogEvalRules log -> pretty log - -- |Plugin descriptor -descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor :: Recorder (WithPriority Eval.Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId "Provies a code lens to evaluate expressions in doctest comments") - { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens CL.codeLens - , pluginCommands = [CL.evalCommand plId] - , pluginRules = rules (cmapWithPrio LogEvalRules recorder) + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens (CL.codeLens recorder) + , pluginCommands = [CL.evalCommand recorder plId] + , pluginRules = rules recorder , pluginConfigDescriptor = defaultConfigDescriptor { configCustomConfig = mkCustomConfig properties } diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index f6912c1485..bb7c51be59 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -95,6 +95,10 @@ import Development.IDE.Core.FileStore (setSomethingModif import Development.IDE.Core.PluginUtils import Development.IDE.Types.Shake (toKey) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) +import Ide.Logger (Priority (..), + Recorder, + WithPriority, + logWith) import Ide.Plugin.Error (PluginError (PluginInternalError), handleMaybe, handleMaybeM) @@ -119,7 +123,7 @@ import Ide.Plugin.Eval.Rules (queueForEvaluatio import Ide.Plugin.Eval.Types import Ide.Plugin.Eval.Util (gStrictTry, isLiterate, - logWith, + prettyWarnings, response', timed) import Ide.Types import qualified Language.LSP.Protocol.Lens as L @@ -131,17 +135,17 @@ import Language.LSP.VFS (virtualFileText) {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. -} -codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens -codeLens st plId CodeLensParams{_textDocument} = - let dbg = logWith st - perf = timed dbg +codeLens :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeLens +codeLens recorder st plId CodeLensParams{_textDocument} = + let dbg = logWith recorder Debug + perf = timed (\lbl duration -> dbg $ LogExecutionTime lbl duration) in perf "codeLens" $ do let TextDocumentIdentifier uri = _textDocument fp <- uriToFilePathE uri let nfp = toNormalizedFilePath' fp isLHS = isLiterate fp - dbg "fp" fp + dbg $ LogCodeLensFp fp (comments, _) <- runActionE "eval.GetParsedModuleWithComments" st $ useWithStaleE GetEvalComments nfp -- dbg "excluded comments" $ show $ DL.toList $ @@ -152,7 +156,7 @@ codeLens st plId CodeLensParams{_textDocument} = -- _ -> DL.singleton (a, b) -- ) -- $ apiAnnComments' pm_annotations - dbg "comments" $ show comments + dbg $ LogCodeLensComments comments -- Extract tests from source code let Sections{..} = commentsToSections isLHS comments @@ -174,17 +178,11 @@ codeLens st plId CodeLensParams{_textDocument} = ] perf "tests" $ - dbg "Tests" $ - unwords - [ show (length tests) - , "tests in" - , show (length nonSetupSections) - , "sections" - , show (length setupSections) - , "setups" - , show (length lenses) - , "lenses." - ] + dbg $ LogTests + (length tests) + (length nonSetupSections) + (length setupSections) + (length lenses) return $ InL lenses where @@ -193,15 +191,15 @@ codeLens st plId CodeLensParams{_textDocument} = evalCommandName :: CommandId evalCommandName = "evalCommand" -evalCommand :: PluginId -> PluginCommand IdeState -evalCommand plId = PluginCommand evalCommandName "evaluate" (runEvalCmd plId) +evalCommand :: Recorder (WithPriority Log) -> PluginId -> PluginCommand IdeState +evalCommand recorder plId = PluginCommand evalCommandName "evaluate" (runEvalCmd recorder plId) type EvalId = Int -runEvalCmd :: PluginId -> CommandFunction IdeState EvalParams -runEvalCmd plId st mtoken EvalParams{..} = - let dbg = logWith st - perf = timed dbg +runEvalCmd :: Recorder (WithPriority Log) -> PluginId -> CommandFunction IdeState EvalParams +runEvalCmd recorder plId st mtoken EvalParams{..} = + let dbg = logWith recorder Debug + perf = timed (\lbl duration -> dbg $ LogExecutionTime lbl duration) cmd :: ExceptT PluginError (LspM Config) WorkspaceEdit cmd = do let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections @@ -226,7 +224,7 @@ runEvalCmd plId st mtoken EvalParams{..} = perf "edits" $ liftIO $ evalGhcEnv final_hscEnv $ do - runTests evalCfg (st, fp) tests + runTests recorder evalCfg fp tests let workspaceEditsMap = Map.singleton _uri (addFinalReturn mdlText edits) let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing Nothing @@ -314,7 +312,7 @@ testsBySection sections = , test <- sectionTests section ] -type TEnv = (IdeState, String) +type TEnv = String -- |GHC declarations required for expression evaluation evalSetup :: Ghc () evalSetup = do @@ -322,26 +320,26 @@ evalSetup = do context <- getContext setContext (IIDecl preludeAsP : context) -runTests :: EvalConfig -> TEnv -> [(Section, Test)] -> Ghc [TextEdit] -runTests EvalConfig{..} e@(_st, _) tests = do +runTests :: Recorder (WithPriority Log) -> EvalConfig -> TEnv -> [(Section, Test)] -> Ghc [TextEdit] +runTests recorder EvalConfig{..} e tests = do df <- getInteractiveDynFlags evalSetup - when (hasQuickCheck df && needsQuickCheck tests) $ void $ evals True e df propSetup + when (hasQuickCheck df && needsQuickCheck tests) $ void $ evals recorder True e df propSetup mapM (processTest e df) tests where processTest :: TEnv -> DynFlags -> (Section, Test) -> Ghc TextEdit - processTest e@(st, fp) df (section, test) = do - let dbg = logWith st + processTest fp df (section, test) = do + let dbg = logWith recorder Debug let pad = pad_ $ (if isLiterate fp then ("> " `T.append`) else id) $ padPrefix (sectionFormat section) rs <- runTest e df test - dbg "TEST RESULTS" rs + dbg $ LogRunTestResults rs let checkedResult = testCheck eval_cfg_diff (section, test) rs let resultLines = concatMap T.lines checkedResult let edit = asEdit (sectionFormat section) test (map pad resultLines) - dbg "TEST EDIT" edit + dbg $ LogRunTestEdits edit return edit -- runTest :: String -> DynFlags -> Loc Test -> Ghc [Text] @@ -350,7 +348,7 @@ runTests EvalConfig{..} e@(_st, _) tests = do return $ singleLine "Add QuickCheck to your cabal dependencies to run this test." - runTest e df test = evals (eval_cfg_exception && not (isProperty test)) e df (asStatements test) + runTest e df test = evals recorder (eval_cfg_exception && not (isProperty test)) e df (asStatements test) asEdit :: Format -> Test -> [Text] -> TextEdit asEdit (MultiLine commRange) test resultLines @@ -426,27 +424,26 @@ Or for a value that does not have a Show instance and can therefore not be displ >>> V No instance for (Show V) arising from a use of ‘evalPrint’ -} -evals :: Bool -> TEnv -> DynFlags -> [Statement] -> Ghc [Text] -evals mark_exception (st, fp) df stmts = do +evals :: Recorder (WithPriority Log) -> Bool -> TEnv -> DynFlags -> [Statement] -> Ghc [Text] +evals recorder mark_exception fp df stmts = do er <- gStrictTry $ mapM eval stmts return $ case er of Left err -> errorLines err Right rs -> concat . catMaybes $ rs where - dbg = logWith st + dbg = logWith recorder Debug eval :: Statement -> Ghc (Maybe [Text]) eval (Located l stmt) | -- GHCi flags Just (words -> flags) <- parseSetFlags stmt = do - dbg "{:SET" flags + dbg $ LogEvalFlags flags ndf <- getInteractiveDynFlags - dbg "pre set" $ showDynFlags ndf + dbg $ LogEvalPreSetDynFlags ndf eans <- liftIO $ try @GhcException $ parseDynamicFlagsCmdLine ndf (map (L $ UnhelpfulSpan unhelpfulReason) flags) - dbg "parsed flags" $ eans - <&> (_1 %~ showDynFlags >>> _3 %~ prettyWarnings) + dbg $ LogEvalParsedFlags eans case eans of Left err -> pure $ Just $ errorLines $ show err Right (df', ignoreds, warns) -> do @@ -460,7 +457,7 @@ evals mark_exception (st, fp) df stmts = do ["Some flags have not been recognized: " <> T.pack (intercalate ", " $ map SrcLoc.unLoc ignoreds) ] - dbg "post set" $ showDynFlags df' + dbg $ LogEvalPostSetDynFlags df' setSessionAndInteractiveDynFlags df' pure $ warnings <> igns | -- A type/kind command @@ -469,23 +466,23 @@ evals mark_exception (st, fp) df stmts = do | -- A statement isStmt pf stmt = do - dbg "{STMT " stmt + dbg $ LogEvalStmtStart stmt res <- exec stmt l let r = case res of Left err -> Just . (if mark_exception then exceptionLines else errorLines) $ err Right x -> singleLine <$> x - dbg "STMT} -> " r + dbg $ LogEvalStmtResult r return r | -- An import isImport pf stmt = do - dbg "{IMPORT " stmt + dbg $ LogEvalImport stmt _ <- addImport stmt return Nothing | -- A declaration otherwise = do - dbg "{DECL " stmt + dbg $ LogEvalDeclaration stmt void $ runDecls stmt return Nothing pf = initParserOpts df @@ -494,19 +491,6 @@ evals mark_exception (st, fp) df stmts = do let opts = execOptions{execSourceFile = fp, execLineNumber = l} in myExecStmt stmt opts -#if MIN_VERSION_ghc(9,8,0) -prettyWarnings :: Messages DriverMessage -> String -prettyWarnings = printWithoutUniques . pprMessages (defaultDiagnosticOpts @DriverMessage) -#else -prettyWarnings :: [Warn] -> String -prettyWarnings = unlines . map prettyWarn - -prettyWarn :: Warn -> String -prettyWarn Warn{..} = - T.unpack (printOutputable $ SrcLoc.getLoc warnMsg) <> ": warning:\n" - <> " " <> SrcLoc.unLoc warnMsg -#endif - needsQuickCheck :: [(Section, Test)] -> Bool needsQuickCheck = any (isProperty . snd) 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 fbc69b30e0..8c9725a90f 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -33,22 +33,15 @@ 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 GHC.Parser.Annotation -import Ide.Logger (Pretty (pretty), - Recorder, WithPriority, +import Ide.Logger (Recorder, WithPriority, cmapWithPrio) import Ide.Plugin.Eval.Types -newtype Log = LogShake Shake.Log deriving Show - -instance Pretty Log where - pretty = \case - LogShake shakeLog -> pretty shakeLog rules :: Recorder (WithPriority Log) -> Rules () rules recorder = do diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index 23fe6fe732..43ea57c956 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -1,12 +1,16 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wwarn #-} module Ide.Plugin.Eval.Types - ( locate, + ( Log(..), + locate, locate0, Test (..), isProperty, @@ -30,17 +34,75 @@ module Ide.Plugin.Eval.Types nullComments) where -import Control.DeepSeq (deepseq) -import Data.Aeson (FromJSON, ToJSON) -import Data.List (partition) -import Data.List.NonEmpty (NonEmpty) -import Data.Map.Strict (Map) -import Data.String (IsString (..)) -import Development.IDE (Range, RuleResult) +import Control.Arrow ((>>>)) +import Control.DeepSeq (deepseq) +import Control.Lens +import Data.Aeson (FromJSON, ToJSON) +import Data.List (partition) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import Data.String (IsString (..)) +import qualified Data.Text as T +import Development.IDE (Range, RuleResult) +import qualified Development.IDE.Core.Shake as Shake +import qualified Development.IDE.GHC.Compat.Core as Core import Development.IDE.Graph.Classes -import GHC.Generics (Generic) -import Language.LSP.Protocol.Types (TextDocumentIdentifier) -import qualified Text.Megaparsec as P +import GHC.Generics (Generic) +import Ide.Logger +import Ide.Plugin.Eval.GHC (showDynFlags) +import Ide.Plugin.Eval.Util +import Language.LSP.Protocol.Types (TextDocumentIdentifier, + TextEdit) +import qualified System.Time.Extra as Extra +import qualified Text.Megaparsec as P + +data Log + = LogShake Shake.Log + | LogCodeLensFp FilePath + | LogCodeLensComments Comments + | LogExecutionTime T.Text Extra.Seconds + | LogTests !Int !Int !Int !Int + | LogRunTestResults [T.Text] + | LogRunTestEdits TextEdit + | LogEvalFlags [String] + | LogEvalPreSetDynFlags Core.DynFlags + | LogEvalParsedFlags + (Either + Core.GhcException + (Core.DynFlags, [Core.Located String], DynFlagsParsingWarnings)) + | LogEvalPostSetDynFlags Core.DynFlags + | LogEvalStmtStart String + | LogEvalStmtResult (Maybe [T.Text]) + | LogEvalImport String + | LogEvalDeclaration String + +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + LogCodeLensFp fp -> "fp" <+> pretty fp + LogCodeLensComments comments -> "comments" <+> viaShow comments + LogExecutionTime lbl duration -> pretty lbl <> ":" <+> pretty (Extra.showDuration duration) + LogTests nTests nNonSetupSections nSetupSections nLenses -> "Tests" <+> fillSep + [ pretty nTests + , "tests in" + , pretty nNonSetupSections + , "sections" + , pretty nSetupSections + , "setups" + , pretty nLenses + , "lenses." + ] + LogRunTestResults results -> "TEST RESULTS" <+> viaShow results + LogRunTestEdits edits -> "TEST EDIT" <+> viaShow edits + LogEvalFlags flags -> "{:SET" <+> pretty flags + LogEvalPreSetDynFlags dynFlags -> "pre set" <+> pretty (showDynFlags dynFlags) + LogEvalParsedFlags eans -> "parsed flags" <+> viaShow (eans + <&> (_1 %~ showDynFlags >>> _3 %~ prettyWarnings)) + LogEvalPostSetDynFlags dynFlags -> "post set" <+> pretty (showDynFlags dynFlags) + LogEvalStmtStart stmt -> "{STMT" <+> pretty stmt + LogEvalStmtResult result -> "STMT}" <+> pretty result + LogEvalImport stmt -> "{IMPORT" <+> pretty stmt + LogEvalDeclaration stmt -> "{DECL" <+> pretty stmt -- | A thing with a location attached. data Located l a = Located {location :: l, located :: a} diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs index 0979e13e81..eb8a47a949 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-} +{-# LANGUAGE RecordWildCards #-} -- |Debug utilities module Ide.Plugin.Eval.Util ( @@ -8,7 +9,8 @@ module Ide.Plugin.Eval.Util ( isLiterate, response', gStrictTry, - logWith, + DynFlagsParsingWarnings, + prettyWarnings, ) where import Control.Exception (SomeException, evaluate, @@ -22,9 +24,11 @@ import Data.Aeson (Value) import Data.Bifunctor (second) import Data.String (IsString (fromString)) import qualified Data.Text as T -import Development.IDE (IdeState, Priority (..), - ideLogger, logPriority) +import Development.IDE (IdeState, + printOutputable) import qualified Development.IDE.Core.PluginUtils as PluginUtils +import qualified Development.IDE.GHC.Compat.Core as Core +import qualified Development.IDE.GHC.Compat.Core as SrcLoc import Development.IDE.GHC.Compat.Outputable import Development.IDE.GHC.Compat.Util (MonadCatch, bagToList, catch) @@ -38,36 +42,16 @@ import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Language.LSP.Server import System.FilePath (takeExtension) +import qualified System.Time.Extra as Extra import System.Time.Extra (duration, showDuration) import UnliftIO.Exception (catchAny) -timed :: MonadIO m => (t -> String -> m a) -> t -> m b -> m b +timed :: MonadIO m => (t -> Extra.Seconds -> m a) -> t -> m b -> m b timed out name op = do (secs, r) <- duration op - _ <- out name (showDuration secs) + _ <- out name secs return r --- | Log using hie logger, reports source position of logging statement -logWith :: (HasCallStack, MonadIO m, Show a1, Show a2) => IdeState -> a1 -> a2 -> m () -logWith state key val = - liftIO . logPriority (ideLogger state) logLevel $ - T.unwords - [T.pack logWithPos, asT key, asT val] - where - logWithPos = - let stk = toList callStack - pr pos = concat [srcLocFile pos, ":", show . srcLocStartLine $ pos, ":", show . srcLocStartCol $ pos] - in case stk of - [] -> "" - (x:_) -> pr $ snd x - - asT :: Show a => a -> T.Text - asT = T.pack . show - --- | Set to Info to see extensive debug info in hie log, set to Debug in production -logLevel :: Priority -logLevel = Debug -- Info - isLiterate :: FilePath -> Bool isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"] @@ -109,3 +93,20 @@ showErr e = _ -> #endif return . show $ e + +#if MIN_VERSION_ghc(9,8,0) +type DynFlagsParsingWarnings = Messages DriverMessage + +prettyWarnings :: DynFlagsParsingWarnings -> String +prettyWarnings = printWithoutUniques . pprMessages (defaultDiagnosticOpts @DriverMessage) +#else +type DynFlagsParsingWarnings = [Core.Warn] + +prettyWarnings :: DynFlagsParsingWarnings -> String +prettyWarnings = unlines . map prettyWarn + +prettyWarn :: Core.Warn -> String +prettyWarn Core.Warn{..} = + T.unpack (printOutputable $ SrcLoc.getLoc warnMsg) <> ": warning:\n" + <> " " <> SrcLoc.unLoc warnMsg +#endif diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index f5871d9d73..48d2886ff0 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -11,7 +11,7 @@ {-# OPTIONS -Wno-orphans #-} -module Ide.Plugin.Retrie (descriptor) where +module Ide.Plugin.Retrie (descriptor, Log) where import Control.Concurrent.STM (readTVarIO) import Control.Exception.Safe (Exception (..), @@ -135,11 +135,18 @@ import System.Directory (makeAbsolute) import GHC.Types.PkgQual #endif -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = +data Log + = LogParsingModule FilePath + +instance Pretty Log where + pretty = \case + LogParsingModule fp -> "Parsing module:" <+> pretty fp + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId "Provides code actions to inline Haskell definitions") { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction provider, - pluginCommands = [retrieCommand, retrieInlineThisCommand] + pluginCommands = [retrieCommand recorder, retrieInlineThisCommand recorder] } retrieCommandId :: CommandId @@ -148,14 +155,14 @@ retrieCommandId = "retrieCommand" retrieInlineThisCommandId :: CommandId retrieInlineThisCommandId = "retrieInlineThisCommand" -retrieCommand :: PluginCommand IdeState -retrieCommand = - PluginCommand retrieCommandId "run the refactoring" runRetrieCmd +retrieCommand :: Recorder (WithPriority Log) -> PluginCommand IdeState +retrieCommand recorder = + PluginCommand retrieCommandId "run the refactoring" (runRetrieCmd recorder) -retrieInlineThisCommand :: PluginCommand IdeState -retrieInlineThisCommand = +retrieInlineThisCommand :: Recorder (WithPriority Log) -> PluginCommand IdeState +retrieInlineThisCommand recorder = PluginCommand retrieInlineThisCommandId "inline function call" - runRetrieInlineThisCmd + (runRetrieInlineThisCmd recorder) -- | Parameters for the runRetrie PluginCommand. data RunRetrieParams = RunRetrieParams @@ -166,8 +173,8 @@ data RunRetrieParams = RunRetrieParams } deriving (Eq, Show, Generic, FromJSON, ToJSON) -runRetrieCmd :: CommandFunction IdeState RunRetrieParams -runRetrieCmd state token RunRetrieParams{originatingFile = uri, ..} = ExceptT $ +runRetrieCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState RunRetrieParams +runRetrieCmd recorder state token RunRetrieParams{originatingFile = uri, ..} = ExceptT $ withIndefiniteProgress description token Cancellable $ \_updater -> do _ <- runExceptT $ do nfp <- getNormalizedFilePathE uri @@ -179,6 +186,7 @@ runRetrieCmd state token RunRetrieParams{originatingFile = uri, ..} = ExceptT $ let importRewrites = concatMap (extractImports ms binds) rewrites (errors, edits) <- liftIO $ callRetrie + recorder state (hscEnv session) (map Right rewrites <> map Left importRewrites) @@ -201,8 +209,8 @@ data RunRetrieInlineThisParams = RunRetrieInlineThisParams } deriving (Eq, Show, Generic, FromJSON, ToJSON) -runRetrieInlineThisCmd :: CommandFunction IdeState RunRetrieInlineThisParams -runRetrieInlineThisCmd state _token RunRetrieInlineThisParams{..} = do +runRetrieInlineThisCmd :: Recorder (WithPriority Log) -> CommandFunction IdeState RunRetrieInlineThisParams +runRetrieInlineThisCmd recorder state _token RunRetrieInlineThisParams{..} = do nfp <- getNormalizedFilePathE $ getLocationUri inlineIntoThisLocation nfpSource <- getNormalizedFilePathE $ getLocationUri inlineFromThisLocation -- What we do here: @@ -219,7 +227,7 @@ runRetrieInlineThisCmd state _token RunRetrieInlineThisParams{..} = do when (null inlineRewrite) $ throwError $ PluginInternalError "Empty rewrite" (session, _) <- runActionE "retrie" state $ useWithStaleE GhcSessionDeps nfp - (fixityEnv, cpp) <- liftIO $ getCPPmodule state (hscEnv session) $ fromNormalizedFilePath nfp + (fixityEnv, cpp) <- liftIO $ getCPPmodule recorder state (hscEnv session) $ fromNormalizedFilePath nfp result <- liftIO $ try @_ @SomeException $ runRetrie fixityEnv (applyWithUpdate myContextUpdater inlineRewrite) cpp case result of @@ -506,13 +514,14 @@ instance Show CallRetrieError where instance Exception CallRetrieError callRetrie :: + Recorder (WithPriority Log) -> IdeState -> HscEnv -> [Either ImportSpec RewriteSpec] -> NormalizedFilePath -> Bool -> IO ([CallRetrieError], WorkspaceEdit) -callRetrie state session rewrites origin restrictToOriginatingFile = do +callRetrie recorder state session rewrites origin restrictToOriginatingFile = do knownFiles <- toKnownFiles . unhashed <$> readTVarIO (knownTargetsVar $ shakeExtras state) let -- TODO cover all workspaceFolders @@ -540,7 +549,7 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do targets <- getTargetFiles retrieOptions (getGroundTerms retrie) results <- forM targets $ \t -> runExceptT $ do - (fixityEnv, cpp) <- ExceptT $ try $ getCPPmodule state session t + (fixityEnv, cpp) <- ExceptT $ try $ getCPPmodule recorder state session t -- TODO add the imports to the resulting edits (_user, _ast, change@(Change _replacements _imports)) <- lift $ runRetrie fixityEnv retrie cpp @@ -751,8 +760,8 @@ reuseParsedModule state f = do (fixities, pm') <- fixFixities state f (fixAnns pm) return (fixities, pm') -getCPPmodule :: IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule) -getCPPmodule state session t = do +getCPPmodule :: Recorder (WithPriority Log) -> IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule) +getCPPmodule recorder state session t = do nt <- toNormalizedFilePath' <$> makeAbsolute t let getParsedModule f contents = do modSummary <- msrModSummary <$> @@ -762,7 +771,7 @@ getCPPmodule state session t = do { ms_hspp_buf = Just (stringToStringBuffer contents) } - logPriority (ideLogger state) Info $ T.pack $ "Parsing module: " <> t + logWith recorder Info $ LogParsingModule t parsed <- evalGhcEnv session (GHCGHC.parseModule ms') `catch` \e -> throwIO (GHCParseError nt (show @SomeException e)) (fixities, parsed) <- fixFixities state f (fixAnns parsed) diff --git a/plugins/hls-retrie-plugin/test/Main.hs b/plugins/hls-retrie-plugin/test/Main.hs index 21fae51642..96a25b0c4c 100644 --- a/plugins/hls-retrie-plugin/test/Main.hs +++ b/plugins/hls-retrie-plugin/test/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} @@ -7,21 +8,31 @@ module Main (main) where import Control.Monad (void) import qualified Data.Map as M import Data.Text (Text) -import qualified Development.IDE.GHC.ExactPrint +import qualified Development.IDE.GHC.ExactPrint as ExactPrint import qualified Development.IDE.Plugin.CodeAction as Refactor +import Ide.Logger import Ide.Plugin.Config import qualified Ide.Plugin.Retrie as Retrie import System.FilePath import Test.Hls +data LogWrap + = RetrieLog Retrie.Log + | ExactPrintLog ExactPrint.Log + +instance Pretty LogWrap where + pretty = \case + RetrieLog msg -> pretty msg + ExactPrintLog msg -> pretty msg + main :: IO () main = defaultTestRunner tests -retriePlugin :: PluginTestDescriptor a -retriePlugin = mkPluginTestDescriptor' Retrie.descriptor "retrie" +retriePlugin :: PluginTestDescriptor LogWrap +retriePlugin = mkPluginTestDescriptor (Retrie.descriptor . cmapWithPrio RetrieLog) "retrie" -refactorPlugin :: PluginTestDescriptor Development.IDE.GHC.ExactPrint.Log -refactorPlugin = mkPluginTestDescriptor Refactor.iePluginDescriptor "refactor" +refactorPlugin :: PluginTestDescriptor LogWrap +refactorPlugin = mkPluginTestDescriptor (Refactor.iePluginDescriptor . cmapWithPrio ExactPrintLog) "refactor" tests :: TestTree tests = testGroup "Retrie" @@ -79,7 +90,7 @@ goldenWithRetrie title path act = runWithRetrie :: Session a -> IO a runWithRetrie = runSessionWithServer def testPlugins testDataDir -testPlugins :: PluginTestDescriptor Development.IDE.GHC.ExactPrint.Log +testPlugins :: PluginTestDescriptor LogWrap testPlugins = retriePlugin <> refactorPlugin -- needed for the GetAnnotatedParsedSource rule diff --git a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs index 795b3e7172..a862e57fb8 100644 --- a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs +++ b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs @@ -1,9 +1,11 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} module Ide.Plugin.StylishHaskell ( descriptor , provider + , Log ) where @@ -26,9 +28,17 @@ import Language.LSP.Protocol.Types as LSP import System.Directory import System.FilePath -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId desc) - { pluginHandlers = mkFormattingHandlers provider +data Log + = LogLanguageExtensionFromDynFlags + +instance Pretty Log where + pretty = \case + LogLanguageExtensionFromDynFlags -> "stylish-haskell uses the language extensions from DynFlags" + + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId desc) + { pluginHandlers = mkFormattingHandlers (provider recorder) } where desc = "Provides formatting of Haskell files via stylish-haskell. Built with stylish-haskell-" <> VERSION_stylish_haskell @@ -36,8 +46,8 @@ descriptor plId = (defaultPluginDescriptor plId desc) -- | Formatter provider of stylish-haskell. -- Formats the given source in either a given Range or the whole Document. -- If the provider fails an error is returned that can be displayed to the user. -provider :: FormattingHandler IdeState -provider ide _token typ contents fp _opts = do +provider :: Recorder (WithPriority Log) -> FormattingHandler IdeState +provider recorder ide _token typ contents fp _opts = do (msrModSummary -> ms_hspp_opts -> dyn) <- runActionE "stylish-haskell" ide $ useE GetModSummary fp let file = fromNormalizedFilePath fp config <- liftIO $ loadConfigFrom file @@ -53,7 +63,7 @@ provider ide _token typ contents fp _opts = do getMergedConfig dyn config | null (configLanguageExtensions config) = do - logInfo (ideLogger ide) "stylish-haskell uses the language extensions from DynFlags" + logWith recorder Info LogLanguageExtensionFromDynFlags pure $ config { configLanguageExtensions = getExtensions dyn } diff --git a/plugins/hls-stylish-haskell-plugin/test/Main.hs b/plugins/hls-stylish-haskell-plugin/test/Main.hs index f8e55e8913..22e9499947 100644 --- a/plugins/hls-stylish-haskell-plugin/test/Main.hs +++ b/plugins/hls-stylish-haskell-plugin/test/Main.hs @@ -10,8 +10,8 @@ import Test.Hls main :: IO () main = defaultTestRunner tests -stylishHaskellPlugin :: PluginTestDescriptor () -stylishHaskellPlugin = mkPluginTestDescriptor' StylishHaskell.descriptor "stylishHaskell" +stylishHaskellPlugin :: PluginTestDescriptor StylishHaskell.Log +stylishHaskellPlugin = mkPluginTestDescriptor StylishHaskell.descriptor "stylishHaskell" tests :: TestTree tests = testGroup "stylish-haskell" diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 1f5d091dc5..f08ae187cd 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -178,13 +178,13 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins let pId = "ormolu" in Ormolu.descriptor (pluginRecorder pId) pId : #endif #if hls_stylishHaskell - StylishHaskell.descriptor "stylish-haskell" : + let pId = "stylish-haskell" in StylishHaskell.descriptor (pluginRecorder pId) pId : #endif #if hls_rename let pId = "rename" in Rename.descriptor (pluginRecorder pId) pId: #endif #if hls_retrie - Retrie.descriptor "retrie" : + let pId = "retrie" in Retrie.descriptor (pluginRecorder pId) pId : #endif #if hls_callHierarchy CallHierarchy.descriptor "callHierarchy" : diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index c1f98acbe9..457e0dc4ec 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -12,18 +12,18 @@ import Control.Monad.Extra import qualified Data.Aeson.Encode.Pretty as A import Data.Coerce (coerce) import Data.Default +import Data.Function ((&)) import Data.List (sortOn) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Lazy.Encoding (decodeUtf8) import qualified Data.Text.Lazy.IO as LT import Development.IDE.Core.Rules hiding (Log, logToPriority) -import Development.IDE.Core.Tracing (withTelemetryLogger) +import Development.IDE.Core.Tracing (withTelemetryRecorder) import Development.IDE.Main (isLSP) import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Session as Session import qualified Development.IDE.Types.Options as Ghcide -import GHC.Stack (emptyCallStack) import qualified HIE.Bios.Environment as HieBios import HIE.Bios.Types hiding (Log) import qualified HIE.Bios.Types as HieBios @@ -121,7 +121,7 @@ defaultMain recorder args idePlugins = do -- --------------------------------------------------------------------- runLspMode :: Recorder (WithPriority Log) -> GhcideArguments -> IdePlugins IdeState -> IO () -runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLogger $ \telemetryLogger -> do +runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryRecorder $ \telemetryRecorder' -> do let log = logWith recorder whenJust argsCwd IO.setCurrentDirectory dir <- IO.getCurrentDirectory @@ -130,14 +130,13 @@ runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLog when (isLSP argsCommand) $ do log Info $ LogLspStart ghcideArgs (map pluginId $ ipMap idePlugins) - -- exists so old-style logging works. intended to be phased out - let logger = Logger $ \p m -> logger_ recorder (WithPriority p emptyCallStack $ LogOther m) - args = (if argsTesting then IDEMain.testing else IDEMain.defaultArguments) - (cmapWithPrio LogIDEMain recorder) logger idePlugins + let args = (if argsTesting then IDEMain.testing else IDEMain.defaultArguments) + (cmapWithPrio LogIDEMain recorder) idePlugins - IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) args + let telemetryRecorder = telemetryRecorder' & cmapWithPrio pretty + + IDEMain.defaultMain (cmapWithPrio LogIDEMain $ recorder <> telemetryRecorder) args { IDEMain.argCommand = argsCommand - , IDEMain.argsLogger = pure logger <> pure telemetryLogger , IDEMain.argsThreads = if argsThreads == 0 then Nothing else Just $ fromIntegral argsThreads , IDEMain.argsIdeOptions = \config sessionLoader -> let defOptions = IDEMain.argsIdeOptions args config sessionLoader