diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index fb35e46e61..cf6214a868 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -247,7 +247,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do } <- getShakeExtras let invalidateShakeCache = do void $ modifyVar' version succ - recordDirtyKeys extras GhcSessionIO [emptyFilePath] + atomically $ recordDirtyKeys extras GhcSessionIO [emptyFilePath] IdeOptions{ optTesting = IdeTesting optTesting , optCheckProject = getCheckProject @@ -264,7 +264,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do TargetModule _ -> do found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations return (targetTarget, found) - recordDirtyKeys extras GetKnownTargets [emptyFilePath] + atomically $ recordDirtyKeys extras GetKnownTargets [emptyFilePath] modifyVarIO' knownTargetsVar $ traverseHashed $ \known -> do let known' = HM.unionWith (<>) known $ HM.fromList $ map (second Set.fromList) knownTargets when (known /= known') $ diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index af9c402838..b2d4df947c 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -10,6 +10,7 @@ module Development.IDE.Core.FileExists ) where +import Control.Concurrent.STM.Stats import Control.Concurrent.Strict import Control.Exception import Control.Monad.Extra @@ -100,9 +101,11 @@ modifyFileExists state changes = do -- flush previous values let (fileModifChanges, fileExistChanges) = partition ((== FcChanged) . snd) (HashMap.toList changesMap) - mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges - recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges - recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges + join $ atomically $ do + mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges + io1 <- recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges + io2 <- recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges + return (io1 <> io2) fromChange :: FileChangeType -> Maybe Bool fromChange FcCreated = Just True diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 2f8dee396e..74baa4fac2 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -24,7 +24,7 @@ module Development.IDE.Core.FileStore( registerFileWatches ) where -import Control.Concurrent.STM (atomically, +import Control.Concurrent.STM.Stats (STM, atomically, modifyTVar') import Control.Concurrent.STM.TQueue (writeTQueue) import Control.Concurrent.Strict @@ -160,7 +160,7 @@ isInterface :: NormalizedFilePath -> Bool isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot"] -- | Reset the GetModificationTime state of interface files -resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> IO () +resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM () resetInterfaceStore state f = do deleteValue state GetModificationTime f @@ -175,7 +175,8 @@ resetFileStore ideState changes = mask $ \_ -> do case c of FcChanged -- already checked elsewhere | not $ HM.member nfp fois - -> deleteValue (shakeExtras ideState) GetModificationTime nfp + -> atomically $ + deleteValue (shakeExtras ideState) GetModificationTime nfp _ -> pure () @@ -262,7 +263,7 @@ setFileModified state saved nfp = do VFSHandle{..} <- getIdeGlobalState state when (isJust setVirtualFileContents) $ fail "setFileModified can't be called on this type of VFSHandle" - recordDirtyKeys (shakeExtras state) GetModificationTime [nfp] + atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp] restartShakeSession (shakeExtras state) (fromNormalizedFilePath nfp ++ " (modified)") [] when checkParents $ typecheckParents state nfp diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 1cdef77375..6832e0d5ba 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -25,6 +25,7 @@ import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as T import Development.IDE.Graph +import Control.Concurrent.STM.Stats (atomically) import qualified Data.ByteString as BS import Data.Maybe (catMaybes) import Development.IDE.Core.ProgressReporting @@ -86,7 +87,7 @@ addFileOfInterest state f v = do let (prev, new) = HashMap.alterF (, Just v) f dict pure (new, (prev, new)) when (prev /= Just v) $ - recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] + join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files) @@ -94,7 +95,7 @@ deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO () deleteFileOfInterest state f = do OfInterestVar var <- getIdeGlobalState state files <- modifyVar' var $ HashMap.delete f - recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] + join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files) scheduleGarbageCollection :: IdeState -> IO () diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 4c5358bf31..6707d44163 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -148,6 +148,7 @@ import Ide.Plugin.Properties (HasProperty, import Ide.PluginUtils (configForPlugin) import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser), PluginId) +import Control.Concurrent.STM.Stats (atomically) -- | This is useful for rules to convert rules that can only produce errors or -- a result into the more general IdeResult type that supports producing @@ -1061,7 +1062,7 @@ writeHiFileAction hsc hiFile = do extras <- getShakeExtras let targetPath = Compat.ml_hi_file $ ms_location $ hirModSummary hiFile liftIO $ do - resetInterfaceStore extras $ toNormalizedFilePath' targetPath + atomically $ resetInterfaceStore extras $ toNormalizedFilePath' targetPath writeHiFile hsc hiFile data RulesConfig = RulesConfig diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 17af58a836..e7578a6ce2 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -191,9 +191,9 @@ data ShakeExtras = ShakeExtras ,logger :: Logger ,globals :: Var (HMap.HashMap TypeRep Dynamic) ,state :: Values - ,diagnostics :: Var DiagnosticStore - ,hiddenDiagnostics :: Var DiagnosticStore - ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic]) + ,diagnostics :: STMDiagnosticStore + ,hiddenDiagnostics :: STMDiagnosticStore + ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic] -- ^ This represents the set of diagnostics that we have published. -- Due to debouncing not every change might get published. ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping))) @@ -437,8 +437,8 @@ deleteValue => ShakeExtras -> k -> NormalizedFilePath - -> IO () -deleteValue ShakeExtras{dirtyKeys, state} key file = atomically $ do + -> STM () +deleteValue ShakeExtras{dirtyKeys, state} key file = do STM.delete (toKey key file) state modifyTVar' dirtyKeys $ HSet.insert (toKey key file) @@ -447,10 +447,11 @@ recordDirtyKeys => ShakeExtras -> k -> [NormalizedFilePath] - -> IO () -recordDirtyKeys ShakeExtras{dirtyKeys} key file = withEventTrace "recordDirtyKeys" $ \addEvent -> do - atomically $ modifyTVar' dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file) - addEvent (fromString $ "dirty " <> show key) (fromString $ unlines $ map fromNormalizedFilePath file) + -> STM (IO ()) +recordDirtyKeys ShakeExtras{dirtyKeys} key file = do + modifyTVar' dirtyKeys $ \x -> foldl' (flip HSet.insert) x (toKey key <$> file) + return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do + addEvent (fromString $ "dirty " <> show key) (fromString $ unlines $ map fromNormalizedFilePath file) -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. @@ -509,9 +510,9 @@ shakeOpen lspEnv defaultConfig logger debouncer shakeExtras <- do globals <- newVar HMap.empty state <- STM.newIO - diagnostics <- newVar mempty - hiddenDiagnostics <- newVar mempty - publishedDiagnostics <- newVar mempty + diagnostics <- STM.newIO + hiddenDiagnostics <- STM.newIO + publishedDiagnostics <- STM.newIO positionMapping <- newVar HMap.empty knownTargetsVar <- newVar $ hashed HMap.empty let restartShakeSession = shakeRestart ideState @@ -756,15 +757,13 @@ instantiateDelayedAction (DelayedAction _ s p a) = do d' = DelayedAction (Just u) s p a' return (b, d') -getDiagnostics :: IdeState -> IO [FileDiagnostic] +getDiagnostics :: IdeState -> STM [FileDiagnostic] getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do - val <- readVar diagnostics - return $ getAllDiagnostics val + getAllDiagnostics diagnostics -getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic] +getHiddenDiagnostics :: IdeState -> STM [FileDiagnostic] getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do - val <- readVar hiddenDiagnostics - return $ getAllDiagnostics val + getAllDiagnostics hiddenDiagnostics -- | Find and release old keys from the state Hashmap -- For the record, there are other state sources that this process does not release: @@ -1154,30 +1153,26 @@ updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, p let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current uri = filePathToUri' fp ver = vfsVersion =<< modTime - update new store = - let store' = setStageDiagnostics uri ver (T.pack $ show k) new store - new' = getUriDiagnostics uri store' - in (store', new') + update new store = setStageDiagnostics uri ver (T.pack $ show k) new store mask_ $ do -- Mask async exceptions to ensure that updated diagnostics are always -- published. Otherwise, we might never publish certain diagnostics if -- an exception strikes between modifyVar but before -- publishDiagnosticsNotification. - newDiags <- modifyVar diagnostics $ pure . update (map snd currentShown) - _ <- modifyVar hiddenDiagnostics $ pure . update (map snd currentHidden) + newDiags <- liftIO $ atomically $ update (map snd currentShown) diagnostics + _ <- liftIO $ atomically $ update (map snd currentHidden) hiddenDiagnostics let uri = filePathToUri' fp let delay = if null newDiags then 0.1 else 0 registerEvent debouncer delay uri $ do - join $ mask_ $ modifyVar publishedDiagnostics $ \published -> do - let lastPublish = HMap.lookupDefault [] uri published - !published' = HMap.insert uri newDiags published - action = when (lastPublish /= newDiags) $ case lspEnv of + join $ mask_ $ do + lastPublish <- atomically $ 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 Just env -> LSP.runLspT env $ LSP.sendNotification LSP.STextDocumentPublishDiagnostics $ LSP.PublishDiagnosticsParams (fromNormalizedUri uri) ver (List newDiags) - return (published', action) + return action newtype Priority = Priority Double @@ -1192,10 +1187,21 @@ actionLogger = do ShakeExtras{logger} <- getShakeExtras return logger +-------------------------------------------------------------------------------- +type STMDiagnosticStore = STM.Map NormalizedUri StoreItem getDiagnosticsFromStore :: StoreItem -> [Diagnostic] getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags +updateSTMDiagnostics :: STMDiagnosticStore + -> NormalizedUri -> TextDocumentVersion -> DiagnosticsBySource + -> STM [LSP.Diagnostic] +updateSTMDiagnostics store uri mv newDiagsBySource = + getDiagnosticsFromStore . fromJust <$> STM.focus (Focus.alter update *> Focus.lookup) uri store + where + update (Just(StoreItem mvs dbs)) + | mvs == mv = Just (StoreItem mv (newDiagsBySource <> dbs)) + update _ = Just (StoreItem mv newDiagsBySource) -- | Sets the diagnostics for a file and compilation step -- if you want to clear the diagnostics call this with an empty list @@ -1204,25 +1210,17 @@ setStageDiagnostics -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited -> T.Text -> [LSP.Diagnostic] - -> DiagnosticStore - -> DiagnosticStore -setStageDiagnostics uri ver stage diags ds = updateDiagnostics ds uri ver updatedDiags + -> STMDiagnosticStore + -> STM [LSP.Diagnostic] +setStageDiagnostics uri ver stage diags ds = updateSTMDiagnostics ds uri ver updatedDiags where updatedDiags = Map.singleton (Just stage) (SL.toSortedList diags) getAllDiagnostics :: - DiagnosticStore -> - [FileDiagnostic] + STMDiagnosticStore -> + STM [FileDiagnostic] getAllDiagnostics = - concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList - -getUriDiagnostics :: - NormalizedUri -> - DiagnosticStore -> - [LSP.Diagnostic] -getUriDiagnostics uri ds = - maybe [] getDiagnosticsFromStore $ - HMap.lookup uri ds + fmap (concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO () updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 30c7b500f9..70d2d6da98 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -21,6 +21,7 @@ module Development.IDE.Plugin.CodeAction import Control.Applicative ((<|>)) import Control.Arrow (second, (>>>)) +import Control.Concurrent.STM.Stats (atomically) import Control.Monad (guard, join) import Control.Monad.IO.Class import Data.Char @@ -90,7 +91,7 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod liftIO $ do let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents mbFile = toNormalizedFilePath' <$> uriToFilePath uri - diag <- fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state + diag <- atomically $ fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state (join -> parsedModule) <- runAction "GhcideCodeActions.getParsedModule" state $ getParsedModule `traverse` mbFile let actions = caRemoveRedundantImports parsedModule text diag xs uri diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 65d6429992..b29be7ab03 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -12,6 +12,7 @@ module Development.IDE.Plugin.TypeLenses ( GlobalBindingTypeSigsResult (..), ) where +import Control.Concurrent.STM.Stats (atomically) import Control.DeepSeq (rwhnf) import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) @@ -100,8 +101,8 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif bindings <- runAction "codeLens.GetBindings" ideState (use GetBindings filePath) gblSigs <- runAction "codeLens.GetGlobalBindingTypeSigs" ideState (use GetGlobalBindingTypeSigs filePath) - diag <- getDiagnostics ideState - hDiag <- getHiddenDiagnostics ideState + diag <- atomically $ getDiagnostics ideState + hDiag <- atomically $ getHiddenDiagnostics ideState let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing generateLensForGlobal sig@GlobalBindingTypeSig{..} = do diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 10690b00d0..e15c6f3fbd 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -368,6 +368,7 @@ executable haskell-language-server , safe-exceptions , hls-graph , sqlite-simple + , stm , temporary , transformers , unordered-containers diff --git a/plugins/default/src/Ide/Plugin/Example.hs b/plugins/default/src/Ide/Plugin/Example.hs index 96525efdcb..89bef3441e 100644 --- a/plugins/default/src/Ide/Plugin/Example.hs +++ b/plugins/default/src/Ide/Plugin/Example.hs @@ -14,6 +14,7 @@ module Ide.Plugin.Example descriptor ) where +import Control.Concurrent.STM import Control.DeepSeq (NFData) import Control.Monad.IO.Class import Control.Monad.Trans.Maybe @@ -126,8 +127,8 @@ codeLens ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} case uriToFilePath' uri of Just (toNormalizedFilePath -> filePath) -> do _ <- runIdeAction "Example.codeLens" (shakeExtras ideState) $ runMaybeT $ useE TypeCheck filePath - _diag <- getDiagnostics ideState - _hDiag <- getHiddenDiagnostics ideState + _diag <- atomically $ getDiagnostics ideState + _hDiag <- atomically $ getHiddenDiagnostics ideState let title = "Add TODO Item via Code Lens" -- tedit = [TextEdit (Range (Position 3 0) (Position 3 0)) diff --git a/plugins/default/src/Ide/Plugin/Example2.hs b/plugins/default/src/Ide/Plugin/Example2.hs index 005da4edcd..4b95e4242b 100644 --- a/plugins/default/src/Ide/Plugin/Example2.hs +++ b/plugins/default/src/Ide/Plugin/Example2.hs @@ -14,6 +14,7 @@ module Ide.Plugin.Example2 descriptor ) where +import Control.Concurrent.STM import Control.DeepSeq (NFData) import Control.Monad.IO.Class import Control.Monad.Trans.Maybe @@ -116,8 +117,8 @@ codeLens ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} case uriToFilePath' uri of Just (toNormalizedFilePath -> filePath) -> do _ <- runIdeAction (fromNormalizedFilePath filePath) (shakeExtras ideState) $ runMaybeT $ useE TypeCheck filePath - _diag <- getDiagnostics ideState - _hDiag <- getHiddenDiagnostics ideState + _diag <- atomically $ getDiagnostics ideState + _hDiag <- atomically $ getHiddenDiagnostics ideState let title = "Add TODO2 Item via Code Lens" range = Range (Position 3 0) (Position 4 0) diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index f3969e45db..23ff2f8a8a 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -63,6 +63,7 @@ library , lens , lsp , regex-tdfa + , stm , temporary , text , transformers diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index e6784ec502..9f4dd42820 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -26,6 +26,7 @@ module Ide.Plugin.Hlint --, provider ) where import Control.Arrow ((&&&)) +import Control.Concurrent.STM import Control.DeepSeq import Control.Exception import Control.Lens ((^.)) @@ -308,7 +309,7 @@ codeActionProvider ideState plId (CodeActionParams _ _ docId _ context) = Right where getCodeActions = do - allDiags <- getDiagnostics ideState + allDiags <- atomically $ getDiagnostics ideState let docNfp = toNormalizedFilePath' <$> uriToFilePath' (docId ^. LSP.uri) numHintsInDoc = length [d | (nfp, _, d) <- allDiags diff --git a/test/utils/Test/Hls/Command.hs b/test/utils/Test/Hls/Command.hs index 799174b32b..90b1f62b7d 100644 --- a/test/utils/Test/Hls/Command.hs +++ b/test/utils/Test/Hls/Command.hs @@ -23,7 +23,7 @@ hlsCommand :: String {-# NOINLINE hlsCommand #-} hlsCommand = unsafePerformIO $ do testExe <- fromMaybe "haskell-language-server" <$> lookupEnv "HLS_TEST_EXE" - pure $ testExe ++ " --lsp -d -j4 -l test-logs/" ++ logFilePath + pure $ testExe ++ " --lsp -d -j4" hlsCommandVomit :: String hlsCommandVomit = hlsCommand ++ " --vomit"