d61807c · ghcide · git.iko.soy

git.iko.soy/ghcide

on master help sign in

Implement debouncing of diagnostics (#1991)

d61807cMoritz Kiefer7 years ago

src/Development/IDE/Core/Debouncer.hsnew file+45

compare with master

unifiedsplit

@@ -0,0 +1,45 @@

2+-- SPDX-License-Identifier: Apache-2.0

4+module Development.IDE.Core.Debouncer

5+ ( Debouncer

6+ , newDebouncer

7+ , registerEvent

8+ ) where

10+import Control.Concurrent.Extra

11+import Control.Concurrent.Async

12+import Control.Exception

13+import Control.Monad.Extra

14+import Data.Map.Strict (Map)

15+import qualified Data.Map.Strict as Map

16+import System.Time.Extra

17+

18+-- | A debouncer can be used to avoid triggering many events

19+-- (e.g. diagnostics) for the same key (e.g. the same file)

20+-- within a short timeframe. This is accomplished

21+-- by delaying each event for a given time. If another event

22+-- is registered for the same key within that timeframe,

23+-- only the new event will fire.

24+newtype Debouncer k = Debouncer (Var (Map k (Async ())))

25+

26+-- | Create a new empty debouncer.

27+newDebouncer :: IO (Debouncer k)

28+newDebouncer = do

29+ m <- newVar Map.empty

30+ pure $ Debouncer m

31+

32+-- | Register an event that will fire after the given delay if no other event

33+-- for the same key gets registered until then.

34+--

35+-- If there is a pending event for the same key, the pending event will be killed.

36+-- Events are run unmasked so it is up to the user of `registerEvent`

37+-- to mask if required.

38+registerEvent :: Ord k => Debouncer k -> Seconds -> k -> IO () -> IO ()

39+registerEvent (Debouncer d) delay k fire = modifyVar_ d $ \m -> mask_ $ do

40+ whenJust (Map.lookup k m) cancel

41+ a <- asyncWithUnmask $ \unmask -> unmask $ do

42+ sleep delay

43+ fire

44+ modifyVar_ d (pure . Map.delete k)

45+ pure $ Map.insert k a m

src/Development/IDE/Core/Shake.hs+11−6

@@ -54,6 +54,7 @@ import Data.Maybe

54import Data.Either.Extra

55import Data.List.Extra

56import qualified Data.Text as T

57+import Development.IDE.Core.Debouncer

57import Development.IDE.Types.Logger hiding (Priority)

58import Development.IDE.Types.Logger hiding (Priority)

58import Language.Haskell.LSP.Diagnostics

59import Language.Haskell.LSP.Diagnostics

59import qualified Data.SortedList as SL

60import qualified Data.SortedList as SL

@@ -79,6 +80,7 @@ import Language.Haskell.LSP.Types

79-- information we stash inside the shakeExtra field

80-- information we stash inside the shakeExtra field

80data ShakeExtras = ShakeExtras

81data ShakeExtras = ShakeExtras

81 {eventer :: LSP.FromServerMessage -> IO ()

82 {eventer :: LSP.FromServerMessage -> IO ()

83+ ,debouncer :: Debouncer Uri

82 ,logger :: Logger

84 ,logger :: Logger

83 ,globals :: Var (HMap.HashMap TypeRep Dynamic)

85 ,globals :: Var (HMap.HashMap TypeRep Dynamic)

84 ,state :: Var Values

86 ,state :: Var Values

@@ -222,6 +224,7 @@ shakeOpen eventer logger opts rules = do

222 globals <- newVar HMap.empty

224 globals <- newVar HMap.empty

223 state <- newVar HMap.empty

225 state <- newVar HMap.empty

224 diagnostics <- newVar mempty

226 diagnostics <- newVar mempty

227+ debouncer <- newDebouncer

225 pure ShakeExtras{..}

228 pure ShakeExtras{..}

226 (shakeDb, shakeClose) <- shakeOpenDatabase opts{shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts} rules

229 (shakeDb, shakeClose) <- shakeOpenDatabase opts{shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts} rules

227 shakeAbort <- newVar $ return ()

230 shakeAbort <- newVar $ return ()

@@ -379,7 +382,7 @@ updateFileDiagnostics ::

379 -> ShakeExtras

382 -> ShakeExtras

380 -> [Diagnostic] -- ^ current results

383 -> [Diagnostic] -- ^ current results

381 -> Action ()

384 -> Action ()

382−updateFileDiagnostics fp k ShakeExtras{diagnostics, state, eventer} current = liftIO $ do

385+updateFileDiagnostics fp k ShakeExtras{diagnostics, state, debouncer, eventer} current = liftIO $ do

383 modTime <- join <$> getValues state GetModificationTime fp

386 modTime <- join <$> getValues state GetModificationTime fp

384 mask_ $ do

387 mask_ $ do

385 -- Mask async exceptions to ensure that updated diagnostics are always

388 -- Mask async exceptions to ensure that updated diagnostics are always

@@ -391,14 +394,16 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, state, eventer} current = li

391 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime) (T.pack $ show k) current old

394 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime) (T.pack $ show k) current old

392 let newDiags = getFileDiagnostics fp newDiagsStore

395 let newDiags = getFileDiagnostics fp newDiagsStore

393 pure (newDiagsStore, (newDiags, oldDiags))

396 pure (newDiagsStore, (newDiags, oldDiags))

397+ let uri = fromNormalizedUri $ filePathToUri' fp

394− when (newDiags /= oldDiags) $

398+ when (newDiags /= oldDiags) $ do

399+ let delay = if null newDiags then 0.1 else 0

395− eventer $ publishDiagnosticsNotification fp newDiags

400+ registerEvent debouncer delay uri $ eventer $ publishDiagnosticsNotification uri newDiags

396

401

397−publishDiagnosticsNotification :: NormalizedFilePath -> [Diagnostic] -> LSP.FromServerMessage

402+publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage

398−publishDiagnosticsNotification fp diags =

403+publishDiagnosticsNotification uri diags =

399 LSP.NotPublishDiagnostics $

404 LSP.NotPublishDiagnostics $

400 LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $

405 LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $

401− LSP.PublishDiagnosticsParams (fromNormalizedUri $ filePathToUri' fp) (List diags)

406+ LSP.PublishDiagnosticsParams uri (List diags)

402

407

403newtype Priority = Priority Double

408newtype Priority = Priority Double

404

409