Skip to content

Commit 1bbe780

Browse files
jhrcekjhrcek
authored
Fix weird behavior of OPTIONS_GHC completions (fixes #3908) (#4031)
1 parent e37ec7d commit 1bbe780

File tree

4 files changed

+51
-33
lines changed

4 files changed

+51
-33
lines changed

‎ghcide/src/Development/IDE/Plugin/Completions/Logic.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -904,7 +904,7 @@ getCompletionPrefix pos@(Position l c) (VFS.VirtualFile _ _ ropetext) =
904904
lastMaybe = headMaybe . reverse
905905

906906
-- grab the entire line the cursor is at
907-
curLine <- headMaybe $ T.lines $ Rope.toText
907+
curLine <- headMaybe $ Rope.lines
908908
$ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext
909909
let beforePos = T.take (fromIntegral c) curLine
910910
-- the word getting typed, after previous space and before cursor

‎haskell-language-server.cabal

+2-2
Original file line numberDiff line numberDiff line change
@@ -761,7 +761,7 @@ common pragmas
761761
cpp-options: -Dhls_pragmas
762762

763763
library hls-pragmas-plugin
764-
import: defaults, warnings
764+
import: defaults, pedantic, warnings
765765
exposed-modules: Ide.Plugin.Pragmas
766766
hs-source-dirs: plugins/hls-pragmas-plugin/src
767767
build-depends:
@@ -777,7 +777,7 @@ library hls-pragmas-plugin
777777
, containers
778778

779779
test-suite hls-pragmas-plugin-tests
780-
import: defaults, test-defaults, warnings
780+
import: defaults, pedantic, test-defaults, warnings
781781
type: exitcode-stdio-1.0
782782
hs-source-dirs: plugins/hls-pragmas-plugin/test
783783
main-is: Main.hs

‎plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs

+45-29
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ module Ide.Plugin.Pragmas
1818
import Control.Lens hiding (List)
1919
import Control.Monad.IO.Class (MonadIO (liftIO))
2020
import Control.Monad.Trans.Class (lift)
21+
import Data.Char (isAlphaNum)
2122
import Data.List.Extra (nubOrdOn)
2223
import qualified Data.Map as M
2324
import Data.Maybe (mapMaybe)
@@ -129,7 +130,6 @@ suggestDisableWarning Diagnostic {_code}
129130

130131
-- Don't suggest disabling type errors as a solution to all type errors
131132
warningBlacklist :: [T.Text]
132-
-- warningBlacklist = []
133133
warningBlacklist = ["deferred-type-errors"]
134134

135135
-- ---------------------------------------------------------------------
@@ -193,30 +193,32 @@ allPragmas =
193193

194194
-- ---------------------------------------------------------------------
195195
flags :: [T.Text]
196-
flags = map (T.pack . stripLeading '-') $ flagsForCompletion False
196+
flags = map T.pack $ flagsForCompletion False
197197

198198
completion :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion
199199
completion _ide _ complParams = do
200200
let (LSP.TextDocumentIdentifier uri) = complParams ^. L.textDocument
201-
position = complParams ^. L.position
201+
position@(Position ln col) = complParams ^. L.position
202202
contents <- lift $ LSP.getVirtualFile $ toNormalizedUri uri
203203
fmap LSP.InL $ case (contents, uriToFilePath' uri) of
204204
(Just cnts, Just _path) ->
205205
pure $ result $ getCompletionPrefix position cnts
206206
where
207207
result pfix
208208
| "{-# language" `T.isPrefixOf` line
209-
= map buildCompletion
210-
(Fuzzy.simpleFilter (prefixText pfix) allPragmas)
209+
= map mkLanguagePragmaCompl $
210+
Fuzzy.simpleFilter word allPragmas
211211
| "{-# options_ghc" `T.isPrefixOf` line
212-
= map buildCompletion
213-
(Fuzzy.simpleFilter (prefixText pfix) flags)
212+
= let optionPrefix = getGhcOptionPrefix pfix
213+
prefixLength = fromIntegral $ T.length optionPrefix
214+
prefixRange = LSP.Range (Position ln (col - prefixLength)) position
215+
in map (mkGhcOptionCompl prefixRange) $ Fuzzy.simpleFilter optionPrefix flags
214216
| "{-#" `T.isPrefixOf` line
215217
= [ mkPragmaCompl (a <> suffix) b c
216218
| (a, b, c, w) <- validPragmas, w == NewLine
217219
]
218-
| -- Do not suggest any pragmas any of these conditions:
219-
-- 1. Current line is a an import
220+
| -- Do not suggest any pragmas under any of these conditions:
221+
-- 1. Current line is an import
220222
-- 2. There is a module name right before the current word.
221223
-- Something like `Text.la` shouldn't suggest adding the
222224
-- 'LANGUAGE' pragma.
@@ -226,20 +228,21 @@ completion _ide _ complParams = do
226228
| otherwise
227229
= [ mkPragmaCompl (prefix <> pragmaTemplate <> suffix) matcher detail
228230
| (pragmaTemplate, matcher, detail, appearWhere) <- validPragmas
229-
, -- Only suggest a pragma that needs its own line if the whole line
230-
-- fuzzily matches the pragma
231-
(appearWhere == NewLine && Fuzzy.test line matcher ) ||
232-
-- Only suggest a pragma that appears in the middle of a line when
233-
-- the current word is not the only thing in the line and the
234-
-- current word fuzzily matches the pragma
235-
(appearWhere == CanInline && line /= word && Fuzzy.test word matcher)
231+
, case appearWhere of
232+
-- Only suggest a pragma that needs its own line if the whole line
233+
-- fuzzily matches the pragma
234+
NewLine -> Fuzzy.test line matcher
235+
-- Only suggest a pragma that appears in the middle of a line when
236+
-- the current word is not the only thing in the line and the
237+
-- current word fuzzily matches the pragma
238+
CanInline -> line /= word && Fuzzy.test word matcher
236239
]
237240
where
238241
line = T.toLower $ fullLine pfix
239242
module_ = prefixScope pfix
240243
word = prefixText pfix
241-
-- Not completely correct, may fail if more than one "{-#" exist
242-
-- , we can ignore it since it rarely happen.
244+
-- Not completely correct, may fail if more than one "{-#" exists.
245+
-- We can ignore it since it rarely happens.
243246
prefix
244247
| "{-# " `T.isInfixOf` line = ""
245248
| "{-#" `T.isInfixOf` line = " "
@@ -293,19 +296,32 @@ mkPragmaCompl insertText label detail =
293296
Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just LSP.InsertTextFormat_Snippet)
294297
Nothing Nothing Nothing Nothing Nothing Nothing Nothing
295298

296-
297-
stripLeading :: Char -> String -> String
298-
stripLeading _ [] = []
299-
stripLeading c (s:ss)
300-
| s == c = ss
301-
| otherwise = s:ss
302-
303-
304-
buildCompletion :: T.Text -> LSP.CompletionItem
305-
buildCompletion label =
299+
mkLanguagePragmaCompl :: T.Text -> LSP.CompletionItem
300+
mkLanguagePragmaCompl label =
306301
LSP.CompletionItem label Nothing (Just LSP.CompletionItemKind_Keyword) Nothing Nothing
307302
Nothing Nothing Nothing Nothing Nothing Nothing Nothing
308303
Nothing Nothing Nothing Nothing Nothing Nothing Nothing
309304

305+
mkGhcOptionCompl :: Range -> T.Text -> LSP.CompletionItem
306+
mkGhcOptionCompl editRange completedFlag =
307+
LSP.CompletionItem completedFlag Nothing (Just LSP.CompletionItemKind_Keyword) Nothing Nothing
308+
Nothing Nothing Nothing Nothing Nothing Nothing Nothing
309+
Nothing (Just insertCompleteFlag) Nothing Nothing Nothing Nothing Nothing
310+
where
311+
insertCompleteFlag = LSP.InL $ LSP.TextEdit editRange completedFlag
312+
313+
-- The prefix extraction logic of getCompletionPrefix
314+
-- doesn't consider '-' part of prefix which breaks completion
315+
-- of flags like "-ddump-xyz". For OPTIONS_GHC completion we need the whole thing
316+
-- to be considered completion prefix, but `prefixText posPrefixInfo` would return"xyz" in this case
317+
getGhcOptionPrefix :: PosPrefixInfo -> T.Text
318+
getGhcOptionPrefix PosPrefixInfo {cursorPos = Position _ col, fullLine}=
319+
T.takeWhileEnd isGhcOptionChar beforePos
320+
where
321+
beforePos = T.take (fromIntegral col) fullLine
310322

311-
323+
-- Is this character contained in some GHC flag? Based on:
324+
-- >>> nub . sort . concat $ GHC.Driver.Session.flagsForCompletion False
325+
-- "#-.01234589=ABCDEFGHIJKLMNOPQRSTUVWX_abcdefghijklmnopqrstuvwxyz"
326+
isGhcOptionChar :: Char -> Bool
327+
isGhcOptionChar c = isAlphaNum c || c `elem` ("#-.=_" :: String)

‎plugins/hls-pragmas-plugin/test/Main.hs

+3-1
Original file line numberDiff line numberDiff line change
@@ -124,7 +124,9 @@ completionTests =
124124
, 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)
125125
, 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)
126126
, 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)
127-
, 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)
127+
, 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)
128+
, 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)
129+
, 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)
128130
, completionTest "completes language extensions" "Completion.hs" "" "OverloadedStrings" Nothing Nothing Nothing (0, 24, 0, 31, 0, 24)
129131
, completionTest "completes language extensions case insensitive" "Completion.hs" "lAnGuaGe Overloaded" "OverloadedStrings" Nothing Nothing Nothing (0, 4, 0, 34, 0, 24)
130132
, completionTest "completes the Strict language extension" "Completion.hs" "Str" "Strict" Nothing Nothing Nothing (0, 13, 0, 31, 0, 16)

0 commit comments

Comments
 (0)