diff --git a/hls-class-plugin.cabal b/hls-class-plugin.cabal --- a/hls-class-plugin.cabal +++ b/hls-class-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-class-plugin -version: 1.1.1.1 +version: 2.0.0.0 synopsis: Class/instance management plugin for Haskell Language Server @@ -39,10 +39,10 @@ , deepseq , extra , ghc - , ghcide ^>=1.9 || ^>= 1.10 + , ghcide == 2.0.0.0 , ghc-boot-th , hls-graph - , hls-plugin-api ^>=1.6 + , hls-plugin-api == 2.0.0.0 , lens , lsp , text @@ -74,7 +74,7 @@ , ghcide , hls-class-plugin , hls-plugin-api - , hls-test-utils ^>=1.5 + , hls-test-utils == 2.0.0.0 , lens , lsp-types , text diff --git a/src/Ide/Plugin/Class/CodeLens.hs b/src/Ide/Plugin/Class/CodeLens.hs --- a/src/Ide/Plugin/Class/CodeLens.hs +++ b/src/Ide/Plugin/Class/CodeLens.hs @@ -1,17 +1,17 @@ {-# 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 @@ -19,24 +19,28 @@ 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 @@ 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 @@ -- 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 @@ 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 diff --git a/src/Ide/Plugin/Class/Utils.hs b/src/Ide/Plugin/Class/Utils.hs --- a/src/Ide/Plugin/Class/Utils.hs +++ b/src/Ide/Plugin/Class/Utils.hs @@ -46,6 +46,10 @@ | 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 @@ (_, 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] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -27,7 +27,9 @@ tests :: TestTree tests = testGroup "class" - [codeActionTests, codeLensTests] + [ codeActionTests + , codeLensTests + ] codeActionTests :: TestTree codeActionTests = testGroup @@ -101,6 +103,14 @@ 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 diff --git a/test/testdata/Stale.hs b/test/testdata/Stale.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Stale.hs @@ -0,0 +1,5 @@ +module Stale where + +data A a +instance Functor A where + fmap = _