Keep instance lenses stable even if parsed results are unavailable

ghcide/src/Development/IDE/GHC/Compat/Core.hs

@@ -496,6 +496,7 @@ module Development.IDE.GHC.Compat.Core (
 # if !MIN_VERSION_ghc(9,5,0)
     field_label,
 #endif
+    groupOrigin,
     ) where
 
 import qualified GHC
@@ -1197,9 +1198,11 @@ type UniqFM k = UniqFM.UniqFM
 mkVisFunTys = mkScaledFunctionTys
 mapLoc :: (a -> b) -> SrcLoc.GenLocated l a -> SrcLoc.GenLocated l b
 mapLoc = fmap
+groupOrigin = mg_ext
 #else
 mapLoc :: (a -> b) -> SrcLoc.GenLocated l a -> SrcLoc.GenLocated l b
 mapLoc = SrcLoc.mapLoc
+groupOrigin = mg_origin
 #endif
 
 

plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs

@@ -1,42 +1,46 @@
 {-# LANGUAGE GADTs           #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE CPP             #-}
 {-# OPTIONS_GHC -Wno-overlapping-patterns #-}
 
 module Ide.Plugin.Class.CodeLens where
 
-import           Control.Lens                    ((^.))
-import           Control.Monad.IO.Class          (liftIO)
+import           Control.Lens                         ((^.))
+import           Control.Monad.IO.Class               (liftIO)
 import           Data.Aeson
-import           Data.Maybe                      (mapMaybe, maybeToList)
-import qualified Data.Text                       as T
+import           Data.Maybe                           (mapMaybe, maybeToList)
+import qualified Data.Text                            as T
 import           Development.IDE
+import           Development.IDE.Core.PositionMapping
 import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.Compat.Util
 import           GHC.LanguageExtensions.Type
 import           Ide.Plugin.Class.Types
 import           Ide.Plugin.Class.Utils
 import           Ide.PluginUtils
 import           Ide.Types
-import           Language.LSP.Server             (sendRequest)
+import           Language.LSP.Server                  (sendRequest)
 import           Language.LSP.Types
-import qualified Language.LSP.Types.Lens         as J
+import qualified Language.LSP.Types.Lens              as J
 
 codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens
 codeLens state plId CodeLensParams{..} = pluginResponse $ do
     nfp <- getNormalizedFilePath uri
-    tmr <- handleMaybeM "Unable to typecheck"
+    (tmr, _) <- handleMaybeM "Unable to typecheck"
         $ liftIO
         $ runAction "classplugin.TypeCheck" state
-        $ use TypeCheck nfp
+        -- Using stale results means that we can almost always return a value. In practice
+        -- this means the lenses don't 'flicker'
+        $ useWithStale TypeCheck nfp
 
     -- All instance binds
-    InstanceBindTypeSigsResult allBinds <-
+    (InstanceBindTypeSigsResult allBinds, mp) <-
         handleMaybeM "Unable to get InstanceBindTypeSigsResult"
         $ liftIO
         $ runAction "classplugin.GetInstanceBindTypeSigs" state
-        $ use GetInstanceBindTypeSigs nfp
+        -- Using stale results means that we can almost always return a value. In practice
+        -- this means the lenses don't 'flicker'
+        $ useWithStale GetInstanceBindTypeSigs nfp
 
     pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs
 
@@ -53,7 +57,7 @@ codeLens state plId CodeLensParams{..} = pluginResponse $ do
         makeLens (range, title) =
             generateLens plId range title
                 $ workspaceEdit pragmaInsertion
-                $ makeEdit range title
+                $ makeEdit range title mp
         codeLens = makeLens <$> mapMaybe getRangeWithSig targetSigs
 
     pure $ List codeLens
@@ -97,13 +101,9 @@ codeLens state plId CodeLensParams{..} = pluginResponse $ do
                         -- that are nonsense for displaying code lenses.
                         --
                         -- See https://github.com/haskell/haskell-language-server/issues/3319
-#if MIN_VERSION_ghc(9,5,0)
-                          | not $ isGenerated (mg_ext fun_matches)
-#else
-                          | not $ isGenerated (mg_origin fun_matches)
-#endif
-                                -> Just $ L l fun_id
-                    _           -> Nothing
+                        | not $ isGenerated (groupOrigin fun_matches)
+                            -> Just $ L l fun_id
+                    _       -> Nothing
                 -- Existed signatures' name
                 sigNames = concat $ mapMaybe (\(L _ r) -> getSigName r) cid_sigs
                 toBindInfo (L l (L l' _)) = BindInfo
@@ -130,12 +130,14 @@ codeLens state plId CodeLensParams{..} = pluginResponse $ do
             let cmd = mkLspCommand plId typeLensCommandId title (Just [toJSON edit])
             in  CodeLens range (Just cmd) Nothing
 
-        makeEdit :: Range -> T.Text -> [TextEdit]
-        makeEdit range bind =
+        makeEdit :: Range -> T.Text -> PositionMapping -> [TextEdit]
+        makeEdit range bind mp =
             let startPos = range ^. J.start
                 insertChar = startPos ^. J.character
                 insertRange = Range startPos startPos
-            in [TextEdit insertRange (bind <> "\n" <> T.replicate (fromIntegral insertChar) " ")]
+            in case toCurrentRange mp insertRange of
+                Just rg -> [TextEdit rg (bind <> "\n" <> T.replicate (fromIntegral insertChar) " ")]
+                Nothing -> []
 
 codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit
 codeLensCommandHandler _ wedit = do

plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs

@@ -46,6 +46,10 @@ toMethodName n
     | otherwise
     = n
 
+-- | Here we use `useWithStale` to compute, Using stale results means that we can almost always return a value.
+--   In practice this means the lenses don't 'flicker'.
+--   This function is also used in code actions, but it doesn't matter because our actions only work
+--   if the module parsed success.
 insertPragmaIfNotPresent :: (MonadIO m)
     => IdeState
     -> NormalizedFilePath
@@ -59,10 +63,10 @@ insertPragmaIfNotPresent state nfp pragma = do
     (_, fileContents) <- liftIO
         $ runAction "classplugin.insertPragmaIfNotPresent.GetFileContents" state
         $ getFileContents nfp
-    pm <- handleMaybeM "Unable to GetParsedModuleWithComments"
+    (pm, _) <- handleMaybeM "Unable to GetParsedModuleWithComments"
         $ liftIO
         $ runAction "classplugin.insertPragmaIfNotPresent.GetParsedModuleWithComments" state
-        $ use GetParsedModuleWithComments nfp
+        $ useWithStale GetParsedModuleWithComments nfp
     let exts = getExtensions pm
         info = getNextPragmaInfo sessionDynFlags fileContents
     pure [insertNewPragma info pragma | pragma `notElem` exts]

plugins/hls-class-plugin/test/Main.hs

@@ -27,7 +27,9 @@ classPlugin = mkPluginTestDescriptor Class.descriptor "class"
 tests :: TestTree
 tests = testGroup
   "class"
-  [codeActionTests, codeLensTests]
+  [ codeActionTests
+  , codeLensTests
+  ]
 
 codeActionTests :: TestTree
 codeActionTests = testGroup
@@ -101,6 +103,14 @@ codeLensTests = testGroup
         goldenCodeLens "Don't insert pragma while GHC2021 enabled" "CodeLensWithGHC2021" 0
     , goldenCodeLens "Qualified name" "Qualified" 0
     , goldenCodeLens "Type family" "TypeFamily" 0
+    , testCase "keep stale lens" $ do
+        runSessionWithServer classPlugin testDataDir $ do
+            doc <- openDoc "Stale.hs" "haskell"
+            oldLens <- getCodeLenses doc
+            let edit = TextEdit (mkRange 4 11 4 12) "" -- Remove the `_`
+            _ <- applyEdit doc edit
+            newLens <- getCodeLenses doc
+            liftIO $ newLens @?= oldLens
     ]
 
 _CACodeAction :: Prism' (Command |? CodeAction) CodeAction

plugins/hls-class-plugin/test/testdata/Stale.hs

@@ -0,0 +1,5 @@
+module Stale where
+
+data A a
+instance Functor A where
+    fmap = _