Add codeactions for cabal field names (#3273)

Add code action for incorrect field names in cabal files

The codeactions will suggest possible corrections for unknown field names in a cabal file.
---------

Co-authored-by: Fendor <fendor@posteo.de>
Co-authored-by: Jana Chadt <jana.chadt@nets.at>

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

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

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

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

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"
 

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:
+

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:
+