Store FileDiagnostic instead of LSP Diagnostic in Shake store

Author: dylan-thinnes

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

@@ -159,7 +159,6 @@ import qualified Ide.PluginUtils                        as HLS
 import           Ide.Types                              (IdePlugins (IdePlugins),
                                                          PluginDescriptor (pluginId),
                                                          PluginId)
-import           Language.LSP.Diagnostics
 import qualified Language.LSP.Protocol.Lens             as L
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
@@ -290,7 +289,7 @@ data ShakeExtras = ShakeExtras
     ,state :: Values
     ,diagnostics :: STMDiagnosticStore
     ,hiddenDiagnostics :: STMDiagnosticStore
-    ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic]
+    ,publishedDiagnostics :: STM.Map NormalizedUri [FileDiagnostic]
     -- ^ This represents the set of diagnostics that we have published.
     -- Due to debouncing not every change might get published.
 
@@ -1349,14 +1348,14 @@ updateFileDiagnostics :: MonadIO m
   -> ShakeExtras
   -> [FileDiagnostic] -- ^ current results
   -> m ()
-updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 =
+updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 = do
   liftIO $ withTrace ("update diagnostics " <> fromString(fromNormalizedFilePath fp)) $ \ addTag -> do
     addTag "key" (show k)
     let (currentShown, currentHidden) = partition ((== ShowDiag) . fdShouldShowDiagnostic) current
         uri = filePathToUri' fp
         addTagUnsafe :: String -> String -> String -> a -> a
         addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v
-        update :: (forall a. String -> String -> a -> a) -> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic]
+        update :: (forall a. String -> String -> a -> a) -> [FileDiagnostic] -> STMDiagnosticStore -> STM [FileDiagnostic]
         update addTagUnsafeMethod new store = addTagUnsafeMethod "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafeMethod uri ver (renderKey k) new store
         current = map (modifyFdLspDiagnostic diagsFromRule) current0
     addTag "version" (show ver)
@@ -1365,21 +1364,21 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti
         -- published. Otherwise, we might never publish certain diagnostics if
         -- an exception strikes between modifyVar but before
         -- publishDiagnosticsNotification.
-        newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") (map fdLspDiagnostic currentShown) diagnostics
-        _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") (map fdLspDiagnostic currentHidden) hiddenDiagnostics
+        newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") currentShown diagnostics
+        _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") currentHidden hiddenDiagnostics
         let uri' = filePathToUri' fp
         let delay = if null newDiags then 0.1 else 0
         registerEvent debouncer delay uri' $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do
              join $ mask_ $ do
                  lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics
                  let action = when (lastPublish /= newDiags) $ case lspEnv of
                         Nothing -> -- Print an LSP event.
-                            logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (\lspDiag -> ideErrorFromLspDiag lspDiag fp Nothing) newDiags) -- TODO: Should try to get structured diagnostics plumbed here if possible
+                            logWith recorder Info $ LogDiagsDiffButNoLspEnv newDiags
                         Just env -> LSP.runLspT env $ do
                             liftIO $ tag "count" (show $ Prelude.length newDiags)
                             liftIO $ tag "key" (show k)
                             LSP.sendNotification SMethod_TextDocumentPublishDiagnostics $
-                                LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) newDiags
+                                LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) (map fdLspDiagnostic newDiags)
                  return action
     where
         diagsFromRule :: Diagnostic -> Diagnostic
@@ -1403,26 +1402,28 @@ actionLogger :: Action (Recorder (WithPriority Log))
 actionLogger = shakeRecorder <$> getShakeExtras
 
 --------------------------------------------------------------------------------
-type STMDiagnosticStore = STM.Map NormalizedUri StoreItem
+type STMDiagnosticStore = STM.Map NormalizedUri StoreItem'
+data StoreItem' = StoreItem' (Maybe Int32) FileDiagnosticsBySource
+type FileDiagnosticsBySource = Map.Map (Maybe T.Text) (SL.SortedList FileDiagnostic)
 
-getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
-getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
+getDiagnosticsFromStore :: StoreItem' -> [FileDiagnostic]
+getDiagnosticsFromStore (StoreItem' _ diags) = concatMap SL.fromSortedList $ Map.elems diags
 
 updateSTMDiagnostics ::
   (forall a. String -> String -> a -> a) ->
   STMDiagnosticStore ->
   NormalizedUri ->
   Maybe Int32 ->
-  DiagnosticsBySource ->
-  STM [LSP.Diagnostic]
+  FileDiagnosticsBySource ->
+  STM [FileDiagnostic]
 updateSTMDiagnostics addTag store uri mv newDiagsBySource =
     getDiagnosticsFromStore . fromJust <$> STM.focus (Focus.alter update *> Focus.lookup) uri store
   where
-    update (Just(StoreItem mvs dbs))
+    update (Just(StoreItem' mvs dbs))
       | addTag "previous version" (show mvs) $
         addTag "previous count" (show $ Prelude.length $ filter (not.null) $ Map.elems dbs) False = undefined
-      | mvs == mv = Just (StoreItem mv (newDiagsBySource <> dbs))
-    update _ = Just (StoreItem mv newDiagsBySource)
+      | 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
@@ -1431,9 +1432,9 @@ setStageDiagnostics
     -> NormalizedUri
     -> Maybe Int32 -- ^ the time that the file these diagnostics originate from was last edited
     -> T.Text
-    -> [LSP.Diagnostic]
+    -> [FileDiagnostic]
     -> STMDiagnosticStore
-    -> STM [LSP.Diagnostic]
+    -> STM [FileDiagnostic]
 setStageDiagnostics addTag uri ver stage diags ds = updateSTMDiagnostics addTag ds uri ver updatedDiags
   where
     !updatedDiags = Map.singleton (Just stage) $! SL.toSortedList diags
@@ -1442,7 +1443,7 @@ getAllDiagnostics ::
     STMDiagnosticStore ->
     STM [FileDiagnostic]
 getAllDiagnostics =
-    fmap (concatMap (\(k,v) -> map (\diag -> ideErrorFromLspDiag diag (fromUri k) Nothing) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT -- TODO: Do we need the structured message here?
+    fmap (concatMap (\(_,v) -> getDiagnosticsFromStore v)) . ListT.toList . STM.listT
 
 updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> STM ()
 updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes =