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..8fa5dc06b7 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: @@ -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 diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index 28ced1d5bc..b43dfd928d 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -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) @@ -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"] -- --------------------------------------------------------------------- @@ -193,12 +193,12 @@ 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) -> @@ -206,17 +206,19 @@ completion _ide _ complParams = do 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. @@ -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 = " " @@ -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) 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)