Lockless diagnostics

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') $

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

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

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,15 +87,15 @@ 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)
 
 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 ()

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

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

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

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

haskell-language-server.cabal

@@ -368,6 +368,7 @@ executable haskell-language-server
     , safe-exceptions
     , hls-graph
     , sqlite-simple
+    , stm
     , temporary
     , transformers
     , unordered-containers

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))

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)

plugins/hls-hlint-plugin/hls-hlint-plugin.cabal

@@ -63,6 +63,7 @@ library
     , lens
     , lsp
     , regex-tdfa
+    , stm
     , temporary
     , text
     , transformers

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