diff --git a/ChangeLog.md b/ChangeLog.md index 160d68fc4c..ca8f35171a 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -17,6 +17,7 @@ - Improved limited cross-module renaming - Improvements to `hls-refactor-plugin` - Code action to delete all unused bindings, including `let` bindings + - Code action to remove a redundant `qualified` from an import - Improvements to `hls-eval-plugin` - Capture `stdout` and `stderr` from evaluated expressions - Improvements to `hls-splice-plugin` diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 716af176be..ed7d0dacf5 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -177,6 +177,7 @@ iePluginDescriptor recorder plId = let old = mkGhcideCAsPlugin [ wrap suggestModuleTypo + , wrap suggestRemoveDuplicateQualified , wrap suggestFixConstructorImport , wrap suggestExtendImport , wrap suggestImportDisambiguation @@ -987,6 +988,67 @@ suggestModuleTypo Diagnostic{_range=_range,..} [modul, "(from", _] -> Just modul _ -> Nothing +suggestRemoveDuplicateQualified :: Maybe DynFlags -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] +suggestRemoveDuplicateQualified mbDf contents' Diagnostic{_range=_range, _message} + | "Multiple occurrences of 'qualified'" `T.isInfixOf` _message + , Just contents <- contents' + , Just edit <- redundantQualifiedEdit contents + = [("Remove redundant 'qualified'", [edit])] + | otherwise = [] + where + usePost = case mbDf of + Just df -> xopt Lang.ImportQualifiedPost df + -- The module could not be parsed and no DynFlags were available, so + -- fall back to the LANGUAGE/OPTIONS_GHC pragmas in the file itself. + Nothing -> maybe False importQualifiedPostFromPragmas contents' + redundantQualifiedEdit contents = do + let Position startLine _ = _start _range + line <- listToMaybe $ drop (fromIntegral startLine) $ T.lines contents + (preQual, postQual) <- case qualifiedOccurrences line of + a : b : _ -> Just (a, b) + _ -> Nothing + let (colStart, colEnd) + | usePost = preQual + | otherwise = postQual + baseRange = Range (Position startLine (fromIntegral colStart)) (Position startLine (fromIntegral colEnd)) + trailing = T.takeWhile isSpace (T.drop colEnd line) + leading = T.takeWhileEnd isSpace (T.take colStart line) + editRange + | usePost = baseRange { _end = Position startLine (fromIntegral (colEnd + T.length trailing)) } + | otherwise = baseRange { _start = Position startLine (fromIntegral (colStart - T.length leading)) } + pure $ TextEdit editRange "" +importQualifiedPostFromPragmas :: T.Text -> Bool +importQualifiedPostFromPragmas contents = + case enabledStates of + [] -> False + states -> last states + where + enabledStates = + [ token /= "NoImportQualifiedPost" + | line <- T.lines contents + , "{-# LANGUAGE" `T.isInfixOf` line || "{-# OPTIONS_GHC" `T.isInfixOf` line + , token <- map T.unpack $ extensionsIn line + , token == "ImportQualifiedPost" || token == "NoImportQualifiedPost" + ] + extensionsIn = + T.split (\c -> not (isAlphaNum c || c == '_' || c == '-')) . T.replace "-X" "" + +qualifiedOccurrences :: T.Text -> [(Int, Int)] +qualifiedOccurrences = go 0 + where + kw = "qualified" + kwLen = T.length kw + go off t = case T.breakOn kw t of + (_, rest) | T.null rest -> [] + (pre, rest) -> + let start = off + T.length pre + after = T.drop kwLen rest + boundedBefore = T.null pre || not (isIdentChar (T.last pre)) + boundedAfter = T.null after || not (isIdentChar (T.head after)) + found = if boundedBefore && boundedAfter then ((start, start + kwLen) :) else id + in found (go (start + kwLen) after) + isIdentChar c = isAlphaNum c || c == '_' + suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, CodeActionKind, CodeActionPreferred, Rewrite)] suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..} | Just [binding, mod, srcspan] <- diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs index 4bff75ecff..3cff3b0946 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -68,12 +68,21 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _ra _ -> pure mempty caaIdeOptions <- onceIO $ runAction "GhcideCodeActions.getIdeOptions" state getIdeOptions caaParsedModule <- onceIO $ runRule GetParsedModuleWithComments + caaModSummary <- onceIO $ runRule GetModSummary caaContents <- onceIO $ runRule GetFileContents <&> \case Just (_, mbContents) -> fmap Rope.toText mbContents Nothing -> Nothing - caaDf <- onceIO $ fmap (ms_hspp_opts . pm_mod_summary) <$> caaParsedModule + caaDf <- onceIO $ do + mbParsedModule <- caaParsedModule + case mbParsedModule of + Just pm -> pure $ Just (ms_hspp_opts (pm_mod_summary pm)) + -- The module may fail to parse (e.g. malformed imports). In + -- that case use the flags from the module summary, which are + -- computed without parsing the module. + Nothing -> + fmap (ms_hspp_opts . msrModSummary) <$> caaModSummary caaAnnSource <- onceIO $ runRule GetAnnotatedParsedSource caaTmr <- onceIO $ runRule TypeCheck caaHar <- onceIO $ runRule GetHieAst @@ -143,6 +152,7 @@ data CodeActionArgs = CodeActionArgs caaGhcSession :: IO (Maybe HscEnvEq), caaIdeOptions :: IO IdeOptions, caaParsedModule :: IO (Maybe ParsedModule), + caaModSummary :: IO (Maybe ModSummaryResult), caaContents :: IO (Maybe T.Text), caaDf :: IO (Maybe DynFlags), caaAnnSource :: IO (Maybe ParsedSource), diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index fa104a634c..3c746e89e8 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -308,6 +308,7 @@ codeActionTests = testGroup "code actions" , suggestHideShadowTests , fixConstructorImportTests , fixModuleImportTypoTests + , removeDuplicateQualifiedTests , importRenameActionTests , fillTypedHoleTests , addSigActionTests @@ -1701,6 +1702,40 @@ fixModuleImportTypoTests = testGroup "fix module import typo" liftIO $ contentAfterAction @?= "import Data.Eq" ] +removeDuplicateQualifiedTests :: TestTree +removeDuplicateQualifiedTests = testGroup "multiple occurrences of qualified in import" + [ testSession "removes prepositive qualified when ImportQualifiedPost is enabled" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# LANGUAGE ImportQualifiedPost #-}" + , "module A where" + , "import qualified Data.List qualified" + ] + _ <- waitForDiagnostics + action <- pickActionWithTitle "Remove redundant 'qualified'" =<< getCodeActions doc (R 2 0 2 36) + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ contentAfterAction @?= T.unlines + [ "{-# LANGUAGE ImportQualifiedPost #-}" + , "module A where" + , "import Data.List qualified" + ] + , testSession "removes postpositive qualified without ImportQualifiedPost" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# LANGUAGE NoImportQualifiedPost #-}" + , "module A where" + , "import qualified Data.List qualified" + ] + _ <- waitForDiagnostics + action <- pickActionWithTitle "Remove redundant 'qualified'" =<< getCodeActions doc (R 2 0 2 36) + executeCodeAction action + contentAfterAction <- documentContents doc + liftIO $ contentAfterAction @?= T.unlines + [ "{-# LANGUAGE NoImportQualifiedPost #-}" + , "module A where" + , "import qualified Data.List" + ] + ] + suggestImportClassMethodTests :: TestTree suggestImportClassMethodTests = testGroup