Skip to content

Commit 3995f3a

Browse files
pepeiborrapepeiborra
authored
Add an option to control progress reporting (#1513)
* add an option to control progress reporting * remove redundant imports * Tracing: avoid calling actionBracket for no reason * restore CPP - I have no idea how it got stripped * add a comment
1 parent e16833e commit 3995f3a

File tree

6 files changed

+66
-43
lines changed

6 files changed

+66
-43
lines changed

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

Lines changed: 1 addition & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -13,19 +13,17 @@ where
1313
import Control.Concurrent.Extra
1414
import Control.Exception
1515
import Control.Monad.Extra
16-
import Data.Binary
1716
import qualified Data.ByteString as BS
1817
import Data.HashMap.Strict (HashMap)
1918
import qualified Data.HashMap.Strict as HashMap
2019
import Data.Maybe
2120
import Development.IDE.Core.FileStore
2221
import Development.IDE.Core.IdeConfiguration
22+
import Development.IDE.Core.RuleTypes
2323
import Development.IDE.Core.Shake
2424
import Development.IDE.Types.Location
2525
import Development.IDE.Types.Options
2626
import Development.Shake
27-
import Development.Shake.Classes
28-
import GHC.Generics
2927
import Language.LSP.Server hiding (getVirtualFile)
3028
import Language.LSP.Types
3129
import Language.LSP.Types.Capabilities
@@ -112,15 +110,6 @@ fromChange FcChanged = Nothing
112110

113111
-------------------------------------------------------------------------------------
114112

115-
type instance RuleResult GetFileExists = Bool
116-
117-
data GetFileExists = GetFileExists
118-
deriving (Eq, Show, Typeable, Generic)
119-
120-
instance NFData GetFileExists
121-
instance Hashable GetFileExists
122-
instance Binary GetFileExists
123-
124113
-- | Returns True if the file exists
125114
-- Note that a file is not considered to exist unless it is saved to disk.
126115
-- In particular, VFS existence is not enough.

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

Lines changed: 20 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -43,7 +43,7 @@ import Data.Text (Text)
4343
import Development.IDE.Import.FindImports (ArtifactsLocation)
4444
import Development.IDE.Spans.Common
4545
import Development.IDE.Spans.LocalBindings
46-
import Development.IDE.Types.Options (IdeGhcSession)
46+
import Development.IDE.Types.Diagnostics
4747
import Fingerprint
4848
import GHC.Serialized (Serialized)
4949
import Language.LSP.Types (NormalizedFilePath)
@@ -254,6 +254,9 @@ type instance RuleResult GetModIfaceWithoutLinkable = HiFileResult
254254
-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
255255
type instance RuleResult GetFileContents = (FileVersion, Maybe Text)
256256

257+
type instance RuleResult GetFileExists = Bool
258+
259+
257260
-- The Shake key type for getModificationTime queries
258261
newtype GetModificationTime = GetModificationTime_
259262
{ missingFileDiagnostics :: Bool
@@ -299,6 +302,12 @@ instance Hashable GetFileContents
299302
instance NFData GetFileContents
300303
instance Binary GetFileContents
301304

305+
data GetFileExists = GetFileExists
306+
deriving (Eq, Show, Typeable, Generic)
307+
308+
instance NFData GetFileExists
309+
instance Hashable GetFileExists
310+
instance Binary GetFileExists
302311

303312
data FileOfInterestStatus
304313
= OnDisk
@@ -478,6 +487,16 @@ type instance RuleResult GetClientSettings = Hashed (Maybe Value)
478487
-- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547
479488
type instance RuleResult GhcSessionIO = IdeGhcSession
480489

490+
data IdeGhcSession = IdeGhcSession
491+
{ loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
492+
-- ^ Returns the Ghc session and the cradle dependencies
493+
, sessionVersion :: !Int
494+
-- ^ Used as Shake key, versions must be unique and not reused
495+
}
496+
497+
instance Show IdeGhcSession where show _ = "IdeGhcSession"
498+
instance NFData IdeGhcSession where rnf !_ = ()
499+
481500
data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic)
482501
instance Hashable GhcSessionIO
483502
instance NFData GhcSessionIO

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -939,8 +939,8 @@ defineEarlyCutoff'
939939
-> Action (RunResult (A (RuleResult k)))
940940
defineEarlyCutoff' doDiagnostics key file old mode action = do
941941
extras@ShakeExtras{state, inProgress} <- getShakeExtras
942-
-- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key
943-
(if show key == "GetFileExists" then id else withProgressVar inProgress file) $ do
942+
options <- getIdeOptions
943+
(if optSkipProgress options key then id else withProgressVar inProgress file) $ do
944944
val <- case old of
945945
Just old | mode == RunDependenciesSame -> do
946946
v <- liftIO $ getValues state key file

‎ghcide/src/Development/IDE/Core/Tracing.hs

Lines changed: 25 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,7 @@ import Development.IDE.Types.Shake (Key (..), Value,
3636
Values)
3737
import Development.Shake (Action, actionBracket)
3838
import Foreign.Storable (Storable (sizeOf))
39+
import GHC.RTS.Flags
3940
import HeapSize (recursiveSize, runHeapsize)
4041
import Ide.PluginUtils (installSigUsr1Handler)
4142
import Ide.Types (PluginId (..))
@@ -47,6 +48,7 @@ import OpenTelemetry.Eventlog (Instrument, SpanInFlight,
4748
addEvent, beginSpan, endSpan,
4849
mkValueObserver, observe,
4950
setTag, withSpan, withSpan_)
51+
import System.IO.Unsafe (unsafePerformIO)
5052

5153
-- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span.
5254
otTracedHandler
@@ -68,6 +70,14 @@ otTracedHandler requestType label act =
6870
otSetUri :: SpanInFlight -> Uri -> IO ()
6971
otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t)
7072

73+
{-# NOINLINE isTracingEnabled #-}
74+
isTracingEnabled :: Bool
75+
isTracingEnabled = unsafePerformIO $ do
76+
flags <- getTraceFlags
77+
case tracing flags of
78+
TraceNone -> return False
79+
_ -> return True
80+
7181
-- | Trace a Shake action using opentelemetry.
7282
otTracedAction
7383
:: Show k
@@ -76,17 +86,20 @@ otTracedAction
7686
-> (a -> Bool) -- ^ Did this action succeed?
7787
-> Action a -- ^ The action
7888
-> Action a
79-
otTracedAction key file success act = actionBracket
80-
(do
81-
sp <- beginSpan (fromString (show key))
82-
setTag sp "File" (fromString $ fromNormalizedFilePath file)
83-
return sp
84-
)
85-
endSpan
86-
(\sp -> do
87-
res <- act
88-
unless (success res) $ setTag sp "error" "1"
89-
return res)
89+
otTracedAction key file success act
90+
| isTracingEnabled =
91+
actionBracket
92+
(do
93+
sp <- beginSpan (fromString (show key))
94+
setTag sp "File" (fromString $ fromNormalizedFilePath file)
95+
return sp
96+
)
97+
endSpan
98+
(\sp -> do
99+
res <- act
100+
unless (success res) $ setTag sp "error" "1"
101+
return res)
102+
| otherwise = act
90103

91104
#if MIN_GHC_API_VERSION(8,8,0)
92105
otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a
@@ -220,3 +233,4 @@ repeatUntilJust nattempts action = do
220233
case res of
221234
Nothing -> repeatUntilJust (nattempts-1) action
222235
Just{} -> return res
236+

‎ghcide/src/Development/IDE/GHC/ExactPrint.hs

Lines changed: 0 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -67,11 +67,6 @@ import Data.Monoid (All(All))
6767
#if __GLASGOW_HASKELL__ == 808
6868
import Control.Arrow
6969
#endif
70-
#if __GLASGOW_HASKELL__ > 808
71-
import Bag (listToBag)
72-
import ErrUtils (mkErrMsg)
73-
import Outputable (text, neverQualify)
74-
#endif
7570

7671

7772
------------------------------------------------------------------------------

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

Lines changed: 18 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
-- SPDX-License-Identifier: Apache-2.0
33

44
-- | Options
5+
{-# LANGUAGE RankNTypes #-}
56
module Development.IDE.Types.Options
67
( IdeOptions(..)
78
, IdePreprocessedSource(..)
@@ -17,27 +18,17 @@ module Development.IDE.Types.Options
1718
, OptHaddockParse(..)
1819
,optShakeFiles) where
1920

20-
import Control.DeepSeq (NFData (..))
2121
import qualified Data.Text as T
22+
import Data.Typeable
23+
import Development.IDE.Core.RuleTypes
2224
import Development.IDE.Types.Diagnostics
23-
import Development.IDE.Types.HscEnvEq (HscEnvEq)
2425
import Development.Shake
2526
import GHC hiding (parseModule,
2627
typecheckModule)
2728
import GhcPlugins as GHC hiding (fst3, (<>))
2829
import Ide.Plugin.Config
2930
import qualified Language.LSP.Types.Capabilities as LSP
3031

31-
data IdeGhcSession = IdeGhcSession
32-
{ loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
33-
-- ^ Returns the Ghc session and the cradle dependencies
34-
, sessionVersion :: !Int
35-
-- ^ Used as Shake key, versions must be unique and not reused
36-
}
37-
38-
instance Show IdeGhcSession where show _ = "IdeGhcSession"
39-
instance NFData IdeGhcSession where rnf !_ = ()
40-
4132
data IdeOptions = IdeOptions
4233
{ optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource
4334
-- ^ Preprocessor to run over all parsed source trees, generating a list of warnings
@@ -85,6 +76,8 @@ data IdeOptions = IdeOptions
8576
-- ^ Will be called right after setting up a new cradle,
8677
-- allowing to customize the Ghc options used
8778
, optShakeOptions :: ShakeOptions
79+
, optSkipProgress :: forall a. Typeable a => a -> Bool
80+
-- ^ Predicate to select which rule keys to exclude from progress reporting.
8881
}
8982

9083
optShakeFiles :: IdeOptions -> Maybe FilePath
@@ -137,8 +130,21 @@ defaultIdeOptions session = IdeOptions
137130
,optCheckParents = pure CheckOnSaveAndClose
138131
,optHaddockParse = HaddockParse
139132
,optCustomDynFlags = id
133+
,optSkipProgress = defaultSkipProgress
140134
}
141135

136+
defaultSkipProgress :: Typeable a => a -> Bool
137+
defaultSkipProgress key = case () of
138+
-- don't do progress for GetFileContents as it's cheap
139+
_ | Just GetFileContents <- cast key -> True
140+
-- don't do progress for GetFileExists, as there are lots of redundant nodes
141+
-- (normally there is one node per file, but this is not the case for GetFileExists)
142+
_ | Just GetFileExists <- cast key -> True
143+
-- don't do progress for GetModificationTime as there are lot of redundant nodes
144+
-- (for the interface files)
145+
_ | Just GetModificationTime_{} <- cast key -> True
146+
_ -> False
147+
142148

143149
-- | The set of options used to locate files belonging to external packages.
144150
data IdePkgLocationOptions = IdePkgLocationOptions

0 commit comments

Comments
 (0)