add an option to control progress reporting

Author: pepeiborra

ghcide/src/Development/IDE/Core/FileExists.hs

@@ -13,19 +13,17 @@ where
 import           Control.Concurrent.Extra
 import           Control.Exception
 import           Control.Monad.Extra
-import           Data.Binary
 import qualified Data.ByteString                       as BS
 import           Data.HashMap.Strict                   (HashMap)
 import qualified Data.HashMap.Strict                   as HashMap
 import           Data.Maybe
 import           Development.IDE.Core.FileStore
 import           Development.IDE.Core.IdeConfiguration
+import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Shake
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
 import           Development.Shake
-import           Development.Shake.Classes
-import           GHC.Generics
 import           Language.LSP.Server                   hiding (getVirtualFile)
 import           Language.LSP.Types
 import           Language.LSP.Types.Capabilities
@@ -112,15 +110,6 @@ fromChange FcChanged = Nothing
 
 -------------------------------------------------------------------------------------
 
-type instance RuleResult GetFileExists = Bool
-
-data GetFileExists = GetFileExists
-    deriving (Eq, Show, Typeable, Generic)
-
-instance NFData   GetFileExists
-instance Hashable GetFileExists
-instance Binary   GetFileExists
-
 -- | Returns True if the file exists
 --   Note that a file is not considered to exist unless it is saved to disk.
 --   In particular, VFS existence is not enough.

ghcide/src/Development/IDE/Core/RuleTypes.hs

@@ -43,7 +43,7 @@ import           Data.Text                                    (Text)
 import           Development.IDE.Import.FindImports           (ArtifactsLocation)
 import           Development.IDE.Spans.Common
 import           Development.IDE.Spans.LocalBindings
-import           Development.IDE.Types.Options                (IdeGhcSession)
+import           Development.IDE.Types.Diagnostics
 import           Fingerprint
 import           GHC.Serialized                               (Serialized)
 import           Language.LSP.Types                           (NormalizedFilePath)
@@ -254,6 +254,9 @@ type instance RuleResult GetModIfaceWithoutLinkable = HiFileResult
 -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
 type instance RuleResult GetFileContents = (FileVersion, Maybe Text)
 
+type instance RuleResult GetFileExists = Bool
+
+
 -- The Shake key type for getModificationTime queries
 newtype GetModificationTime = GetModificationTime_
     { missingFileDiagnostics :: Bool
@@ -299,6 +302,12 @@ instance Hashable GetFileContents
 instance NFData   GetFileContents
 instance Binary   GetFileContents
 
+data GetFileExists = GetFileExists
+    deriving (Eq, Show, Typeable, Generic)
+
+instance NFData   GetFileExists
+instance Hashable GetFileExists
+instance Binary   GetFileExists
 
 data FileOfInterestStatus
   = OnDisk
@@ -478,6 +487,16 @@ type instance RuleResult GetClientSettings = Hashed (Maybe Value)
 -- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547
 type instance RuleResult GhcSessionIO = IdeGhcSession
 
+data IdeGhcSession = IdeGhcSession
+  { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
+  -- ^ Returns the Ghc session and the cradle dependencies
+  , sessionVersion :: !Int
+  -- ^ Used as Shake key, versions must be unique and not reused
+  }
+
+instance Show IdeGhcSession where show _ = "IdeGhcSession"
+instance NFData IdeGhcSession where rnf !_ = ()
+
 data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)
 instance Hashable GhcSessionIO
 instance NFData   GhcSessionIO

ghcide/src/Development/IDE/Core/Shake.hs

@@ -939,8 +939,8 @@ defineEarlyCutoff'
     -> Action (RunResult (A (RuleResult k)))
 defineEarlyCutoff' doDiagnostics key file old mode action = do
     extras@ShakeExtras{state, inProgress} <- getShakeExtras
-    -- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key
-    (if show key == "GetFileExists" then id else withProgressVar inProgress file) $ do
+    options <- getIdeOptions
+    (if optSkipProgress options key then id else withProgressVar inProgress file) $ do
         val <- case old of
             Just old | mode == RunDependenciesSame -> do
                 v <- liftIO $ getValues state key file

ghcide/src/Development/IDE/Types/Options.hs

@@ -2,6 +2,7 @@
 -- SPDX-License-Identifier: Apache-2.0
 
 -- | Options
+{-# LANGUAGE RankNTypes #-}
 module Development.IDE.Types.Options
   ( IdeOptions(..)
   , IdePreprocessedSource(..)
@@ -17,27 +18,17 @@ module Development.IDE.Types.Options
   , OptHaddockParse(..)
   ,optShakeFiles) where
 
-import           Control.DeepSeq                   (NFData (..))
 import qualified Data.Text                         as T
+import           Data.Typeable
+import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Types.Diagnostics
-import           Development.IDE.Types.HscEnvEq    (HscEnvEq)
 import           Development.Shake
 import           GHC                               hiding (parseModule,
                                                     typecheckModule)
 import           GhcPlugins                        as GHC hiding (fst3, (<>))
 import           Ide.Plugin.Config
 import qualified Language.LSP.Types.Capabilities   as LSP
 
-data IdeGhcSession = IdeGhcSession
-  { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
-  -- ^ Returns the Ghc session and the cradle dependencies
-  , sessionVersion :: !Int
-  -- ^ Used as Shake key, versions must be unique and not reused
-  }
-
-instance Show IdeGhcSession where show _ = "IdeGhcSession"
-instance NFData IdeGhcSession where rnf !_ = ()
-
 data IdeOptions = IdeOptions
   { optPreprocessor       :: GHC.ParsedSource -> IdePreprocessedSource
     -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings
@@ -85,6 +76,8 @@ data IdeOptions = IdeOptions
     -- ^ Will be called right after setting up a new cradle,
     --   allowing to customize the Ghc options used
   , optShakeOptions       :: ShakeOptions
+  , optSkipProgress       :: forall a. Typeable a => a -> Bool
+      -- ^ Predicate to select which rule keys to exclude from progress reporting.
   }
 
 optShakeFiles :: IdeOptions -> Maybe FilePath
@@ -137,8 +130,16 @@ defaultIdeOptions session = IdeOptions
     ,optCheckParents = pure CheckOnSaveAndClose
     ,optHaddockParse = HaddockParse
     ,optCustomDynFlags = id
+    ,optSkipProgress = defaultSkipProgress
     }
 
+defaultSkipProgress :: Typeable a => a -> Bool
+defaultSkipProgress key = case () of
+    _ | Just GetFileContents <- cast key        -> True
+    _ | Just GetFileExists <- cast key          -> True
+    _ | Just GetModificationTime_{} <- cast key -> True
+    _                                           -> False
+
 
 -- | The set of options used to locate files belonging to external packages.
 data IdePkgLocationOptions = IdePkgLocationOptions