diff --git a/exe/Main.hs b/exe/Main.hs index e5ba2cb6a7..d3f8af8d00 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,21 +1,50 @@ -- 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 Development.IDE.Types.Logger (Priority (Debug, Info), + WithPriority (WithPriority, priority), + cfilter, cmapWithPrio, + makeDefaultStderrRecorder, + withDefaultRecorder) +import Ide.Arguments (Arguments (..), + GhcideArguments (..), + getArguments) +import Ide.Main (defaultMain) +import qualified Ide.Main as IdeMain +import qualified Plugins +import Prettyprinter (Pretty (pretty)) + +data Log + = LogIdeMain IdeMain.Log + | LogPlugins Plugins.Log + +instance Pretty Log where + pretty log = case log of + LogIdeMain ideMainLog -> pretty ideMainLog + LogPlugins pluginsLog -> pretty pluginsLog main :: IO () main = do - args <- getArguments "haskell-language-server" (idePlugins 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 + pluginCliRecorder <- cmapWithPrio pretty <$> makeDefaultStderrRecorder Nothing Info + args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder) 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 + withDefaultRecorder logFilePath Nothing minPriority $ \textWithPriorityRecorder -> do + let recorder = + textWithPriorityRecorder + & cfilter (\WithPriority{ priority } -> priority >= minPriority) + & cmapWithPrio pretty - defaultMain args (idePlugins withExamples) + defaultMain (cmapWithPrio LogIdeMain recorder) args (Plugins.idePlugins (cmapWithPrio LogPlugins recorder) includeExamplePlugins) diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 3934b61de8..7a55c5ea00 100644 --- a/exe/Plugins.hs +++ b/exe/Plugins.hs @@ -1,75 +1,78 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} module Plugins where +import Development.IDE.Types.Logger (Pretty (pretty), Recorder, + WithPriority, cmapWithPrio) import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types (IdePlugins) -- fixed plugins import Development.IDE (IdeState) -import Development.IDE.Plugin.HLS.GhcIde as GhcIde -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 #if selectionRange @@ -79,25 +82,30 @@ import Ide.Plugin.SelectionRange as SelectionRange -- 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 Ide.Plugin.Brittany as Brittany +import qualified Ide.Plugin.Brittany as Brittany #endif +data Log = forall a. (Pretty a) => Log a + +instance Pretty Log where + pretty (Log a) = pretty a + -- --------------------------------------------------------------------- -- | The plugins configured for use in this instance of the language @@ -105,9 +113,11 @@ 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 (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 @@ -122,7 +132,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins Fourmolu.descriptor "fourmolu" : #endif #if tactic - Tactic.descriptor "tactics" : + Tactic.descriptor pluginRecorder "tactics" : #endif #if ormolu Ormolu.descriptor "ormolu" : @@ -149,36 +159,36 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins HaddockComments.descriptor "haddockComments" : #endif #if eval - Eval.descriptor "eval" : + Eval.descriptor pluginRecorder "eval" : #endif #if importLens - ExplicitImports.descriptor "importLens" : + ExplicitImports.descriptor pluginRecorder "importLens" : #endif #if qualifyImportedNames QualifyImportedNames.descriptor "qualifyImportedNames" : #endif #if refineImports - RefineImports.descriptor "refineImports" : + RefineImports.descriptor pluginRecorder "refineImports" : #endif #if moduleName ModuleName.descriptor "moduleName" : #endif #if hlint - Hlint.descriptor "hlint" : + Hlint.descriptor pluginRecorder "hlint" : #endif #if splice Splice.descriptor "splice" : #endif #if alternateNumberFormat - AlternateNumberFormat.descriptor "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 + GhcIde.descriptors pluginRecorder examplePlugins = - [Example.descriptor "eg" - ,Example2.descriptor "eg2" + [Example.descriptor pluginRecorder "eg" + ,Example2.descriptor pluginRecorder "eg2" ] diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index c743231255..178052da71 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -9,17 +9,28 @@ import Arguments (Arguments (..), getArguments) import Control.Monad.Extra (unless) 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 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 (Logger (Logger), + LoggingColumn (DataColumn, PriorityColumn), + Pretty (pretty), + Priority (Debug, Info), + Recorder (Recorder), + WithPriority (WithPriority, priority), + cfilter, cmapWithPrio, + 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) @@ -29,6 +40,17 @@ import System.Exit (exitSuccess) import System.IO (hPutStrLn, stderr) import System.Info (compilerVersion) +data Log + = LogIDEMain IDEMain.Log + | LogRules Rules.Log + | LogGhcIde GhcIde.Log + +instance Pretty Log where + pretty = \case + LogIDEMain log -> pretty log + LogRules log -> pretty log + LogGhcIde log -> pretty log + ghcideVersion :: IO String ghcideVersion = do path <- getExecutablePath @@ -42,7 +64,12 @@ ghcideVersion = do main :: IO () main = withTelemetryLogger $ \telemetryLogger -> do - let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors + -- stderr recorder just for plugin cli commands + pluginCliRecorder <- + cmapWithPrio pretty + <$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Info + + 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 @@ -55,26 +82,42 @@ 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 + + docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) minPriority + + let docWithFilteredPriorityRecorder@Recorder{ logger_ } = + docWithPriorityRecorder + & cfilter (\WithPriority{ priority } -> priority >= minPriority) + + -- 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 + + let arguments = + if argsTesting + then IDEMain.testing (cmapWithPrio LogIDEMain recorder) logger + else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger - Main.defaultMain arguments - { Main.argsProjectRoot = Just argsCwd - , Main.argCommand = argsCommand - ,Main.argsLogger = Main.argsLogger arguments <> pure telemetryLogger + IDEMain.defaultMain (cmapWithPrio 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 (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 $ 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 19d9ed4aaa..07d4595652 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 @@ -27,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 @@ -44,11 +46,12 @@ 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, Priority, + withHieDb) import qualified Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile, TargetModule, - Var) + Var, 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) @@ -60,7 +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 +import Development.IDE.Types.Logger (Pretty (pretty), + Priority (Debug, Error, Info, Warning), + Recorder, WithPriority, + logWith, nest, vcat, + viaShow, (<+>)) import Development.IDE.Types.Options import GHC.Check import qualified HIE.Bios as HieBios @@ -72,7 +79,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 ((<|>))) @@ -82,6 +88,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 +100,94 @@ import HieDb.Utils import System.Random (RandomGen) import qualified System.Random as Random +data Log + = LogSettingInitialDynFlags + | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void) + | LogGetInitialGhcLibDirDefaultCradleNone + | LogHieDbRetry !Int !Int !Int !SomeException + | LogHieDbRetriesExhausted !Int !Int !Int !SomeException + | LogHieDbWriterThreadSQLiteError !SQLError + | LogHieDbWriterThreadException !SomeException + | LogInterfaceFilesCacheDir !FilePath + | LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedFilePath)) + | LogMakingNewHscEnv ![UnitId] + | LogDLLLoadError !String + | LogCradlePath !FilePath + | LogCradleNotFound !FilePath + | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath)) + | LogCradle !(Cradle Void) + | LogNoneCradleFound FilePath + | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) +deriving instance Show Log + +instance Pretty Log where + pretty = \case + LogNoneCradleFound path -> + "None cradle found for" <+> pretty path <+> ", ignoring the file" + LogSettingInitialDynFlags -> + "Setting initial dynflags..." + LogGetInitialGhcLibDirDefaultCradleFail cradleError rootDirPath hieYamlPath cradle -> + nest 2 $ + vcat + [ "Couldn't load cradle for ghc libdir." + , "Cradle error:" <+> viaShow cradleError + , "Root dir path:" <+> pretty rootDirPath + , "hie.yaml path:" <+> pretty hieYamlPath + , "Cradle:" <+> viaShow cradle ] + LogGetInitialGhcLibDirDefaultCradleNone -> + "Couldn't load cradle. Cradle not found." + LogHieDbRetry delay maxDelay maxRetryCount e -> + 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 -> + 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 -> + nest 2 $ + vcat + [ "HieDb writer thread SQLite error:" + , pretty (displayException e) ] + LogHieDbWriterThreadException e -> + nest 2 $ + vcat + [ "HieDb writer thread exception:" + , pretty (displayException e) ] + LogInterfaceFilesCacheDir path -> + "Interface files cache directory:" <+> pretty path + LogKnownFilesUpdated targetToPathsMap -> + nest 2 $ + vcat + [ "Known files updated:" + , 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 -> + 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:" <+> viaShow e + LogCradle cradle -> + "Cradle:" <+> viaShow cradle + LogNewComponentCache 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 hiedbDataVersion = "1" @@ -110,7 +206,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 (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, @@ -119,7 +215,7 @@ data SessionLoadingOptions = SessionLoadingOptions } instance Default SessionLoadingOptions where - def = SessionLoadingOptions + def = SessionLoadingOptions {findCradle = HieBios.findCradle ,loadCradle = loadWithImplicitCradle ,getCacheDirs = getCacheDirsDefault @@ -148,26 +244,27 @@ 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 (WithPriority 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 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 Warning $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle pure Nothing CradleNone -> do - hPutStrLn stderr "Couldn't load cradle (CradleNone)" + log Warning 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 (WithPriority Log) -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir) +setInitialDynFlags recorder rootDir SessionLoadingOptions{..} = do + libdir <- getInitialGhcLibDir recorder rootDir dynFlags <- mapM dynFlagsForPrinting libdir + logWith recorder Debug LogSettingInitialDynFlags mapM_ setUnsafeGlobalDynFlags dynFlags pure libdir @@ -180,14 +277,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 (WithPriority 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 +294,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 Warning $ 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 Warning $ 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 +320,30 @@ maxRetryCount :: Int maxRetryCount = 10 retryOnSqliteBusy :: (MonadIO m, MonadCatch m, RandomGen g) - => Logger -> g -> m a -> m a -retryOnSqliteBusy logger rng action = + => Recorder (WithPriority 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 (WithPriority 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 (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 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 +352,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 +369,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 Error $ LogHieDbWriterThreadSQLiteError e `Safe.catchAny` \e -> do - logDebug logger $ T.pack $ "Uncaught error in database worker, ignoring: " ++ show e + log Error $ LogHieDbWriterThreadException e getHieDbLoc :: FilePath -> IO FilePath @@ -310,11 +398,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 (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession) +loadSession recorder = loadSessionWithOptions recorder def -loadSessionWithOptions :: SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) -loadSessionWithOptions SessionLoadingOptions{..} dir = do +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) -- Mapping from a Filepath to HscEnv @@ -340,7 +428,7 @@ loadSessionWithOptions 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 @@ -371,8 +459,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 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 @@ -412,7 +499,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 +514,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 Info $ LogMakingNewHscEnv inplace hscEnv <- emptyHscEnv ideNc libDir newHscEnv <- -- Add the options for the current component to the HscEnv @@ -463,9 +550,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 Error $ LogDLLLoadError err + -- Make a map from unit-id to DynFlags, this is used when trying to -- resolve imports. (especially PackageImports) @@ -476,7 +563,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 +600,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 Info $ LogCradlePath lfp when (isNothing hieYaml) $ - logWarning logger $ implicitCradleWarning lfp + log Warning $ LogCradleNotFound lfp cradle <- loadCradle hieYaml dir lfp <- flip makeRelative cfp <$> getCurrentDirectory @@ -530,12 +617,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 Debug $ LogSessionLoadingResult eopts case eopts of -- The cradle gave us some options so get to work turning them -- into and HscEnv. @@ -598,18 +684,19 @@ 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 :: Recorder (WithPriority Log) -> Cradle Void -> FilePath -> IO (Either [CradleError] (ComponentOptions, FilePath)) -cradleToOptsAndLibDir logger cradle file = do - let noneCradleFoundMessage :: FilePath -> T.Text - noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file" +cradleToOptsAndLibDir recorder cradle file = do + -- let noneCradleFoundMessage :: FilePath -> T.Text + -- noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file" -- Start off by getting the session options - logDebug logger $ T.pack $ "Output from setting up the cradle " <> show cradle + logWith recorder Debug $ LogCradle cradle cradleRes <- HieBios.getCompilerOptions file cradle case cradleRes of CradleSuccess r -> do @@ -620,12 +707,12 @@ cradleToOptsAndLibDir logger cradle file = do CradleSuccess libDir -> pure (Right (r, libDir)) CradleFail err -> return (Left [err]) CradleNone -> do - logInfo logger $ noneCradleFoundMessage file + logWith recorder Info $ LogNoneCradleFound file return (Left []) CradleFail err -> return (Left [err]) CradleNone -> do - logInfo logger $ noneCradleFoundMessage file + logWith recorder Info $ LogNoneCradleFound file return (Left []) emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv @@ -672,7 +759,7 @@ setNameCache nc hsc = hsc { hsc_NC = nc } -- | Create a mapping from FilePaths to HscEnvEqs newComponentCache - :: Logger + :: Recorder (WithPriority Log) -> [String] -- File extensions to consider -> Maybe FilePath -- Path to cradle -> NormalizedFilePath -- Path to file that caused the creation of this component @@ -680,7 +767,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 +777,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 Debug $ LogNewComponentCache res let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends ctargets <- concatMapM mk (componentTargets ci) @@ -758,9 +845,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 (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags +setCacheDirs recorder CacheDirs{..} dflags = do + logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir) pure $ dflags & maybe id setHiDir hiCacheDir & maybe id setHieDir hieCacheDir @@ -933,12 +1020,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/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 15cddd821e..d30f8047f2 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,17 @@ 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, LogShake) +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 (Pretty (pretty), + Recorder, WithPriority, + cmapWithPrio) import Development.IDE.Types.Options import qualified Focus import Ide.Plugin.Config (Config) @@ -82,6 +88,16 @@ newtype FileExistsMapVar = FileExistsMapVar FileExistsMap instance IsIdeGlobal FileExistsMapVar +data Log + = LogFileStore FileStore.Log + | LogShake Shake.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogFileStore log -> pretty log + LogShake log -> pretty log + -- | Grab the current global value of 'FileExistsMap' without acquiring a dependency getFileExistsMapUntracked :: Action FileExistsMap getFileExistsMapUntracked = do @@ -157,8 +173,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 (WithPriority 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 +195,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 (cmapWithPrio 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 (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> VFSHandle -> Rules () +fileExistsRulesFast recorder isWatched vfs = + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetFileExists file -> do isWF <- isWatched file if isWF then fileExistsFast vfs file @@ -225,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 :: VFSHandle -> Rules () -fileExistsRulesSlow vfs = - defineEarlyCutoff $ RuleNoDiagnostics $ \GetFileExists file -> fileExistsSlow vfs file +fileExistsRulesSlow :: Recorder (WithPriority Log) -> VFSHandle -> Rules () +fileExistsRulesSlow recorder vfs = + 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 f6f93d3c02..81a2fea695 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,14 @@ import qualified Data.HashSet as HSet 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 (Pretty (pretty), + Priority (Info), + Recorder, + WithPriority, + cmapWithPrio, + logWith, viaShow, + (<+>)) import Language.LSP.Server hiding (getVirtualFile) import qualified Language.LSP.Server as LSP @@ -80,6 +89,23 @@ import qualified Language.LSP.Types.Capabilities as LSP import Language.LSP.VFS import System.FilePath +data Log + = LogCouldNotIdentifyReverseDeps !NormalizedFilePath + | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath]) + | LogShake Shake.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogCouldNotIdentifyReverseDeps path -> + "Could not identify reverse dependencies for" <+> viaShow path + (LogTypeCheckingReverseDeps path reverseDepPaths) -> + "Typechecking reverse dependecies for" + <+> viaShow path + <> ":" + <+> pretty (fmap (fmap show) reverseDepPaths) + LogShake log -> pretty log + makeVFSHandle :: IO VFSHandle makeVFSHandle = do vfsVar <- newVar (1, Map.empty) @@ -101,8 +127,8 @@ makeLSPVFSHandle lspEnv = VFSHandle , setVirtualFileContents = Nothing } -addWatchedFileRule :: (NormalizedFilePath -> Action Bool) -> Rules () -addWatchedFileRule isWatched = defineNoDiagnostics $ \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 @@ -114,8 +140,8 @@ addWatchedFileRule isWatched = defineNoDiagnostics $ \AddWatchedFile f -> do Nothing -> pure $ Just False -getModificationTimeRule :: VFSHandle -> Rules () -getModificationTimeRule vfs = defineEarlyCutoff $ 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 @@ -201,8 +227,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 (WithPriority Log) -> VFSHandle -> Rules () +getFileContentsRule recorder vfs = define (cmapWithPrio LogShake recorder) $ \GetFileContents file -> getFileContentsImpl vfs file getFileContentsImpl :: VFSHandle @@ -240,20 +266,21 @@ getFileContents f = do pure $ posixSecondsToUTCTime posix return (modTime, txt) -fileStoreRules :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules () -fileStoreRules vfs isWatched = do +fileStoreRules :: Recorder (WithPriority 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. -setFileModified :: IdeState +setFileModified :: Recorder (WithPriority 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 +293,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 (WithPriority 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 (WithPriority 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 Info $ LogCouldNotIdentifyReverseDeps nfp Just rs -> do - liftIO $ (log $ "Typechecking reverse dependencies for " ++ show nfp ++ ": " ++ show revs) - `catch` \(e :: SomeException) -> log (show e) + 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 8f31856098..3d50287c3b 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -14,8 +14,10 @@ module Development.IDE.Core.OfInterest( deleteFileOfInterest, setFilesOfInterest, kick, FileOfInterestStatus(..), - OfInterestVar(..) - ,scheduleGarbageCollection) where + OfInterestVar(..), + scheduleGarbageCollection, + Log(..) + ) where import Control.Concurrent.Strict import Control.Monad @@ -32,24 +34,37 @@ 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 -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 +data Log = LogShake Shake.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + 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 (WithPriority Log) -> Rules () +ofInterestRules recorder = do addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty) addIdeGlobal . GarbageCollectVar =<< liftIO (newVar False) - defineEarlyCutoff $ 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 ba4bec4e50..5e8b33a28c 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(..), DisplayTHWarning(..), ) where @@ -96,25 +97,27 @@ 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 (LogShake, 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 (LogShake, 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 (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 + Var, + (<+>)) +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 +import Development.IDE.GHC.ExactPrint hiding (LogShake, Log) import Development.IDE.GHC.Util hiding (modifyDynFlags) import Development.IDE.Graph @@ -127,7 +130,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 qualified GHC.LanguageExtensions as LangExt @@ -150,6 +152,35 @@ 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, Pretty (pretty), (<+>), nest, vcat) +import qualified Development.IDE.Core.Shake as Shake +import qualified Development.IDE.GHC.ExactPrint as ExactPrint hiding (LogShake) +import qualified Development.IDE.Types.Logger as Logger + +data Log + = LogShake Shake.Log + | LogReindexingHieFile !NormalizedFilePath + | LogLoadingHieFile !NormalizedFilePath + | LogLoadingHieFileFail !FilePath !SomeException + | LogLoadingHieFileSuccess !FilePath + | LogExactPrint ExactPrint.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + LogReindexingHieFile path -> + "Re-indexing hie file for" <+> pretty (fromNormalizedFilePath path) + LogLoadingHieFile path -> + "LOADING HIE FILE FOR" <+> pretty (fromNormalizedFilePath path) + LogLoadingHieFileFail path e -> + nest 2 $ + vcat + [ "FAILED LOADING HIE FILE FOR" <+> pretty path + , pretty (displayException e) ] + LogLoadingHieFileSuccess path -> + "SUCCEEDED LOADING HIE FILE FOR" <+> pretty path + LogExactPrint log -> pretty log templateHaskellInstructions :: T.Text templateHaskellInstructions = "https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html#static-binaries" @@ -207,10 +238,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 (WithPriority Log) -> Rules () +getParsedModuleRule recorder = -- this rule does not have early cutoff since all its dependencies already have it - define $ \GetParsedModule file -> do + define (cmapWithPrio LogShake recorder) $ \GetParsedModule file -> do ModSummaryResult{msrModSummary = ms'} <- use_ GetModSummary file sess <- use_ GhcSession file let hsc = hscEnv sess @@ -280,11 +311,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 (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 $ \GetParsedModuleWithComments file -> do + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetParsedModuleWithComments file -> do ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file sess <- use_ GhcSession file opt <- getIdeOptions @@ -315,9 +346,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 (WithPriority Log) -> Rules () +getLocatedImportsRule recorder = + define (cmapWithPrio LogShake recorder) $ \GetLocatedImports file -> do ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file targets <- useNoFile_ GetKnownTargets let targetsMap = HM.mapWithKey const targets @@ -474,15 +505,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 (WithPriority Log) -> Rules () +getDependencyInformationRule recorder = + define (cmapWithPrio 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 (WithPriority Log) -> Rules () +reportImportCyclesRule recorder = + 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 @@ -514,16 +545,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 (WithPriority Log) -> Rules () +getHieAstsRule recorder = + define (cmapWithPrio LogShake recorder) $ \GetHieAst f -> do tmr <- use_ TypeCheck f hsc <- hscEnv <$> use_ GhcSessionDeps f getHieAstRuleDefinition f hsc tmr -persistentHieFileRule :: Rules () -persistentHieFileRule = addPersistentRule GetHieAst $ \file -> runMaybeT $ do - res <- readHieFileForSrcFromDisk file +persistentHieFileRule :: Recorder (WithPriority Log) -> Rules () +persistentHieFileRule recorder = addPersistentRule GetHieAst $ \file -> runMaybeT $ do + res <- readHieFileForSrcFromDisk recorder file vfs <- asks vfs (currentSource,ver) <- liftIO $ do mvf <- getVirtualFile vfs $ filePathToUri' file @@ -557,8 +588,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 (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) @@ -567,17 +598,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 (WithPriority Log) -> Rules () +getBindingsRule recorder = + 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 :: Rules () -getDocMapRule = - define $ \GetDocMap file -> do +getDocMapRule :: Recorder (WithPriority Log) -> Rules () +getDocMapRule recorder = + 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 @@ -591,40 +622,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 (WithPriority 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 Logger.Debug $ LogLoadingHieFile file + exceptToMaybeT $ readHieFileFromDisk recorder hie_loc -readHieFileFromDisk :: FilePath -> ExceptT SomeException IdeAction Compat.HieFile -readHieFileFromDisk hie_loc = do +readHieFileFromDisk :: Recorder (WithPriority 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 Logger.Debug $ LogLoadingHieFileFail hie_loc e + Right _ -> log Logger.Debug $ LogLoadingHieFileSuccess hie_loc except res -- | Typechecks a module. -typeCheckRule :: Rules () -typeCheckRule = define $ \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 :: Rules () -knownFilesRule = defineEarlyCutOffNoFile $ \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 :: Rules () -getModuleGraphRule = defineNoFile $ \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 @@ -663,11 +693,11 @@ currentLinkables = do where go (mod, time) = LM time mod [] -loadGhcSession :: GhcSessionDepsConfig -> Rules () -loadGhcSession ghcSessionDepsConfig = do +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 $ \GhcSessionIO -> do + defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GhcSessionIO -> do alwaysRerun opts <- getIdeOptions res <- optGhcSession opts @@ -675,7 +705,7 @@ loadGhcSession ghcSessionDepsConfig = do let fingerprint = LBS.toStrict $ B.encode $ hash (sessionVersion res) return (fingerprint, res) - defineEarlyCutoff $ Rule $ \GhcSession file -> do + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file @@ -700,7 +730,7 @@ loadGhcSession ghcSessionDepsConfig = do Nothing -> LBS.toStrict $ B.encode (hash (snd val)) return (Just cutoffHash, val) - defineNoDiagnostics $ \(GhcSessionDeps_ fullModSummary) file -> do + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \(GhcSessionDeps_ fullModSummary) file -> do env <- use_ GhcSession file ghcSessionDepsDefinition fullModSummary ghcSessionDepsConfig env file @@ -738,8 +768,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 (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 @@ -762,10 +792,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 (WithPriority Log) -> Rules () +getModIfaceFromDiskAndIndexRule recorder = -- doesn't need early cutoff since all its dependencies already have it - defineNoDiagnostics $ \GetModIfaceFromDiskAndIndex f -> do + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetModIfaceFromDiskAndIndex f -> do x <- use_ GetModIfaceFromDisk f se@ShakeExtras{withHieDb} <- getShakeExtras @@ -787,19 +817,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 Logger.Debug $ LogReindexingHieFile f indexHieFile se ms f hash hf return (Just x) -isHiFileStableRule :: Rules () -isHiFileStableRule = defineEarlyCutoff $ 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 @@ -837,14 +867,14 @@ displayTHWarning newtype DisplayTHWarning = DisplayTHWarning (IO ()) instance IsIdeGlobal DisplayTHWarning -getModSummaryRule :: Rules () -getModSummaryRule = do +getModSummaryRule :: Recorder (WithPriority Log) -> Rules () +getModSummaryRule recorder = do menv <- lspEnv <$> getShakeExtrasRules forM_ menv $ \env -> do displayItOnce <- liftIO $ once $ LSP.runLspT env displayTHWarning addIdeGlobal (DisplayTHWarning displayItOnce) - defineEarlyCutoff $ 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' @@ -865,7 +895,7 @@ getModSummaryRule = do return ( Just (fingerprintToBS fingerPrint) , ([], Just res)) Left diags -> return (Nothing, (diags, Nothing)) - defineEarlyCutoff $ RuleNoDiagnostics $ \GetModSummaryWithoutTimestamps f -> do + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetModSummaryWithoutTimestamps f -> do ms <- use GetModSummary f case ms of Just res@ModSummaryResult{..} -> do @@ -884,12 +914,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 (WithPriority Log) -> Rules () +generateCoreRule recorder = + define (cmapWithPrio LogShake recorder) $ \GenerateCore -> generateCore (RunSimplifier True) -getModIfaceRule :: Rules () -getModIfaceRule = defineEarlyCutoff $ 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 @@ -992,8 +1022,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 (WithPriority Log) -> Rules () +getClientSettingsRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetClientSettings -> do alwaysRerun settings <- clientSettings <$> getIdeConfiguration return (LBS.toStrict $ B.encode $ hash settings, settings) @@ -1103,28 +1133,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 (WithPriority 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: -- * -> @@ -1132,13 +1162,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 (cmapWithPrio LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation file -> needsCompilationRule file - else defineNoDiagnostics $ \NeedsCompilation _ -> return $ Just Nothing - generateCoreRule - getImportMapRule - getAnnotatedParsedSourceRule - persistentHieFileRule + else defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \NeedsCompilation _ -> return $ Just Nothing + generateCoreRule recorder + getImportMapRule 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 e5eae280e2..d190a0d6cf 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -15,30 +15,52 @@ module Development.IDE.Core.Service( getDiagnostics, ideLogger, updatePositionMapping, + Log(..), ) where 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, LogShake) import Development.IDE.Graph -import Development.IDE.Types.Logger as Logger +import Development.IDE.Types.Logger as Logger (Logger, + Pretty (pretty), + Priority (Debug), + Recorder, + WithPriority, + cmapWithPrio) import Development.IDE.Types.Options (IdeOptions (..)) import Ide.Plugin.Config import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP import Control.Monad -import Development.IDE.Core.Shake +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) import System.Environment (lookupEnv) +data Log + = LogShake Shake.Log + | LogOfInterest OfInterest.Log + | LogFileExists FileExists.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + LogOfInterest log -> pretty log + LogFileExists log -> pretty log + ------------------------------------------------------------ -- Exposed API -- | Initialise the Compiler Service. -initialise :: Config +initialise :: Recorder (WithPriority Log) + -> Config -> Rules () -> Maybe (LSP.LanguageContextEnv Config) -> Logger @@ -48,12 +70,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 + (cmapWithPrio LogShake recorder) lspEnv defaultConfig logger @@ -67,8 +90,8 @@ initialise defaultConfig mainRule lspEnv logger debouncer options vfs withHieDb (optShakeOptions options) $ do addIdeGlobal $ GlobalIdeOptions options - ofInterestRules - fileExistsRules 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 da727cadd2..fec940731a 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 @@ -158,7 +159,6 @@ 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 qualified Development.IDE.Types.Exports as ExportsMap import qualified Focus @@ -169,6 +169,47 @@ import Ide.Types (PluginId) import qualified "list-t" ListT import qualified StmContainers.Map as STM +data Log + = LogCreateHieDbExportsMapStart + | LogCreateHieDbExportsMapFinish !Int + | LogBuildSessionRestart !String ![DelayedActionInternal] !(HashSet Key) !Seconds !(Maybe FilePath) + | LogDelayedAction !(DelayedAction ()) !Seconds + | LogBuildSessionFinish !(Maybe SomeException) + | LogDiagsDiffButNoLspEnv ![FileDiagnostic] + | LogDefineEarlyCutoffRuleNoDiagHasDiag !FileDiagnostic + | LogDefineEarlyCutoffRuleCustomNewnessHasDiag !FileDiagnostic + deriving Show + +instance Pretty Log where + pretty = \case + LogCreateHieDbExportsMapStart -> + "Initializing exports map from hiedb" + LogCreateHieDbExportsMapFinish exportsMapSize -> + "Done initializing exports map from hiedb. Size:" <+> pretty exportsMapSize + LogBuildSessionRestart reason actionQueue keyBackLog abortDuration shakeProfilePath -> + 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 -> + hsep + [ "Finished:" <+> pretty (actionName delayedAction) + , "Took:" <+> pretty (showDuration duration) ] + LogBuildSessionFinish e -> + vcat + [ "Finished build session" + , pretty (fmap displayException e) ] + LogDiagsDiffButNoLspEnv fileDiagnostics -> + "updateFileDiagnostics published different from new diagnostics - file diagnostics:" + <+> pretty (showDiagnosticsColored fileDiagnostics) + LogDefineEarlyCutoffRuleNoDiagHasDiag fileDiagnostic -> + "defineEarlyCutoff RuleNoDiagnostics - file diagnostic:" + <+> pretty (showDiagnosticsColored [fileDiagnostic]) + LogDefineEarlyCutoffRuleCustomNewnessHasDiag fileDiagnostic -> + "defineEarlyCutoff RuleWithCustomNewnessCheck - file diagnostic:" + <+> pretty (showDiagnosticsColored [fileDiagnostic]) + -- | 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 +535,8 @@ seqValue val = case val of Failed _ -> val -- | Open a 'IdeState', should be shut using 'shakeShut'. -shakeOpen :: Maybe (LSP.LanguageContextEnv Config) +shakeOpen :: Recorder (WithPriority Log) + -> Maybe (LSP.LanguageContextEnv Config) -> Config -> Logger -> Debouncer NormalizedUri @@ -507,8 +549,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 :: Logger.Priority -> Log -> IO () + log = logWith recorder us <- mkSplitUniqSupply 'r' ideNc <- newIORef (initNameCache us knownKeyNames) @@ -520,7 +564,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 +572,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 Debug LogCreateHieDbExportsMapStart em <- createExportsMapHieDb withHieDb atomically $ modifyTVar' exportsMap (<> em) - logDebug logger $ "Done initializing exports map from hiedb (" <> pack(show (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) @@ -584,9 +629,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 (WithPriority Log) -> IdeState -> IO () +shakeSessionInit recorder ide@IdeState{..} = do + initSession <- newSession recorder shakeExtras shakeDb [] "shakeSessionInit" putMVar shakeSession initSession logDebug (ideLogger ide) "Shake session initialized" @@ -626,31 +671,35 @@ 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 (WithPriority 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 Debug $ LogBuildSessionRestart reason queue backlog stopTime res + 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) 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 +733,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 (WithPriority 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 <- @@ -709,10 +759,7 @@ newSession 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 $ do - logPriority logger (actionPriority d) msg + 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 ()) @@ -728,7 +775,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 Debug $ LogBuildSessionFinish exception notifyTestingLogMessage extras msg -- Do the work in a background thread @@ -736,6 +787,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 @@ -843,13 +895,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 (WithPriority 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 (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 use :: IdeRule k v @@ -971,37 +1023,36 @@ data RuleBody k v -- | Define a new Rule with early cutoff defineEarlyCutoff :: IdeRule k v - => RuleBody k v + => Recorder (WithPriority 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 + mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleNoDiagHasDiag) 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 traceDiagnostics diags + mapM_ (logWith recorder Warning . LogDefineEarlyCutoffRuleCustomNewnessHasDiag) 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 (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 => (k -> Action (BS.ByteString, v)) -> Rules () -defineEarlyCutOffNoFile f = defineEarlyCutoff $ RuleNoDiagnostics $ \k file -> do +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" @@ -1107,9 +1158,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 (WithPriority 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 @@ -1121,7 +1173,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 "") @@ -1132,7 +1184,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 @@ -1149,12 +1201,13 @@ needOnDisks k files = do liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k) updateFileDiagnostics :: MonadIO m - => NormalizedFilePath + => Recorder (WithPriority 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 @@ -1174,7 +1227,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 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 1c258ddd78..a2257250b4 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -43,6 +43,7 @@ module Development.IDE.GHC.ExactPrint ASTElement (..), ExceptStringT (..), TransformT, + Log(..), ) where @@ -66,13 +67,18 @@ 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 (Pretty (pretty), + Recorder, + WithPriority, + cmapWithPrio) import qualified GHC.Generics as GHC import Generics.SYB import Generics.SYB.GHC @@ -100,6 +106,12 @@ import GHC.Parser.Annotation (AnnContext (..), ------------------------------------------------------------------------------ +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) @@ -108,8 +120,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 (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 f3e4f4d9e8..9f16788c3b 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 @@ -31,17 +32,46 @@ 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 +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 qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Shake (WithHieDb) import System.IO.Unsafe (unsafeInterleaveIO) +data Log + = LogRegisteringIdeConfig !IdeConfiguration + | LogReactorThreadException !SomeException + | LogReactorMessageActionException !SomeException + | LogReactorThreadStopped + | LogCancelledRequest !SomeLspId + | LogSession Session.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogRegisteringIdeConfig ideConfig -> + "Registering IDE configuration:" <+> viaShow ideConfig + LogReactorThreadException e -> + vcat + [ "ReactorThreadException" + , pretty $ displayException e ] + LogReactorMessageActionException e -> + vcat + [ "ReactorMessageActionException" + , pretty $ displayException e ] + LogReactorThreadStopped -> + "Reactor thread stopped" + LogCancelledRequest requestId -> + "Cancelled request" <+> viaShow requestId + LogSession log -> pretty log + issueTrackerUrl :: T.Text issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues" @@ -50,7 +80,8 @@ newtype WithHieDbShield = WithHieDbShield WithHieDb runLanguageServer :: forall config. (Show config) - => LSP.Options + => Recorder (WithPriority Log) + -> LSP.Options -> Handle -- input -> Handle -- output -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project @@ -59,7 +90,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 +159,9 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan serverDefinition where + log :: Logger.Priority -> 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 +179,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 Info $ LogRegisteringIdeConfig initConfig registerIdeConfiguration (shakeExtras ide) initConfig let handleServerException (Left e) = do - logError logger $ - T.pack $ "Fatal error in server thread: " <> show e + log Error $ LogReactorThreadException e sendErrorMessage e exitClientMsg handleServerException (Right _) = pure () @@ -163,13 +197,9 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan ] exceptionInHandler e = do - logError logger $ T.pack $ - "Unexpected exception, please report!\n" ++ - "Exception: " ++ show e + log Error $ LogReactorMessageActionException e sendErrorMessage e - logger = ideLogger ide - checkCancelled _id act k = flip finally (clearReqId _id) $ catch (do @@ -180,14 +210,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 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 logger dbLoc $ \withHieDb hieChan -> do + untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb hieChan -> do putMVar dbMVar (WithHieDbShield withHieDb,hieChan) forever $ do msg <- readChan clientMsgChan @@ -196,7 +226,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 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 49dab15015..6b25942ba2 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 @@ -26,21 +27,33 @@ 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.OfInterest hiding (Log, LogShake) import Development.IDE.Core.RuleTypes (GetClientSettings (..)) -import Development.IDE.Core.Service -import Development.IDE.Core.Shake +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 import Development.IDE.Types.Shake (toKey) import Ide.Types +data Log + = LogShake Shake.Log + | LogFileStore FileStore.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + LogFileStore log -> pretty log + 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 (WithPriority 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 []) @@ -48,7 +61,7 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = -- 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 (cmapWithPrio LogFileStore recorder) ide False file logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri , mkPluginNotificationHandler LSP.STextDocumentDidChange $ @@ -56,14 +69,14 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = atomically $ updatePositionMapping ide identifier changes whenUriFile _uri $ \file -> do addFileOfInterest ide file Modified{firstOpen=False} - setFileModified 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 ide True file + setFileModified (cmapWithPrio LogFileStore recorder) ide True file logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri , mkPluginNotificationHandler LSP.STextDocumentDidClose $ @@ -112,7 +125,7 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ -> do --------- Initialize Shake session -------------------------------------------------------------------- - liftIO $ shakeSessionInit 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 1554ec185b..936a7f80e3 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 -import Control.Concurrent.Extra (newLock, withLock, - withNumCapabilities) +,testing +,Log(..) +) where +import Control.Concurrent.Extra (withNumCapabilities) import Control.Concurrent.STM.Stats (atomically, dumpSTMStats) -import Control.Exception.Safe (Exception (displayException), - catchAny) +import Control.Exception.Safe (SomeException, catchAny, + displayException) import Control.Monad.Extra (concatMapM, unless, when) import qualified Data.Aeson.Encode.Pretty as A @@ -26,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) @@ -50,17 +50,23 @@ 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), 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 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)) import Development.IDE.Plugin.HLS (asGhcIdePlugin) -import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide +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, getHieDbLoc, @@ -68,11 +74,14 @@ 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), - logDebug, logInfo) +import Development.IDE.Types.Logger (Logger, Pretty (pretty), + Priority (Info, Warning), + Recorder, WithPriority, + cmapWithPrio, logWith, + vsep, (<+>)) import Development.IDE.Types.Options (IdeGhcSession, IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), IdeTesting (IdeTesting), @@ -118,10 +127,49 @@ 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) +data Log + = LogHeapStats !HeapStats.Log + | LogLspStart + | LogLspStartDuration !Seconds + | LogShouldRunSubset !Bool + | LogOnlyPartialGhc9Support + | LogSetInitialDynFlagsException !SomeException + | 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 = \case + LogHeapStats log -> pretty log + LogLspStart -> + 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 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 + data Command = Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures | Db {hieOptions :: HieDb.Options, hieCommand :: HieDb.Command} @@ -132,7 +180,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 @@ -187,18 +234,16 @@ data Arguments = Arguments , argsThreads :: Maybe Natural } -instance Default Arguments where - def = defaultArguments Info -defaultArguments :: Priority -> Arguments -defaultArguments priority = Arguments +defaultArguments :: Recorder (WithPriority Log) -> Logger -> Arguments +defaultArguments recorder logger = Arguments { argsProjectRoot = Nothing , argsOTMemoryProfiling = False , argCommand = LSP - , argsLogger = stderrLogger priority - , argsRules = mainRule def >> action kick + , argsLogger = pure logger + , argsRules = mainRule (cmapWithPrio LogRules recorder) def >> action kick , argsGhcidePlugin = mempty - , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors + , argsHlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde recorder)) , argsSessionLoadingOptions = def , argsIdeOptions = \config ghcSession -> (defaultIdeOptions ghcSession) { optCheckProject = pure $ checkProject config @@ -226,35 +271,39 @@ 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 - } -} - --- | 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 -defaultMain :: Arguments -> IO () -defaultMain Arguments{..} = flip withHeapStats fun =<< argsLogger +testing :: Recorder (WithPriority Log) -> Logger -> Arguments +testing recorder logger = + let + arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = defaultArguments recorder logger + 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 + } + + +defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO () +defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun where + log :: Priority -> Log -> IO () + log = logWith recorder + fun = do setLocaleEncoding utf8 pid <- T.pack . show <$> getProcessID logger <- argsLogger hSetBuffering stderr LineBuffering - let hlsPlugin = asGhcIdePlugin argsHlsPlugins + let hlsPlugin = asGhcIdePlugin (cmapWithPrio LogPluginHLS recorder) argsHlsPlugins hlsCommands = allLspCmdIds' pid argsHlsPlugins plugins = hlsPlugin <> argsGhcidePlugin options = argsLspOptions { LSP.executeCommandCommands = LSP.executeCommandCommands argsLspOptions <> Just hlsCommands } @@ -274,29 +323,29 @@ 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!" - runLanguageServer options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath withHieDb hieChan -> do + log Info LogLspStart + + runLanguageServer (cmapWithPrio LogLanguageServer recorder) 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 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 logger dir argsSessionLoadingOptions - `catchAny` (\e -> (logDebug logger $ T.pack $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing) - + setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions + -- TODO: should probably catch/log/rethrow at top level instead + `catchAny` (\e -> log Debug (LogSetInitialDynFlagsException e) >> pure Nothing) - sessionLoader <- loadSessionWithOptions 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 - logDebug logger $ T.pack $ "runSubset: " <> show runSubset + log Debug $ LogShouldRunSubset runSubset let options = def_options { optReportProgress = clientSupportsProgress caps @@ -306,10 +355,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 Warning LogOnlyPartialGhc9Support initialise + (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules (Just env) @@ -323,7 +371,7 @@ defaultMain Arguments{..} = flip withHeapStats fun =<< argsLogger Check argFiles -> do dir <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc dir - runWithDb logger 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 @@ -345,15 +393,15 @@ defaultMain Arguments{..} = flip withHeapStats fun =<< argsLogger when (n > 0) $ putStrLn $ " (" ++ intercalate ", " (catMaybes ucradles) ++ ")" putStrLn "\nStep 3/4: Initializing the IDE" vfs <- makeVFSHandle - sessionLoader <- loadSessionWithOptions 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 argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan - shakeSessionInit 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" @@ -388,26 +436,26 @@ defaultMain Arguments{..} = flip withHeapStats fun =<< argsLogger root <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc root hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc - mlibdir <- setInitialDynFlags logger root def + mlibdir <- setInitialDynFlags (cmapWithPrio 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 (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 logger dbLoc $ \hiedb hieChan -> do + runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do vfs <- makeVFSHandle - sessionLoader <- loadSessionWithOptions 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 argsDefaultHlsConfig rules Nothing logger debouncer options vfs hiedb hieChan - shakeSessionInit 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 de17eef1df..c998630f6a 100644 --- a/ghcide/src/Development/IDE/Main/HeapStats.hs +++ b/ghcide/src/Development/IDE/Main/HeapStats.hs @@ -1,22 +1,48 @@ {-# LANGUAGE NumericUnderscores #-} -- | Logging utilities for reporting heap statistics -module Development.IDE.Main.HeapStats ( withHeapStats ) where +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, logInfo) +import Development.IDE.Types.Logger (Pretty (pretty), Priority (Info), + Recorder, WithPriority, hsep, + logWith, (<+>)) import GHC.Stats import Text.Printf (printf) +data Log + = LogHeapStatsPeriod !Int + | LogHeapStatsDisabled + | LogHeapStats !Word64 !Word64 + 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 -> + 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 -- | Report the live bytes and heap size at the last major collection. -logHeapStats :: Logger -> IO () +logHeapStats :: Recorder (WithPriority Log) -> IO () logHeapStats l = do stats <- getRTSStats -- live_bytes is the total amount of live memory in a program @@ -25,14 +51,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 Info $ LogHeapStats live_bytes heap_size -- | An action which logs heap statistics at the 'heapStatsInterval' -heapStatsThread :: Logger -> IO r +heapStatsThread :: Recorder (WithPriority Log) -> IO r heapStatsThread l = forever $ do threadDelay heapStatsInterval logHeapStats l @@ -40,14 +62,14 @@ 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 (WithPriority 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 Info $ LogHeapStatsPeriod heapStatsInterval withAsync (heapStatsThread l) (const k) else do - logInfo l "Heap statistics are not enabled (RTS option -T is needed)" + logWith l Info LogHeapStatsDisabled k + diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 8e0292cdc6..edc656ada0 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -4,6 +4,7 @@ module Development.IDE.Plugin.Completions ( descriptor + , Log(..) ) where import Control.Concurrent.Async (concurrently) @@ -19,8 +20,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 -import Development.IDE.Core.Shake +import Development.IDE.Core.Service hiding (Log, + 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) import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource (GetAnnotatedParsedSource)) @@ -36,6 +39,10 @@ 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 (Pretty (pretty), + Recorder, + WithPriority, + cmapWithPrio) import GHC.Exts (fromList, toList) import Ide.Plugin.Config (Config) import Ide.Types @@ -44,17 +51,23 @@ 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 + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + +descriptor :: Recorder (WithPriority 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 (WithPriority Log) -> Rules () +produceCompletions recorder = do + define (cmapWithPrio LogShake recorder) $ \LocalCompletions file -> do let uri = fromNormalizedUri $ normalizedFilePathToUri file pm <- useWithStale GetParsedModule file case pm of @@ -62,7 +75,7 @@ produceCompletions = do let cdata = localCompletionsForParsedModule uri pm return ([], Just cdata) _ -> return ([], Nothing) - define $ \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 842b69b530..a7c64a024f 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -6,11 +6,11 @@ module Development.IDE.Plugin.HLS ( asGhcIdePlugin + , Log(..) ) where 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) @@ -22,7 +22,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 +43,22 @@ import UnliftIO.Exception (catchAny) -- --------------------------------------------------------------------- -- +data Log + = LogNoEnabledPlugins + deriving Show + +instance Pretty Log where + pretty = \case + LogNoEnabledPlugins -> + "extensibleNotificationPlugins no enabled plugins" + -- | Map a set of plugins to the underlying ghcide engine. -asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config -asGhcIdePlugin (IdePlugins ls) = +asGhcIdePlugin :: Recorder (WithPriority 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 +180,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 (WithPriority 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 +195,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 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 c854330d9c..c1393b1f4b 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,16 +20,28 @@ import Language.LSP.Server (LspM) import Language.LSP.Types import Text.Regex.TDFA.Text () -descriptors :: [PluginDescriptor IdeState] -descriptors = +data Log + = LogNotifications Notifications.Log + | LogCompletions Completions.Log + | LogTypeLenses TypeLenses.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogNotifications log -> pretty log + LogCompletions log -> pretty log + LogTypeLenses log -> pretty log + +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 "ghcide-completions", - TypeLenses.descriptor "ghcide-type-lenses", - Notifications.descriptor "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 4f7084badb..ecfdd35449 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -10,7 +10,8 @@ module Development.IDE.Plugin.TypeLenses ( GlobalBindingTypeSig (..), GetGlobalBindingTypeSigs (..), GlobalBindingTypeSigsResult (..), -) where + Log(..) + ) where import Control.Concurrent.STM.Stats (atomically) import Control.DeepSeq (rwhnf) @@ -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,9 @@ import Development.IDE.Types.Location (Position (Position, _chara Range (Range, _end, _start), toNormalizedFilePath', uriToFilePath') +import Development.IDE.Types.Logger (Pretty (pretty), Recorder, + WithPriority, + cmapWithPrio) import GHC.Generics (Generic) import Ide.Plugin.Config (Config) import Ide.Plugin.Properties @@ -68,15 +73,21 @@ import Language.LSP.Types (ApplyWorkspaceEditParams ( WorkspaceEdit (WorkspaceEdit)) import Text.Regex.TDFA ((=~), (=~~)) +data Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + typeLensCommandId :: T.Text typeLensCommandId = "typesignature.add" -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = +descriptor :: Recorder (WithPriority 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} } @@ -239,9 +250,9 @@ instance NFData GlobalBindingTypeSigsResult where type instance RuleResult GetGlobalBindingTypeSigs = GlobalBindingTypeSigsResult -rules :: Rules () -rules = do - define $ \GetGlobalBindingTypeSigs nfp -> do +rules :: Recorder (WithPriority Log) -> Rules () +rules recorder = 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 c40ef36e54..9f696210e2 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -8,12 +8,50 @@ module Development.IDE.Types.Logger ( Priority(..) , Logger(..) + , Recorder(..) , logError, logWarning, logInfo, logDebug, logTelemetry , noLogging + , WithPriority(..) + , logWith + , cmap + , cmapIO + , cfilter + , withDefaultRecorder + , makeDefaultStderrRecorder + , priorityToHsLoggerPriority + , LoggingColumn(..) + , cmapWithPrio + , module PrettyPrinterModule ) where -import qualified Data.Text as T - +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 (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), + 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 @@ -27,7 +65,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). @@ -57,3 +94,208 @@ logTelemetry x = logPriority x Telemetry 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. +-- 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. (MonadIO m) => msg -> m () } + +logWith :: (HasCallStack, MonadIO m) => Recorder (WithPriority msg) -> Priority -> msg -> m () +logWith recorder priority msg = withFrozenCallStack $ logger_ recorder (WithPriority priority callStack 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 + +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 + { 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 } + +-- | 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 minPriority lock stderr + +-- | If no path given then use stderr, otherwise use file. +-- Kinda complicated because we also need to setup `hslogger` for +-- `hie-bios` log compatibility reasons. If `hie-bios` can be set to use our +-- logger instead or if `hie-bios` doesn't use `hslogger` then `hslogger` can +-- be removed completely. See `setupHsLogger` comment. +withDefaultRecorder + :: MonadUnliftIO m + => Maybe FilePath + -- ^ Log file path. `Nothing` uses stderr + -> Maybe [LoggingColumn] + -- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns` + -> Priority + -- ^ min priority for hslogger compatibility + -> (Recorder (WithPriority (Doc d)) -> m a) + -- ^ action given a recorder + -> m a +withDefaultRecorder path columns minPriority action = do + lock <- liftIO newLock + let makeHandleRecorder = makeDefaultHandleRecorder columns minPriority lock + case path of + Nothing -> do + recorder <- makeHandleRecorder stderr + let message = "No log file specified; using stderr." + logWith recorder Info message + action recorder + Just path -> 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 Warning message + action recorder + Right fileHandle -> finally (makeHandleRecorder fileHandle >>= action) (liftIO $ hClose fileHandle) + +makeDefaultHandleRecorder + :: MonadIO m + => Maybe [LoggingColumn] + -- ^ built-in logging columns to display. Nothing uses the default + -> Priority + -- ^ min priority for hslogger compatibility + -> Lock + -- ^ lock to take when outputting to handle + -> Handle + -- ^ handle to output to + -> m (Recorder (WithPriority (Doc a))) +makeDefaultHandleRecorder columns minPriority lock handle = do + let Recorder{ logger_ } = textHandleRecorder handle + let threadSafeRecorder = Recorder { logger_ = \msg -> liftIO $ withLock lock (logger_ msg) } + let loggingColumns = fromMaybe defaultLoggingColumns columns + let textWithPriorityRecorder = cmapIO (textWithPriorityToText loggingColumns) threadSafeRecorder + -- see `setupHsLogger` comment + liftIO $ setupHsLogger lock handle ["hls", "hie-bios"] (priorityToHsLoggerPriority minPriority) + pure (cmap docToText textWithPriorityRecorder) + where + docToText = fmap (renderStrict . layoutPretty defaultLayoutOptions) + +priorityToHsLoggerPriority :: Priority -> HsLogger.Priority +priorityToHsLoggerPriority = \case + Telemetry -> HsLogger.INFO + Debug -> HsLogger.DEBUG + Info -> HsLogger.INFO + Warning -> HsLogger.WARNING + Error -> HsLogger.ERROR + +-- | The purpose of setting up `hslogger` at all is that `hie-bios` uses +-- `hslogger` to output compilation logs. The easiest way to merge these logs +-- with our log output is to setup an `hslogger` that uses the same handle +-- and same lock as our loggers. That way the output from our loggers and +-- `hie-bios` don't interleave strangely. +-- It may be possible to have `hie-bios` use our logger by decorating the +-- `Cradle.cradleOptsProg.runCradle` we get in the Cradle from +-- `HieBios.findCradle`, but I remember trying that and something not good +-- happened. I'd have to try it again to remember if that was a real issue. +-- Once that is figured out or `hie-bios` doesn't use `hslogger`, then all +-- references to `hslogger` can be removed entirely. +setupHsLogger :: Lock -> Handle -> [String] -> HsLogger.Priority -> IO () +setupHsLogger lock handle extraLogNames level = do + hSetEncoding handle utf8 + + logH <- HSL.streamHandler handle level + + let logHandle = logH + { HSL.writeFunc = \a s -> withLock lock $ HSL.writeFunc logH a s } + logFormatter = HSL.tfLogFormatter logDateFormat logFormat + logHandler = HSL.setFormatter logHandle logFormatter + + HsLogger.updateGlobalLogger HsLogger.rootLoggerName $ HsLogger.setHandlers ([] :: [HSL.GenericHandler Handle]) + HsLogger.updateGlobalLogger "haskell-lsp" $ HsLogger.setHandlers [logHandler] + HsLogger.updateGlobalLogger "haskell-lsp" $ HsLogger.setLevel level + + -- Also route the additional log names to the same log + forM_ extraLogNames $ \logName -> do + HsLogger.updateGlobalLogger logName $ HsLogger.setHandlers [logHandler] + HsLogger.updateGlobalLogger logName $ HsLogger.setLevel level + where + logFormat = "$time [$tid] $prio $loggername:\t$msg" + logDateFormat = "%Y-%m-%d %H:%M:%S%Q" + +data LoggingColumn + = TimeColumn + | ThreadIdColumn + | PriorityColumn + | DataColumn + | SourceLocColumn + +defaultLoggingColumns :: [LoggingColumn] +defaultLoggingColumns = [TimeColumn, PriorityColumn, DataColumn] + +textWithPriorityToText :: [LoggingColumn] -> WithPriority Text -> IO Text +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 = showAsText + + threadIdToText = showAsText + + callStackToSrcLoc :: CallStack -> Maybe SrcLoc + callStackToSrcLoc callStack = + case getCallStack callStack of + (_, srcLoc) : _ -> Just srcLoc + _ -> Nothing + + 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) + PriorityColumn -> pure (priorityToText priority) + DataColumn -> pure payload + + + + diff --git a/ghcide/test/exe/HieDbRetry.hs b/ghcide/test/exe/HieDbRetry.hs index f3a29cea39..c51c8bbebc 100644 --- a/ghcide/test/exe/HieDbRetry.hs +++ b/ghcide/test/exe/HieDbRetry.hs @@ -5,25 +5,34 @@ 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_), + WithPriority (WithPriority, payload), + cmapWithPrio) 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 (WithPriority Log) +makeLogger msgsVar = + Recorder { + logger_ = \WithPriority{ payload = 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 (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 @@ -60,7 +69,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 +78,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 +95,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 +110,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 (cmapWithPrio 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 6f4481f9e5..286c5e98d0 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -107,7 +107,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 @@ -121,8 +120,21 @@ import Test.Tasty.Ingredients.Rerun 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)) +import Data.Function ((&)) +import GHC.Stack (emptyCallStack) import qualified FuzzySearch +data Log + = LogGhcIde Ghcide.Log + | LogIDEMain IDE.Log + +instance Pretty Log where + pretty = \case + LogGhcIde log -> pretty log + LogIDEMain log -> pretty log + -- | Wait for the next progress begin step waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case @@ -151,6 +163,18 @@ waitForAllProgressDone = loop main :: IO () main = do + docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Debug + + let docWithFilteredPriorityRecorder@Recorder{ logger_ } = + 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 + -- We mess with env vars so run single-threaded. defaultMainWithRerun $ testGroup "ghcide" [ testSession "open close" $ do @@ -174,7 +198,7 @@ main = do , thTests , symlinkTests , safeTests - , unitTests + , unitTests recorder logger , haddockTests , positionMappingTests , watchedFilesTests @@ -6174,8 +6198,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 (WithPriority 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 "." @@ -6215,9 +6239,9 @@ unitTests = do ] } | i <- [(1::Int)..20] - ] ++ Ghcide.descriptors + ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder) - testIde IDE.testing{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 @@ -6316,16 +6340,14 @@ 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 a -> IO a -testIde = testIde' "." - -testIde' :: FilePath -> IDE.Arguments -> Session a -> IO a -testIde' projDir arguments session = do +testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () +testIde recorder arguments session = do config <- getConfigFromEnv cwd <- getCurrentDirectory (hInRead, hInWrite) <- createPipe (hOutRead, hOutWrite) <- createPipe - let server = IDE.defaultMain arguments + let projDir = "." + let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments { IDE.argsHandleIn = pure hInRead , IDE.argsHandleOut = pure hOutWrite } diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 92b5305f45..2df0e33d37 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/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 0fb06387d4..b4faf554ec 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -396,6 +396,7 @@ type CommandFunction ideState a newtype PluginId = PluginId T.Text deriving (Show, Read, Eq, Ord) + instance IsString PluginId where fromString = PluginId . T.pack diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index b6d25909a8..02ece9efb4 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} module Test.Hls ( module Test.Tasty.HUnit, module Test.Tasty, @@ -51,14 +51,24 @@ 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 +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), WaitForIdeRuleResult (ideResultSuccess)) +import qualified Development.IDE.Plugin.Test as Test +import Development.IDE.Types.Logger (Logger (Logger), + Pretty (pretty), + Priority (Debug), + Recorder (Recorder, logger_), + WithPriority (WithPriority, priority), + cfilter, cmapWithPrio, + 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) @@ -69,6 +79,7 @@ import Language.LSP.Types hiding SemanticTokenRelative (length), SemanticTokensEdit (_start)) import Language.LSP.Types.Capabilities (ClientCapabilities) +import Prelude hiding (log) import System.Directory (getCurrentDirectory, setCurrentDirectory) import System.Environment (lookupEnv) @@ -83,6 +94,12 @@ import Test.Tasty.Golden import Test.Tasty.HUnit import Test.Tasty.Ingredients.Rerun +newtype Log = LogIDEMain IDEMain.Log + +instance Pretty Log where + pretty = \case + LogIDEMain log -> pretty log + -- | Run 'defaultMainWithRerun', limiting each single test case running at most 10 minutes defaultTestRunner :: TestTree -> IO () defaultTestRunner = defaultMainWithRerun . adjustOption (const $ mkTimeout 600000000) @@ -152,6 +169,7 @@ keepCurrentDirectory = bracket getCurrentDirectory setCurrentDirectory . const lock :: Lock lock = unsafePerformIO newLock + -- | Host a server, and run a test session on it -- Note: cwd will be shifted into @root@ in @Session a@ runSessionWithServer' :: @@ -165,31 +183,50 @@ 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 + + docWithPriorityRecorder <- makeDefaultStderrRecorder Nothing Debug + + logStdErr <- fromMaybe "0" <$> lookupEnv "LSP_TEST_LOG_STDERR" + + let + docWithFilteredPriorityRecorder@Recorder{ logger_ } = + if logStdErr == "0" then mempty + else cfilter (\WithPriority{ priority } -> priority >= Debug) docWithPriorityRecorder + + -- exists until old logging style is phased out + logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) + + recorder = cmapWithPrio pretty docWithFilteredPriorityRecorder + + arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLogger } = defaultArguments (cmapWithPrio LogIDEMain recorder) logger + + 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 } + } 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) - } + (cmapWithPrio LogIDEMain recorder) + arguments + { argsHandleIn = pure inR + , argsHandleOut = pure outW + , argsDefaultHlsConfig = conf + , argsLogger = argsLogger + , argsIdeOptions = ideOptions + , argsHlsPlugins = pluginDescToIdePlugins hlsPlugins } + x <- runSessionWithHandles inW outR sconf caps root s hClose inW timeout 3 (wait server) >>= \case diff --git a/plugins/default/src/Ide/Plugin/Example.hs b/plugins/default/src/Ide/Plugin/Example.hs index 9511b00b06..0416cbe8d1 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 #-} @@ -12,6 +13,7 @@ module Ide.Plugin.Example ( descriptor + , Log(..) ) where import Control.Concurrent.STM @@ -27,6 +29,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 import GHC.Generics import Ide.PluginUtils @@ -38,9 +41,15 @@ import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) - { pluginRules = exampleRules +newtype Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + +descriptor :: Recorder (WithPriority 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 +83,9 @@ instance NFData Example type instance RuleResult Example = () -exampleRules :: Rules () -exampleRules = do - define $ \Example file -> do +exampleRules :: Recorder (WithPriority Log) -> Rules () +exampleRules recorder = 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 4b95e4242b..6595ce58a6 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 #-} @@ -12,6 +13,7 @@ module Ide.Plugin.Example2 ( descriptor + , Log(..) ) where import Control.Concurrent.STM @@ -25,7 +27,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 +38,15 @@ import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) - { pluginRules = exampleRules +newtype Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + +descriptor :: Recorder (WithPriority 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 +75,9 @@ instance NFData Example2 type instance RuleResult Example2 = () -exampleRules :: Rules () -exampleRules = do - define $ \Example2 file -> do +exampleRules :: Recorder (WithPriority Log) -> Rules () +exampleRules recorder = 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 53056164e2..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 @@ -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,16 @@ import Ide.Types import Language.LSP.Types import Language.LSP.Types.Lens (uri) -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) +newtype Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionHandler - , pluginRules = collectLiteralsRule + , pluginRules = collectLiteralsRule recorder } data CollectLiterals = CollectLiterals @@ -53,8 +60,8 @@ instance Show CollectLiteralsResult where instance NFData CollectLiteralsResult -collectLiteralsRule :: Rules () -collectLiteralsRule = define $ \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-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/src/Ide/Plugin/Eval.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs index c223f522f1..c00022fd13 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs @@ -1,32 +1,43 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE LambdaCase #-} {- | Eval Plugin entry point. -} module Ide.Plugin.Eval ( descriptor, -) where + Log(..) + ) where -import Development.IDE (IdeState) -import qualified Ide.Plugin.Eval.CodeLens as CL +import Development.IDE (IdeState) +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) -import Ide.Types (ConfigDescriptor (..), - PluginDescriptor (..), PluginId, - defaultConfigDescriptor, - defaultPluginDescriptor, - mkCustomConfig, mkPluginHandler) +import Ide.Plugin.Eval.Rules (rules) +import qualified Ide.Plugin.Eval.Rules as EvalRules +import Ide.Types (ConfigDescriptor (..), + PluginDescriptor (..), PluginId, + defaultConfigDescriptor, + defaultPluginDescriptor, + mkCustomConfig, mkPluginHandler) import Language.LSP.Types +newtype Log = LogEvalRules EvalRules.Log deriving Show + +instance Pretty Log where + pretty = \case + LogEvalRules log -> pretty log + -- |Plugin descriptor -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeLens CL.codeLens , pluginCommands = [CL.evalCommand plId] - , pluginRules = rules + , 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 b23adc7b21..1a9c94c98b 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -2,9 +2,10 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} + -- To avoid warning "Pattern match has inaccessible right hand side" {-# OPTIONS_GHC -Wno-overlapping-patterns #-} -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) @@ -32,20 +33,29 @@ 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 (Pretty (pretty), + Recorder, WithPriority, + cmapWithPrio) #if MIN_VERSION_ghc(9,2,0) import GHC.Parser.Annotation #endif import Ide.Plugin.Eval.Types +newtype Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog -rules :: Rules () -rules = do - evalParsedModuleRule - redefinedNeedsCompilation +rules :: Recorder (WithPriority Log) -> Rules () +rules recorder = do + evalParsedModuleRule recorder + redefinedNeedsCompilation recorder addIdeGlobal . EvaluatingVar =<< liftIO(newIORef mempty) newtype EvaluatingVar = EvaluatingVar (IORef (HashSet NormalizedFilePath)) @@ -91,8 +101,8 @@ pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing #endif -evalParsedModuleRule :: Rules () -evalParsedModuleRule = defineEarlyCutoff $ RuleNoDiagnostics $ \GetEvalComments nfp -> do +evalParsedModuleRule :: Recorder (WithPriority Log) -> Rules () +evalParsedModuleRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetEvalComments nfp -> do (pm, posMap) <- useWithStale_ GetParsedModuleWithComments nfp let comments = foldMap (\case L (RealSrcSpanAlready real) bdy @@ -123,8 +133,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 (WithPriority Log) -> Rules () +redefinedNeedsCompilation recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation f -> do alwaysRerun EvaluatingVar var <- getIdeGlobalAction diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index 36c0feb951..2830815fe7 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -30,7 +30,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/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 7a14519904..6f42430748 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 #-} @@ -13,6 +14,7 @@ module Ide.Plugin.ExplicitImports , descriptorForModules , extractMinimalImports , within + , Log(..) ) where import Control.DeepSeq @@ -29,8 +31,10 @@ 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 Development.IDE.Types.Logger as Logger (Pretty (pretty)) import GHC.Generics (Generic) import Ide.PluginUtils (mkLspCommand) import Ide.Types @@ -40,24 +44,33 @@ import Language.LSP.Types importCommandId :: CommandId importCommandId = "ImportLensCommand" +newtype Log + = LogShake Shake.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + -- | The "main" function of a plugin -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor = +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder = -- (almost) no one wants to see an explicit import list for Prelude - descriptorForModules (/= moduleName pRELUDE) + descriptorForModules recorder (/= moduleName pRELUDE) descriptorForModules - :: (ModuleName -> Bool) + :: Recorder (WithPriority 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 @@ -185,8 +198,8 @@ exportedModuleStrings ParsedModule{pm_parsed_source = L _ HsModule{..}} = map prettyPrint exports exportedModuleStrings _ = [] -minimalImportsRule :: Rules () -minimalImportsRule = define $ \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-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/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 3f4ca1b510..a5ba0b9c2e 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 #-} @@ -26,6 +27,7 @@ module Ide.Plugin.Hlint ( descriptor + , Log(..) ) where import Control.Arrow ((&&&)) import Control.Concurrent.STM @@ -109,6 +111,7 @@ import Language.LSP.Types hiding import qualified Language.LSP.Types as LSP import qualified Language.LSP.Types.Lens as LSP +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Spans.Pragmas (LineSplitTextEdits (LineSplitTextEdits), NextPragmaInfo (NextPragmaInfo), getNextPragmaInfo, @@ -122,6 +125,14 @@ import System.Environment (setEnv, import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- +newtype Log + = LogShake Shake.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty 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 @@ -133,9 +144,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 (WithPriority 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 +174,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 (WithPriority Log) -> PluginId -> Rules () +rules recorder plugin = 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 $ \GetHlintSettings -> do + defineNoFile (cmapWithPrio LogShake recorder) $ \GetHlintSettings -> do (Config flags) <- getHlintConfig plugin liftIO $ argsSettings flags @@ -519,7 +530,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-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 65242266c2..b0fa0987ae 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -25,7 +25,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/src/Ide/Plugin/RefineImports.hs b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs index 6e505377cc..2519ce1366 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -2,12 +2,13 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# 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,7 +38,9 @@ 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 qualified Development.IDE.Types.Logger as Logger import GHC.Generics (Generic) import Ide.Plugin.ExplicitImports (extractMinimalImports, within) @@ -46,11 +49,17 @@ import Ide.Types import Language.LSP.Server import Language.LSP.Types +newtype Log = LogShake Shake.Log deriving Show + +instance Pretty Log where + pretty = \case + LogShake log -> pretty log + -- | plugin declaration -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) +descriptor :: Recorder (WithPriority 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 +172,8 @@ newtype RefineImportsResult = RefineImportsResult instance Show RefineImportsResult where show _ = "" instance NFData RefineImportsResult where rnf = rwhnf -refineImportsRule :: Rules () -refineImportsRule = define $ \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-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 diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs index de93d03ed0..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) 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 104de36d50..ed896a99eb 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 (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,8 +63,18 @@ 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, Pretty (pretty)) +import qualified Development.IDE.Core.Shake as Shake +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" @@ -550,9 +560,9 @@ instance NFData GetMetaprograms type instance RuleResult GetMetaprograms = [(Tracked 'Current RealSrcSpan, T.Text)] -wingmanRules :: PluginId -> Rules () -wingmanRules plId = do - define $ \WriteDiagnostics nfp -> +wingmanRules :: Recorder (WithPriority Log) -> PluginId -> Rules () +wingmanRules recorder plId = do + define (cmapWithPrio LogShake recorder) $ \WriteDiagnostics nfp -> usePropertyAction #hole_severity plId properties >>= \case Nothing -> pure (mempty, Just ()) Just severity -> @@ -585,7 +595,7 @@ wingmanRules plId = do , Just () ) - defineNoDiagnostics $ \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 d01bdbbc92..6473a725d5 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Plugin.hs @@ -9,20 +9,29 @@ 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, cmapWithPrio, WithPriority, Pretty (pretty)) +newtype Log + = LogWingmanLanguageServer WingmanLanguageServer.Log + deriving Show -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId +instance Pretty Log where + pretty = \case + LogWingmanLanguageServer log -> pretty log + +descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = installInteractions ( emptyCaseInteraction : fmap makeTacticInteraction [minBound .. maxBound] ) $ (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentHover hoverProvider - , pluginRules = wingmanRules plId + , pluginRules = wingmanRules (cmapWithPrio LogWingmanLanguageServer recorder) plId , pluginConfigDescriptor = defaultConfigDescriptor { configCustomConfig = mkCustomConfig properties diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs index 08ecb83c2e..9f124efdb6 100644 --- a/plugins/hls-tactics-plugin/test/Utils.hs +++ b/plugins/hls-tactics-plugin/test/Utils.hs @@ -35,7 +35,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 diff --git a/src/Ide/Arguments.hs b/src/Ide/Arguments.hs index b94463b841..eb87bee30c 100644 --- a/src/Ide/Arguments.hs +++ b/src/Ide/Arguments.hs @@ -151,3 +151,4 @@ haskellLanguageServerVersion = do <> " (GHC: " <> VERSION_ghc <> ") (PATH: " <> path <> ")" <> gitHashSection + diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 3925c985a7..73acc2a922 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -5,26 +5,29 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# 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 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 +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 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 +import qualified HIE.Bios.Environment as HieBios import HIE.Bios.Types -import qualified HIE.Bios.Environment as HieBios import Ide.Arguments import Ide.Logger import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, @@ -32,15 +35,31 @@ 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 -defaultMain :: Arguments -> IdePlugins IdeState -> IO () -defaultMain args idePlugins = do +data Log + = LogVersion !String + | LogDirectory !FilePath + | LogLspStart !GhcideArguments ![PluginId] + | 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 -> + nest 2 $ + vsep + [ "Starting (haskell-language-server) LSP server..." + , viaShow ghcideArgs + , "PluginIds:" <+> pretty (coerce @_ @[Text] pluginIds) ] + LogIDEMain iDEMainLog -> pretty iDEMainLog + +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 @@ -72,8 +91,8 @@ defaultMain args idePlugins = do Ghcide ghcideArgs -> do {- see WARNING above -} - hPutStrLn stderr hlsVer - runLspMode ghcideArgs idePlugins + logWith recorder Info $ LogVersion hlsVer + runLspMode recorder ghcideArgs idePlugins VSCodeExtensionSchemaMode -> do LBS.putStrLn $ A.encodePretty $ pluginsToVSCodeExtensionSchema idePlugins @@ -101,25 +120,22 @@ hlsLogger = G.Logger $ \pri txt -> -- --------------------------------------------------------------------- -runLspMode :: GhcideArguments -> IdePlugins IdeState -> IO () -runLspMode ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLogger $ \telemetryLogger -> do +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 - LSP.setupLogger argsLogFile ["hls", "hie-bios"] - $ if argsDebugOn then L.DEBUG else L.INFO + log Info $ LogDirectory dir 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 Info $ LogLspStart ghcideArgs (map fst $ ipMap idePlugins) + + IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) (IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) hlsLogger) + { 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 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