From d49add97dfa497092e61f01af468a0357bdaacaf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Sun, 4 Feb 2024 09:14:38 +0100 Subject: [PATCH 1/3] Add reproducer for bug in OPTIONS_GHC completions (#3908) --- plugins/hls-pragmas-plugin/test/Main.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/plugins/hls-pragmas-plugin/test/Main.hs b/plugins/hls-pragmas-plugin/test/Main.hs index e6f0b220b6..dc62c14860 100644 --- a/plugins/hls-pragmas-plugin/test/Main.hs +++ b/plugins/hls-pragmas-plugin/test/Main.hs @@ -124,7 +124,9 @@ completionTests = , completionTest "completes pragmas with existing closing comment bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #") (Just "{-# LANGUAGE #-}") (0, 4, 0, 32, 0, 4) , completionTest "completes pragmas with existing closing bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #-") (Just "{-# LANGUAGE #-}") (0, 4, 0, 33, 0, 4) , completionTest "completes options pragma" "Completion.hs" "OPTIONS" "OPTIONS_GHC" (Just InsertTextFormat_Snippet) (Just "OPTIONS_GHC -${1:option} #-}") (Just "{-# OPTIONS_GHC #-}") (0, 4, 0, 34, 0, 4) - , completionTest "completes ghc options pragma values" "Completion.hs" "{-# OPTIONS_GHC -Wno-red #-}\n" "Wno-redundant-constraints" Nothing Nothing Nothing (0, 0, 0, 0, 0, 24) + , completionTest "completes ghc options pragma values" "Completion.hs" "{-# OPTIONS_GHC -Wno-red #-}\n" "-Wno-redundant-constraints" Nothing Nothing Nothing (0, 0, 0, 0, 0, 24) + , completionTest "completes ghc options pragma values with multiple dashes" "Completion.hs" "{-# OPTIONS_GHC -fmax-worker-ar #-}\n" "-fmax-worker-args" Nothing Nothing Nothing (0, 0, 0, 0, 0, 31) + , completionTest "completes multiple ghc options within single pragma" "Completion.hs" "{-# OPTIONS_GHC -ddump-simpl -ddump-spl #-}\n" "-ddump-splices" Nothing Nothing Nothing (0, 0, 0, 0, 0, 39) , completionTest "completes language extensions" "Completion.hs" "" "OverloadedStrings" Nothing Nothing Nothing (0, 24, 0, 31, 0, 24) , completionTest "completes language extensions case insensitive" "Completion.hs" "lAnGuaGe Overloaded" "OverloadedStrings" Nothing Nothing Nothing (0, 4, 0, 34, 0, 24) , completionTest "completes the Strict language extension" "Completion.hs" "Str" "Strict" Nothing Nothing Nothing (0, 13, 0, 31, 0, 16) From 42088bf7c5ac79d4910a8f5979516ef7679d7053 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Sun, 4 Feb 2024 09:15:18 +0100 Subject: [PATCH 2/3] Fix the bug --- .../IDE/Plugin/Completions/Logic.hs | 2 +- haskell-language-server.cabal | 5 +- .../src/Ide/Plugin/Pragmas.hs | 74 +++++++++++++------ 3 files changed, 57 insertions(+), 24 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index a08a188337..204bd4d388 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -904,7 +904,7 @@ getCompletionPrefix pos@(Position l c) (VFS.VirtualFile _ _ ropetext) = lastMaybe = headMaybe . reverse -- grab the entire line the cursor is at - curLine <- headMaybe $ T.lines $ Rope.toText + curLine <- headMaybe $ Rope.lines $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext let beforePos = T.take (fromIntegral c) curLine -- the word getting typed, after previous space and before cursor diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 9bbb097060..c42a8f074f 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -761,7 +761,7 @@ common pragmas cpp-options: -Dhls_pragmas library hls-pragmas-plugin - import: defaults, warnings + import: defaults, pedantic, warnings exposed-modules: Ide.Plugin.Pragmas hs-source-dirs: plugins/hls-pragmas-plugin/src build-depends: @@ -773,11 +773,12 @@ library hls-pragmas-plugin , lens , lsp , text + , text-rope , transformers , containers test-suite hls-pragmas-plugin-tests - import: defaults, test-defaults, warnings + import: defaults, pedantic, test-defaults, warnings type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-pragmas-plugin/test main-is: Main.hs diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index 28ced1d5bc..ff8220c603 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -18,10 +18,14 @@ module Ide.Plugin.Pragmas import Control.Lens hiding (List) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (lift) +import Data.Char (isAlphaNum) import Data.List.Extra (nubOrdOn) import qualified Data.Map as M -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, + listToMaybe, + mapMaybe) import qualified Data.Text as T +import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE hiding (line) import Development.IDE.Core.Compile (sourceParser, sourceTypecheck) @@ -29,7 +33,8 @@ import Development.IDE.Core.PluginUtils import Development.IDE.GHC.Compat import Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority) import Development.IDE.Plugin.Completions.Logic (getCompletionPrefix) -import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..)) +import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..), + prefixText) import qualified Development.IDE.Spans.Pragmas as Pragmas import Ide.Plugin.Error import Ide.Types @@ -37,6 +42,7 @@ import qualified Language.LSP.Protocol.Lens as L import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP +import qualified Language.LSP.VFS as VFS import qualified Text.Fuzzy as Fuzzy -- --------------------------------------------------------------------- @@ -193,30 +199,32 @@ allPragmas = -- --------------------------------------------------------------------- flags :: [T.Text] -flags = map (T.pack . stripLeading '-') $ flagsForCompletion False +flags = map T.pack $ flagsForCompletion False completion :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion completion _ide _ complParams = do let (LSP.TextDocumentIdentifier uri) = complParams ^. L.textDocument - position = complParams ^. L.position + cursorPos@(Position l c) = complParams ^. L.position contents <- lift $ LSP.getVirtualFile $ toNormalizedUri uri fmap LSP.InL $ case (contents, uriToFilePath' uri) of (Just cnts, Just _path) -> - pure $ result $ getCompletionPrefix position cnts + pure $ result $ getCompletionPrefix cursorPos cnts where result pfix | "{-# language" `T.isPrefixOf` line - = map buildCompletion - (Fuzzy.simpleFilter (prefixText pfix) allPragmas) + = map mkLanguagePragmaCompl $ + Fuzzy.simpleFilter (prefixText pfix) allPragmas | "{-# options_ghc" `T.isPrefixOf` line - = map buildCompletion - (Fuzzy.simpleFilter (prefixText pfix) flags) + = let flagPrefix = getGhcOptionPrefix cursorPos cnts + prefixLength = fromIntegral $ T.length flagPrefix + prefixRange = LSP.Range (Position l (c - prefixLength)) cursorPos + in map (mkGhcOptionCompl prefixRange) $ Fuzzy.simpleFilter flagPrefix flags | "{-#" `T.isPrefixOf` line = [ mkPragmaCompl (a <> suffix) b c | (a, b, c, w) <- validPragmas, w == NewLine ] | -- Do not suggest any pragmas any of these conditions: - -- 1. Current line is a an import + -- 1. Current line is an import -- 2. There is a module name right before the current word. -- Something like `Text.la` shouldn't suggest adding the -- 'LANGUAGE' pragma. @@ -239,7 +247,7 @@ completion _ide _ complParams = do module_ = prefixScope pfix word = prefixText pfix -- Not completely correct, may fail if more than one "{-#" exist - -- , we can ignore it since it rarely happen. + -- , we can ignore it since it rarely happens. prefix | "{-# " `T.isInfixOf` line = "" | "{-#" `T.isInfixOf` line = " " @@ -293,19 +301,43 @@ mkPragmaCompl insertText label detail = Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just LSP.InsertTextFormat_Snippet) Nothing Nothing Nothing Nothing Nothing Nothing Nothing - -stripLeading :: Char -> String -> String -stripLeading _ [] = [] -stripLeading c (s:ss) - | s == c = ss - | otherwise = s:ss - - -buildCompletion :: T.Text -> LSP.CompletionItem -buildCompletion label = +getGhcOptionPrefix :: Position -> VFS.VirtualFile -> T.Text +getGhcOptionPrefix (Position l c) (VFS.VirtualFile _ _ ropetext) = + fromMaybe "" $ do + let lastMaybe = listToMaybe . reverse + + -- grab the entire line the cursor is at + curLine <- listToMaybe + $ Rope.lines + $ fst $ Rope.splitAtLine 1 + $ snd $ Rope.splitAtLine (fromIntegral l) ropetext + let beforePos = T.take (fromIntegral c) curLine + -- the word getting typed, after previous space and before cursor + curWord <- + if | T.null beforePos -> Just "" + | T.last beforePos == ' ' -> Just "" -- don't count abc as the curword in 'abc ' + | otherwise -> lastMaybe (T.words beforePos) + pure $ T.takeWhileEnd isGhcOptionChar curWord + +-- | Is this character contained in some GHC flag? Based on: +-- GHCi> nub . sort . concat $ GHC.Driver.Session.flagsForCompletion False +-- "#-.01234589=ABCDEFGHIJKLMNOPQRSTUVWX_abcdefghijklmnopqrstuvwxyz" +isGhcOptionChar :: Char -> Bool +isGhcOptionChar c = isAlphaNum c || c `elem` ("#-.=_" :: String) + +mkLanguagePragmaCompl :: T.Text -> LSP.CompletionItem +mkLanguagePragmaCompl label = LSP.CompletionItem label Nothing (Just LSP.CompletionItemKind_Keyword) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing +mkGhcOptionCompl :: Range -> T.Text -> LSP.CompletionItem +mkGhcOptionCompl editRange completedFlag = + LSP.CompletionItem completedFlag Nothing (Just LSP.CompletionItemKind_Keyword) Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing (Just insertCompleteFlag) Nothing Nothing Nothing Nothing Nothing + where + insertCompleteFlag = LSP.InL $ LSP.TextEdit editRange completedFlag + From 7942f9900bbeec13146449cdc5763a548e25a6ab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Fri, 9 Feb 2024 19:34:53 +0100 Subject: [PATCH 3/3] Refactor, more reuse --- haskell-language-server.cabal | 1 - .../src/Ide/Plugin/Pragmas.hs | 84 ++++++++----------- 2 files changed, 34 insertions(+), 51 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index c42a8f074f..8fa5dc06b7 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -773,7 +773,6 @@ library hls-pragmas-plugin , lens , lsp , text - , text-rope , transformers , containers diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index ff8220c603..b43dfd928d 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -21,11 +21,8 @@ import Control.Monad.Trans.Class (lift) import Data.Char (isAlphaNum) import Data.List.Extra (nubOrdOn) import qualified Data.Map as M -import Data.Maybe (fromMaybe, - listToMaybe, - mapMaybe) +import Data.Maybe (mapMaybe) import qualified Data.Text as T -import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE hiding (line) import Development.IDE.Core.Compile (sourceParser, sourceTypecheck) @@ -33,8 +30,7 @@ import Development.IDE.Core.PluginUtils import Development.IDE.GHC.Compat import Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority) import Development.IDE.Plugin.Completions.Logic (getCompletionPrefix) -import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..), - prefixText) +import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..)) import qualified Development.IDE.Spans.Pragmas as Pragmas import Ide.Plugin.Error import Ide.Types @@ -42,7 +38,6 @@ import qualified Language.LSP.Protocol.Lens as L import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP -import qualified Language.LSP.VFS as VFS import qualified Text.Fuzzy as Fuzzy -- --------------------------------------------------------------------- @@ -135,7 +130,6 @@ suggestDisableWarning Diagnostic {_code} -- Don't suggest disabling type errors as a solution to all type errors warningBlacklist :: [T.Text] --- warningBlacklist = [] warningBlacklist = ["deferred-type-errors"] -- --------------------------------------------------------------------- @@ -204,26 +198,26 @@ flags = map T.pack $ flagsForCompletion False completion :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion completion _ide _ complParams = do let (LSP.TextDocumentIdentifier uri) = complParams ^. L.textDocument - cursorPos@(Position l c) = complParams ^. L.position + position@(Position ln col) = complParams ^. L.position contents <- lift $ LSP.getVirtualFile $ toNormalizedUri uri fmap LSP.InL $ case (contents, uriToFilePath' uri) of (Just cnts, Just _path) -> - pure $ result $ getCompletionPrefix cursorPos cnts + pure $ result $ getCompletionPrefix position cnts where result pfix | "{-# language" `T.isPrefixOf` line = map mkLanguagePragmaCompl $ - Fuzzy.simpleFilter (prefixText pfix) allPragmas + Fuzzy.simpleFilter word allPragmas | "{-# options_ghc" `T.isPrefixOf` line - = let flagPrefix = getGhcOptionPrefix cursorPos cnts - prefixLength = fromIntegral $ T.length flagPrefix - prefixRange = LSP.Range (Position l (c - prefixLength)) cursorPos - in map (mkGhcOptionCompl prefixRange) $ Fuzzy.simpleFilter flagPrefix flags + = let optionPrefix = getGhcOptionPrefix pfix + prefixLength = fromIntegral $ T.length optionPrefix + prefixRange = LSP.Range (Position ln (col - prefixLength)) position + in map (mkGhcOptionCompl prefixRange) $ Fuzzy.simpleFilter optionPrefix flags | "{-#" `T.isPrefixOf` line = [ mkPragmaCompl (a <> suffix) b c | (a, b, c, w) <- validPragmas, w == NewLine ] - | -- Do not suggest any pragmas any of these conditions: + | -- Do not suggest any pragmas under any of these conditions: -- 1. Current line is an import -- 2. There is a module name right before the current word. -- Something like `Text.la` shouldn't suggest adding the @@ -234,20 +228,21 @@ completion _ide _ complParams = do | otherwise = [ mkPragmaCompl (prefix <> pragmaTemplate <> suffix) matcher detail | (pragmaTemplate, matcher, detail, appearWhere) <- validPragmas - , -- Only suggest a pragma that needs its own line if the whole line - -- fuzzily matches the pragma - (appearWhere == NewLine && Fuzzy.test line matcher ) || - -- Only suggest a pragma that appears in the middle of a line when - -- the current word is not the only thing in the line and the - -- current word fuzzily matches the pragma - (appearWhere == CanInline && line /= word && Fuzzy.test word matcher) + , case appearWhere of + -- Only suggest a pragma that needs its own line if the whole line + -- fuzzily matches the pragma + NewLine -> Fuzzy.test line matcher + -- Only suggest a pragma that appears in the middle of a line when + -- the current word is not the only thing in the line and the + -- current word fuzzily matches the pragma + CanInline -> line /= word && Fuzzy.test word matcher ] where line = T.toLower $ fullLine pfix module_ = prefixScope pfix word = prefixText pfix - -- Not completely correct, may fail if more than one "{-#" exist - -- , we can ignore it since it rarely happens. + -- Not completely correct, may fail if more than one "{-#" exists. + -- We can ignore it since it rarely happens. prefix | "{-# " `T.isInfixOf` line = "" | "{-#" `T.isInfixOf` line = " " @@ -301,30 +296,6 @@ mkPragmaCompl insertText label detail = Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just LSP.InsertTextFormat_Snippet) Nothing Nothing Nothing Nothing Nothing Nothing Nothing -getGhcOptionPrefix :: Position -> VFS.VirtualFile -> T.Text -getGhcOptionPrefix (Position l c) (VFS.VirtualFile _ _ ropetext) = - fromMaybe "" $ do - let lastMaybe = listToMaybe . reverse - - -- grab the entire line the cursor is at - curLine <- listToMaybe - $ Rope.lines - $ fst $ Rope.splitAtLine 1 - $ snd $ Rope.splitAtLine (fromIntegral l) ropetext - let beforePos = T.take (fromIntegral c) curLine - -- the word getting typed, after previous space and before cursor - curWord <- - if | T.null beforePos -> Just "" - | T.last beforePos == ' ' -> Just "" -- don't count abc as the curword in 'abc ' - | otherwise -> lastMaybe (T.words beforePos) - pure $ T.takeWhileEnd isGhcOptionChar curWord - --- | Is this character contained in some GHC flag? Based on: --- GHCi> nub . sort . concat $ GHC.Driver.Session.flagsForCompletion False --- "#-.01234589=ABCDEFGHIJKLMNOPQRSTUVWX_abcdefghijklmnopqrstuvwxyz" -isGhcOptionChar :: Char -> Bool -isGhcOptionChar c = isAlphaNum c || c `elem` ("#-.=_" :: String) - mkLanguagePragmaCompl :: T.Text -> LSP.CompletionItem mkLanguagePragmaCompl label = LSP.CompletionItem label Nothing (Just LSP.CompletionItemKind_Keyword) Nothing Nothing @@ -339,5 +310,18 @@ mkGhcOptionCompl editRange completedFlag = where insertCompleteFlag = LSP.InL $ LSP.TextEdit editRange completedFlag +-- The prefix extraction logic of getCompletionPrefix +-- doesn't consider '-' part of prefix which breaks completion +-- of flags like "-ddump-xyz". For OPTIONS_GHC completion we need the whole thing +-- to be considered completion prefix, but `prefixText posPrefixInfo` would return"xyz" in this case +getGhcOptionPrefix :: PosPrefixInfo -> T.Text +getGhcOptionPrefix PosPrefixInfo {cursorPos = Position _ col, fullLine}= + T.takeWhileEnd isGhcOptionChar beforePos + where + beforePos = T.take (fromIntegral col) fullLine - + -- Is this character contained in some GHC flag? Based on: + -- >>> nub . sort . concat $ GHC.Driver.Session.flagsForCompletion False + -- "#-.01234589=ABCDEFGHIJKLMNOPQRSTUVWX_abcdefghijklmnopqrstuvwxyz" + isGhcOptionChar :: Char -> Bool + isGhcOptionChar c = isAlphaNum c || c `elem` ("#-.=_" :: String)