Skip to content

Fix weird behavior of OPTIONS_GHC completions (fixes #3908) #4031

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 3 commits into from
Feb 10, 2024
Merged

Fix weird behavior of OPTIONS_GHC completions (fixes #3908) #4031

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
d49add9
Add reproducer for bug in OPTIONS_GHC completions (#3908)
jhrcek Feb 4, 2024
42088bf
Fix the bug
jhrcek Feb 4, 2024
7942f99
Refactor, more reuse
jhrcek Feb 9, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion ghcide/src/Development/IDE/Plugin/Completions/Logic.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is supposed to be faster than Text.lines, so why not use it here as well..
https://hackage.haskell.org/package/text-rope-0.2/docs/Data-Text-Lines.html#v:lines

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yes! We really need to audit all uses of Rope.toText, maybe even give it a hlint hint. It's generally unnecessarily expensive and does work proportional to the length of the document...

$ 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
Expand Down
4 changes: 2 additions & 2 deletions haskell-language-server.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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:
Expand All @@ -777,7 +777,7 @@ library hls-pragmas-plugin
, 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
Expand Down
74 changes: 45 additions & 29 deletions plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -18,6 +18,7 @@ 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)
Expand Down Expand Up @@ -129,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"]

-- ---------------------------------------------------------------------
Expand Down Expand Up @@ -193,30 +193,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
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 position cnts
where
result pfix
| "{-# language" `T.isPrefixOf` line
= map buildCompletion
(Fuzzy.simpleFilter (prefixText pfix) allPragmas)
= map mkLanguagePragmaCompl $
Fuzzy.simpleFilter word allPragmas
| "{-# options_ghc" `T.isPrefixOf` line
= map buildCompletion
(Fuzzy.simpleFilter (prefixText pfix) 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:
-- 1. Current line is a an import
| -- 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
-- 'LANGUAGE' pragma.
Expand All @@ -226,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 happen.
-- 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 = " "
Expand Down Expand Up @@ -293,19 +296,32 @@ 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 =
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

-- 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)
4 changes: 3 additions & 1 deletion plugins/hls-pragmas-plugin/test/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down