diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 8aac08c0a..24f7c9b8b 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -242,6 +242,7 @@ library hls-cabal-plugin Ide.Plugin.Cabal.Completion.Completions Ide.Plugin.Cabal.Completion.Data Ide.Plugin.Cabal.Completion.Types + Ide.Plugin.Cabal.FieldSuggest Ide.Plugin.Cabal.LicenseSuggest Ide.Plugin.Cabal.Orphans Ide.Plugin.Cabal.Parse @@ -285,6 +286,7 @@ test-suite hls-cabal-plugin-tests , base , bytestring , Cabal-syntax >= 3.7 + , extra , filepath , ghcide , haskell-language-server:hls-cabal-plugin diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 3c471a21b..3f9eac0fd 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -19,6 +19,7 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import qualified Data.List.NonEmpty as NE import qualified Data.Maybe as Maybe +import qualified Data.Text as T import qualified Data.Text.Encoding as Encoding import Data.Typeable import Development.IDE as D @@ -26,7 +27,6 @@ import Development.IDE.Core.Shake (restartShakeSessio import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph (Key, alwaysRerun) import qualified Development.IDE.Plugin.Completions.Logic as Ghcide -import qualified Development.IDE.Plugin.Completions.Types as Ghcide import Development.IDE.Types.Shake (toKey) import qualified Distribution.Fields as Syntax import qualified Distribution.Parsec.Position as Syntax @@ -38,6 +38,7 @@ import Ide.Plugin.Cabal.Completion.Types (ParseCabalCommonSe ParseCabalFile (..)) import qualified Ide.Plugin.Cabal.Completion.Types as Types import qualified Ide.Plugin.Cabal.Diagnostics as Diagnostics +import qualified Ide.Plugin.Cabal.FieldSuggest as FieldSuggest import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest import Ide.Plugin.Cabal.Orphans () import qualified Ide.Plugin.Cabal.Parse as Parse @@ -89,6 +90,7 @@ descriptor recorder plId = mconcat [ mkPluginHandler LSP.SMethod_TextDocumentCodeAction licenseSuggestCodeAction , mkPluginHandler LSP.SMethod_TextDocumentCompletion $ completion recorder + , mkPluginHandler LSP.SMethod_TextDocumentCodeAction $ fieldSuggestCodeAction recorder ] , pluginNotificationHandlers = mconcat @@ -238,6 +240,41 @@ licenseSuggestCodeAction ideState _ (CodeActionParams _ _ (TextDocumentIdentifie maxCompls <- fmap maxCompletions . liftIO $ runAction "cabal-plugin.suggestLicense" ideState getClientConfigAction pure $ InL $ diags >>= (fmap InR . LicenseSuggest.licenseErrorAction maxCompls uri) +-- | CodeActions for correcting field names with typos in them. +-- +-- Provides CodeActions that fix typos in both stanzas and top-level field names. +-- The suggestions are computed based on the completion context, where we "move" a fake cursor +-- to the end of the field name and trigger cabal file completions. The completions are then +-- suggested to the user. +-- +-- TODO: Relying on completions here often does not produce the desired results, we should +-- use some sort of fuzzy matching in the future, see issue #4357. +fieldSuggestCodeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction +fieldSuggestCodeAction recorder ide _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext{_diagnostics=diags}) = do + vfileM <- lift (pluginGetVirtualFile $ toNormalizedUri uri) + case (,) <$> vfileM <*> uriToFilePath' uri of + Nothing -> pure $ InL [] + Just (vfile, path) -> do + -- We decide on `useWithStale` here, since `useWithStaleFast` often leads to the wrong completions being suggested. + -- In case it fails, we still will get some completion results instead of an error. + mFields <- liftIO $ runAction "cabal-plugin.fields" ide $ useWithStale ParseCabalFields $ toNormalizedFilePath path + case mFields of + Nothing -> + pure $ InL [] + Just (cabalFields, _) -> do + let fields = Maybe.mapMaybe FieldSuggest.fieldErrorName diags + results <- forM fields (getSuggestion vfile path cabalFields) + pure $ InL $ map InR $ concat results + where + getSuggestion vfile fp cabalFields (fieldName,Diagnostic{ _range=_range@(Range (Position lineNr col) _) }) = do + let -- Compute where we would anticipate the cursor to be. + fakeLspCursorPosition = Position lineNr (col + fromIntegral (T.length fieldName)) + lspPrefixInfo = Ghcide.getCompletionPrefix fakeLspCursorPosition vfile + cabalPrefixInfo = Completions.getCabalPrefixInfo fp lspPrefixInfo + completions <- liftIO $ computeCompletionsAt recorder ide cabalPrefixInfo fp cabalFields + let completionTexts = fmap (^. JL.label) completions + pure $ FieldSuggest.fieldErrorAction uri fieldName completionTexts _range + -- ---------------------------------------------------------------- -- Cabal file of Interest rules and global variable -- ---------------------------------------------------------------- @@ -319,7 +356,7 @@ deleteFileOfInterest recorder state f = do completion :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion completion recorder ide _ complParams = do - let (TextDocumentIdentifier uri) = complParams ^. JL.textDocument + let TextDocumentIdentifier uri = complParams ^. JL.textDocument position = complParams ^. JL.position mVf <- lift $ pluginGetVirtualFile $ toNormalizedUri uri case (,) <$> mVf <*> uriToFilePath' uri of @@ -331,39 +368,36 @@ completion recorder ide _ complParams = do Nothing -> pure . InR $ InR Null Just (fields, _) -> do - let pref = Ghcide.getCompletionPrefix position cnts - let res = produceCompletions pref path fields + let lspPrefInfo = Ghcide.getCompletionPrefix position cnts + cabalPrefInfo = Completions.getCabalPrefixInfo path lspPrefInfo + let res = computeCompletionsAt recorder ide cabalPrefInfo path fields liftIO $ fmap InL res Nothing -> pure . InR $ InR Null - where - completerRecorder = cmapWithPrio LogCompletions recorder - produceCompletions :: Ghcide.PosPrefixInfo -> FilePath -> [Syntax.Field Syntax.Position] -> IO [CompletionItem] - produceCompletions prefix fp fields = do - runMaybeT (context fields) >>= \case - Nothing -> pure [] - Just ctx -> do - logWith recorder Debug $ LogCompletionContext ctx pos - let completer = Completions.contextToCompleter ctx - let completerData = CompleterTypes.CompleterData - { getLatestGPD = do - -- We decide on useWithStaleFast here, since we mostly care about the file's meta information, - -- thus, a quick response gives us the desired result most of the time. - -- The `withStale` option is very important here, since we often call this rule with invalid cabal files. - mGPD <- runIdeAction "cabal-plugin.modulesCompleter.gpd" (shakeExtras ide) $ useWithStaleFast ParseCabalFile $ toNormalizedFilePath fp - pure $ fmap fst mGPD - , getCabalCommonSections = do - mSections <- runIdeAction "cabal-plugin.modulesCompleter.commonsections" (shakeExtras ide) $ useWithStaleFast ParseCabalCommonSections $ toNormalizedFilePath fp - pure $ fmap fst mSections - , cabalPrefixInfo = prefInfo - , stanzaName = - case fst ctx of - Types.Stanza _ name -> name - _ -> Nothing - } - completions <- completer completerRecorder completerData - pure completions - where - pos = Ghcide.cursorPos prefix +computeCompletionsAt :: Recorder (WithPriority Log) -> IdeState -> Types.CabalPrefixInfo -> FilePath -> [Syntax.Field Syntax.Position] -> IO [CompletionItem] +computeCompletionsAt recorder ide prefInfo fp fields = do + runMaybeT (context fields) >>= \case + Nothing -> pure [] + Just ctx -> do + logWith recorder Debug $ LogCompletionContext ctx pos + let completer = Completions.contextToCompleter ctx + let completerData = CompleterTypes.CompleterData + { getLatestGPD = do + -- We decide on useWithStaleFast here, since we mostly care about the file's meta information, + -- thus, a quick response gives us the desired result most of the time. + -- The `withStale` option is very important here, since we often call this rule with invalid cabal files. + mGPD <- runAction "cabal-plugin.modulesCompleter.gpd" ide $ useWithStale ParseCabalFile $ toNormalizedFilePath fp + pure $ fmap fst mGPD + , getCabalCommonSections = runAction "cabal-plugin.commonSections" ide $ use ParseCabalCommonSections $ toNormalizedFilePath fp + , cabalPrefixInfo = prefInfo + , stanzaName = + case fst ctx of + Types.Stanza _ name -> name + _ -> Nothing + } + completions <- completer completerRecorder completerData + pure completions + where + pos = Types.completionCursorPosition prefInfo context fields = Completions.getContext completerRecorder prefInfo fields - prefInfo = Completions.getCabalPrefixInfo fp prefix + completerRecorder = cmapWithPrio LogCompletions recorder diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/FieldSuggest.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/FieldSuggest.hs new file mode 100644 index 000000000..2e77ccb19 --- /dev/null +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/FieldSuggest.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.Cabal.FieldSuggest + ( fieldErrorName, + fieldErrorAction, + -- * Re-exports + T.Text, + Diagnostic (..), + ) +where + +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Language.LSP.Protocol.Types (CodeAction (..), + CodeActionKind (..), + Diagnostic (..), Position (..), + Range (..), TextEdit (..), Uri, + WorkspaceEdit (..)) +import Text.Regex.TDFA + +-- | Generate all code actions for given file, erroneous/unknown field and suggestions +fieldErrorAction + :: Uri + -- ^ File for which the diagnostic was generated + -> T.Text + -- ^ Original (unknown) field + -> [T.Text] + -- ^ Suggestions for the given file + -> Range + -- ^ Location of diagnostic + -> [CodeAction] +fieldErrorAction uri original suggestions range = + fmap mkCodeAction suggestions + where + mkCodeAction suggestion = + let + -- Range returned by cabal here represents fragment from start of offending identifier + -- to end of line, we modify this range to be to the end of the identifier + adjustRange (Range rangeFrom@(Position lineNr col) _) = + Range rangeFrom (Position lineNr (col + fromIntegral (T.length original))) + title = "Replace with " <> suggestion' + tedit = [TextEdit (adjustRange range ) suggestion'] + edit = WorkspaceEdit (Just $ Map.singleton uri tedit) Nothing Nothing + in CodeAction title (Just CodeActionKind_QuickFix) (Just []) Nothing Nothing (Just edit) Nothing Nothing + where + -- dropping colon from the end of suggestion + suggestion' = T.dropEnd 1 suggestion + +-- | Given a diagnostic returned by 'Ide.Plugin.Cabal.Diag.errorDiagnostic', +-- if it represents an "Unknown field"-error with incorrect identifier +-- then return the incorrect identifier together with original diagnostics. +fieldErrorName :: + Diagnostic -> + -- ^ Output of 'Ide.Plugin.Cabal.Diag.errorDiagnostic' + Maybe (T.Text, Diagnostic) + -- ^ Original (incorrect) field name with the suggested replacement +fieldErrorName diag = + mSuggestion (_message diag) >>= \case + [original] -> Just (original, diag) + _ -> Nothing + where + regex :: T.Text + regex = "Unknown field: \"(.*)\"" + mSuggestion msg = getMatch <$> (msg :: T.Text) =~~ regex + getMatch :: (T.Text, T.Text, T.Text, [T.Text]) -> [T.Text] + getMatch (_, _, _, results) = results diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index 6488e71e1..734c3a3ca 100644 --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -9,9 +9,12 @@ module Main ( import Completer (completerTests) import Context (contextTests) import Control.Lens ((^.)) +import Control.Lens.Fold ((^?)) import Control.Monad (guard) import qualified Data.ByteString as BS import Data.Either (isRight) +import Data.List.Extra (nubOrdOn) +import qualified Data.Maybe as Maybe import qualified Data.Text as T import qualified Data.Text as Text import Ide.Plugin.Cabal.LicenseSuggest (licenseErrorSuggestion) @@ -30,6 +33,7 @@ main = do , pluginTests , completerTests , contextTests + , codeActionTests ] -- ------------------------------------------------------------------------ @@ -137,57 +141,83 @@ pluginTests = unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error ] - , testGroup - "Code Actions" - [ runCabalTestCaseSession "BSD-3" "" $ do - doc <- openDoc "licenseCodeAction.cabal" "cabal" - diags <- waitForDiagnosticsFromSource doc "cabal" - reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] - liftIO $ do - length diags @?= 1 - reduceDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) - reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Error - [codeAction] <- getLicenseAction "BSD-3-Clause" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0)) - executeCodeAction codeAction - contents <- documentContents doc - liftIO $ - contents - @?= Text.unlines - [ "cabal-version: 3.0" - , "name: licenseCodeAction" - , "version: 0.1.0.0" - , "license: BSD-3-Clause" - , "" - , "library" - , " build-depends: base" - , " default-language: Haskell2010" - ] - , runCabalTestCaseSession "Apache-2.0" "" $ do - doc <- openDoc "licenseCodeAction2.cabal" "cabal" - diags <- waitForDiagnosticsFromSource doc "cabal" - -- test if it supports typos in license name, here 'apahe' - reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'APAHE'"] - liftIO $ do - length diags @?= 1 - reduceDiag ^. L.range @?= Range (Position 3 25) (Position 4 0) - reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Error - [codeAction] <- getLicenseAction "Apache-2.0" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0)) - executeCodeAction codeAction - contents <- documentContents doc - liftIO $ - contents - @?= Text.unlines - [ "cabal-version: 3.0" - , "name: licenseCodeAction2" - , "version: 0.1.0.0" - , "license: Apache-2.0" - , "" - , "library" - , " build-depends: base" - , " default-language: Haskell2010" - ] - ] ] +-- ---------------------------------------------------------------------------- +-- Code Action Tests +-- ---------------------------------------------------------------------------- + +codeActionTests :: TestTree +codeActionTests = testGroup "Code Actions" + [ runCabalTestCaseSession "BSD-3" "" $ do + doc <- openDoc "licenseCodeAction.cabal" "cabal" + diags <- waitForDiagnosticsFromSource doc "cabal" + reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] + liftIO $ do + length diags @?= 1 + reduceDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) + reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Error + [codeAction] <- getLicenseAction "BSD-3-Clause" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0)) + executeCodeAction codeAction + contents <- documentContents doc + liftIO $ + contents + @?= Text.unlines + [ "cabal-version: 3.0" + , "name: licenseCodeAction" + , "version: 0.1.0.0" + , "license: BSD-3-Clause" + , "" + , "library" + , " build-depends: base" + , " default-language: Haskell2010" + ] + , runCabalTestCaseSession "Apache-2.0" "" $ do + doc <- openDoc "licenseCodeAction2.cabal" "cabal" + diags <- waitForDiagnosticsFromSource doc "cabal" + -- test if it supports typos in license name, here 'apahe' + reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'APAHE'"] + liftIO $ do + length diags @?= 1 + reduceDiag ^. L.range @?= Range (Position 3 25) (Position 4 0) + reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Error + [codeAction] <- getLicenseAction "Apache-2.0" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0)) + executeCodeAction codeAction + contents <- documentContents doc + liftIO $ + contents + @?= Text.unlines + [ "cabal-version: 3.0" + , "name: licenseCodeAction2" + , "version: 0.1.0.0" + , "license: Apache-2.0" + , "" + , "library" + , " build-depends: base" + , " default-language: Haskell2010" + ] + , runCabalGoldenSession "Code Actions - Can fix field names" "code-actions" "FieldSuggestions" $ \doc -> do + _ <- waitForDiagnosticsFrom doc + cas <- Maybe.mapMaybe (^? _R) <$> getAllCodeActions doc + -- Filter out the code actions we want to invoke. + -- We only want to invoke Code Actions with certain titles, and + -- we want to invoke them only once, not once for each cursor request. + -- 'getAllCodeActions' iterates over each cursor position and requests code actions. + let selectedCas = nubOrdOn (^. L.title) $ filter + (\ca -> (ca ^. L.title) `elem` + [ "Replace with license" + , "Replace with build-type" + , "Replace with extra-doc-files" + , "Replace with ghc-options" + , "Replace with location" + , "Replace with default-language" + , "Replace with import" + , "Replace with build-depends" + , "Replace with main-is" + , "Replace with hs-source-dirs" + ]) cas + mapM_ executeCodeAction selectedCas + pure () + ] where getLicenseAction :: T.Text -> [Command |? CodeAction] -> [CodeAction] getLicenseAction license codeActions = do diff --git a/plugins/hls-cabal-plugin/test/Utils.hs b/plugins/hls-cabal-plugin/test/Utils.hs index cd83ba623..c69b229c0 100644 --- a/plugins/hls-cabal-plugin/test/Utils.hs +++ b/plugins/hls-cabal-plugin/test/Utils.hs @@ -46,6 +46,9 @@ runCabalSession :: FilePath -> Session a -> IO a runCabalSession subdir = failIfSessionTimeout . runSessionWithServer def cabalPlugin (testDataDir subdir) +runCabalGoldenSession :: TestName -> FilePath -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree +runCabalGoldenSession title subdir fp act = goldenWithCabalDoc def cabalPlugin title testDataDir (subdir fp) "golden" "cabal" act + testDataDir :: FilePath testDataDir = "plugins" "hls-cabal-plugin" "test" "testdata" diff --git a/plugins/hls-cabal-plugin/test/testdata/code-actions/FieldSuggestions.cabal b/plugins/hls-cabal-plugin/test/testdata/code-actions/FieldSuggestions.cabal new file mode 100644 index 000000000..e32f77b61 --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/code-actions/FieldSuggestions.cabal @@ -0,0 +1,36 @@ +cabal-version: 3.0 +name: FieldSuggestions +version: 0.1.0 +licens: BSD-3-Clause + +buil-type: Simple + +extra-doc-fils: + ChangeLog + +-- Default warnings in HLS +common warnings + ghc-option: -Wall + -Wredundant-constraints + -Wunused-packages + -Wno-name-shadowing + -Wno-unticked-promoted-constructors + +source-repository head + type: git + loc: fake + +library + default-lang: Haskell2010 + -- Import isn't supported right now. + impor: warnings + build-dep: base + +executable my-exe + mains: Main.hs + +test-suite Test + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-drs: + diff --git a/plugins/hls-cabal-plugin/test/testdata/code-actions/FieldSuggestions.golden.cabal b/plugins/hls-cabal-plugin/test/testdata/code-actions/FieldSuggestions.golden.cabal new file mode 100644 index 000000000..99bf84dfd --- /dev/null +++ b/plugins/hls-cabal-plugin/test/testdata/code-actions/FieldSuggestions.golden.cabal @@ -0,0 +1,36 @@ +cabal-version: 3.0 +name: FieldSuggestions +version: 0.1.0 +license: BSD-3-Clause + +build-type: Simple + +extra-doc-files: + ChangeLog + +-- Default warnings in HLS +common warnings + ghc-options: -Wall + -Wredundant-constraints + -Wunused-packages + -Wno-name-shadowing + -Wno-unticked-promoted-constructors + +source-repository head + type: git + location: fake + +library + default-language: Haskell2010 + -- Import isn't supported right now. + import: warnings + build-depends: base + +executable my-exe + main-is: Main.hs + +test-suite Test + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: +