diff --git a/ghcide/src/Development/IDE/Core/Debouncer.hs b/ghcide/src/Development/IDE/Core/Debouncer.hs index 41ffd766cc..d7df9bad49 100644 --- a/ghcide/src/Development/IDE/Core/Debouncer.hs +++ b/ghcide/src/Development/IDE/Core/Debouncer.hs @@ -11,7 +11,8 @@ module Development.IDE.Core.Debouncer import Control.Concurrent.Async import Control.Concurrent.Extra import Control.Exception -import Control.Monad.Extra +import Control.Monad (join) +import Data.Foldable (traverse_) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map import Data.Hashable @@ -40,17 +41,18 @@ newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty -- to mask if required. asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO () asyncRegisterEvent d 0 k fire = do - modifyVar_ d $ \m -> mask_ $ do - whenJust (Map.lookup k m) cancel - pure $ Map.delete k m + join $ modifyVar d $ \m -> do + (cancel, !m') <- evaluate $ Map.alterF (\prev -> (traverse_ cancel prev, Nothing)) k m + return (m', cancel) fire -asyncRegisterEvent d delay k fire = modifyVar_ d $ \m -> mask_ $ do - whenJust (Map.lookup k m) cancel +asyncRegisterEvent d delay k fire = mask_ $ do a <- asyncWithUnmask $ \unmask -> unmask $ do sleep delay fire - modifyVar_ d (pure . Map.delete k) - pure $ Map.insert k a m + modifyVar_ d (evaluate . Map.delete k) + join $ modifyVar d $ \m -> do + (cancel, !m') <- evaluate $ Map.alterF (\prev -> (traverse_ cancel prev, Just a)) k m + return (m', cancel) -- | Debouncer used in the DAML CLI compiler that emits events immediately. noopDebouncer :: Debouncer k diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index b0d7d53277..17f82caad2 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1100,15 +1100,16 @@ updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, p let uri = filePathToUri' fp let delay = if null newDiags then 0.1 else 0 registerEvent debouncer delay uri $ do - mask_ $ modifyVar_ publishedDiagnostics $ \published -> do + join $ mask_ $ modifyVar publishedDiagnostics $ \published -> do let lastPublish = HMap.lookupDefault [] uri published - when (lastPublish /= newDiags) $ case lspEnv of - Nothing -> -- Print an LSP event. - logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags - Just env -> LSP.runLspT env $ - LSP.sendNotification LSP.STextDocumentPublishDiagnostics $ - LSP.PublishDiagnosticsParams (fromNormalizedUri uri) ver (List newDiags) - pure $! HMap.insert uri newDiags published + !published' = HMap.insert uri newDiags published + action = when (lastPublish /= newDiags) $ case lspEnv of + Nothing -> -- Print an LSP event. + logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags + Just env -> LSP.runLspT env $ + LSP.sendNotification LSP.STextDocumentPublishDiagnostics $ + LSP.PublishDiagnosticsParams (fromNormalizedUri uri) ver (List newDiags) + return (published', action) newtype Priority = Priority Double diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 14f58a0a83..2d8128e69a 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -15,7 +15,8 @@ import Data.Maybe (catMaybes, fromMaybe, import qualified Data.Text as T import qualified Data.Text.IO as T import Development.IDE (Action, Rules) -import Development.IDE.Core.Debouncer (newAsyncDebouncer) +import Development.IDE.Core.Debouncer (Debouncer, + newAsyncDebouncer) import Development.IDE.Core.FileStore (makeVFSHandle) import Development.IDE.Core.IdeConfiguration (IdeConfiguration (..), registerIdeConfiguration) @@ -43,7 +44,8 @@ import Development.IDE.Session (SessionLoadingOptions, loadSessionWithOptions, runWithDb, setInitialDynFlags) -import Development.IDE.Types.Location (toNormalizedFilePath') +import Development.IDE.Types.Location (NormalizedUri, + toNormalizedFilePath') import Development.IDE.Types.Logger (Logger (Logger)) import Development.IDE.Types.Options (IdeGhcSession, IdeOptions (optCheckParents, optCheckProject, optReportProgress), @@ -86,6 +88,7 @@ data Arguments = Arguments , argsLspOptions :: LSP.Options , argsDefaultHlsConfig :: Config , argsGetHieDbLoc :: FilePath -> IO FilePath -- ^ Map project roots to the location of the hiedb for the project + , argsDebouncer :: IO (Debouncer NormalizedUri) -- ^ Debouncer used for diagnostics } instance Default Arguments where @@ -101,6 +104,7 @@ instance Default Arguments where , argsLspOptions = def {LSP.completionTriggerCharacters = Just "."} , argsDefaultHlsConfig = def , argsGetHieDbLoc = getHieDbLoc + , argsDebouncer = newAsyncDebouncer } -- | Cheap stderr logger that relies on LineBuffering @@ -123,6 +127,8 @@ defaultMain Arguments{..} = do argsOnConfigChange _ide = pure . getConfigFromNotification argsDefaultHlsConfig rules = argsRules >> pluginRules plugins + debouncer <- argsDebouncer + case argFiles of Nothing -> do t <- offsetTime @@ -148,7 +154,6 @@ defaultMain Arguments{..} = do { optReportProgress = clientSupportsProgress caps } caps = LSP.resClientCapabilities env - debouncer <- newAsyncDebouncer initialise argsDefaultHlsConfig rules @@ -184,7 +189,6 @@ defaultMain Arguments{..} = do when (n > 0) $ putStrLn $ " (" ++ intercalate ", " (catMaybes ucradles) ++ ")" putStrLn "\nStep 3/4: Initializing the IDE" vfs <- makeVFSHandle - debouncer <- newAsyncDebouncer sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir let options = (argsIdeOptions Nothing sessionLoader) { optCheckParents = pure NeverCheck