lock-less diagnostics

Author: pepeiborra

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

@@ -191,8 +191,8 @@ data ShakeExtras = ShakeExtras
     ,logger :: Logger
     ,globals :: Var (HMap.HashMap TypeRep Dynamic)
     ,state :: Values
-    ,diagnostics :: Var DiagnosticStore
-    ,hiddenDiagnostics :: Var DiagnosticStore
+    ,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.
@@ -509,8 +509,8 @@ shakeOpen lspEnv defaultConfig logger debouncer
     shakeExtras <- do
         globals <- newVar HMap.empty
         state <- STM.newIO
-        diagnostics <- newVar mempty
-        hiddenDiagnostics <- newVar mempty
+        diagnostics <- STM.newIO
+        hiddenDiagnostics <- STM.newIO
         publishedDiagnostics <- STM.newIO
         positionMapping <- newVar HMap.empty
         knownTargetsVar <- newVar $ hashed HMap.empty
@@ -758,13 +758,11 @@ instantiateDelayedAction (DelayedAction _ s p a) = do
 
 getDiagnostics :: IdeState -> IO [FileDiagnostic]
 getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
-    val <- readVar diagnostics
-    return $ getAllDiagnostics val
+    atomically $ getAllDiagnostics diagnostics
 
 getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic]
 getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do
-    val <- readVar hiddenDiagnostics
-    return $ getAllDiagnostics val
+    atomically $ 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,17 +1152,14 @@ 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
@@ -1191,10 +1186,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
@@ -1203,25 +1209,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