Skip to content

Commit

Permalink
hls-pragmas-plugin: Reduce noisy completions
Browse files Browse the repository at this point in the history
  • Loading branch information
akshaymankar committed Jun 11, 2023
1 parent c126332 commit 8ae29e3
Show file tree
Hide file tree
Showing 3 changed files with 83 additions and 22 deletions.
1 change: 1 addition & 0 deletions plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -49,6 +49,7 @@ test-suite tests
main-is: Main.hs
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends:
, aeson
, base
, filepath
, hls-pragmas-plugin
Expand Down
30 changes: 18 additions & 12 deletions plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs
Original file line number Diff line number Diff line change
Expand Up @@ -12,6 +12,7 @@ module Ide.Plugin.Pragmas
( descriptor
-- For testing
, validPragmas
, AppearWhere(..)
) where

import Control.Lens hiding (List)
Expand Down Expand Up @@ -181,23 +182,32 @@ completion _ide _ complParams = do
contents <- LSP.getVirtualFile $ toNormalizedUri uri
fmap (Right . J.InL) $ case (contents, uriToFilePath' uri) of
(Just cnts, Just _path) ->
result <$> VFS.getCompletionPrefix position cnts
J.List . result <$> VFS.getCompletionPrefix position cnts
where
result (Just pfix)
| "{-# language" `T.isPrefixOf` line
= J.List $ map buildCompletion
= map buildCompletion
(Fuzzy.simpleFilter (VFS.prefixText pfix) allPragmas)
| "{-# options_ghc" `T.isPrefixOf` line
= J.List $ map buildCompletion
= map buildCompletion
(Fuzzy.simpleFilter (VFS.prefixText pfix) flags)
| "{-#" `T.isPrefixOf` line
= J.List $ [ mkPragmaCompl (a <> suffix) b c
| (a, b, c, w) <- validPragmas, w == NewLine ]
= [ mkPragmaCompl (a <> suffix) b c
| (a, b, c, w) <- validPragmas, w == NewLine
]
| "import" `T.isPrefixOf` line || not (T.null module_) || T.null word
= []
| otherwise
= J.List $ [ mkPragmaCompl (prefix <> a <> suffix) b c
| (a, b, c, _) <- validPragmas, Fuzzy.test word b]
= [ mkPragmaCompl (prefix <> pragmaTemplate <> suffix) matcher detail
| (pragmaTemplate, matcher, detail, appearWhere) <- validPragmas
, Fuzzy.test word matcher
, (appearWhere == NewLine && line == word)
|| (appearWhere == CanInline && line /= word)
|| (T.elem ' ' matcher && appearWhere == NewLine && Fuzzy.test word matcher)
]
where
line = T.toLower $ VFS.fullLine pfix
module_ = VFS.prefixModule pfix
word = VFS.prefixText pfix
-- Not completely correct, may fail if more than one "{-#" exist
-- , we can ignore it since it rarely happen.
Expand All @@ -211,9 +221,8 @@ completion _ide _ complParams = do
| "-}" `T.isSuffixOf` line = " #"
| "}" `T.isSuffixOf` line = " #-"
| otherwise = " #-}"
result Nothing = J.List []
result Nothing = []
_ -> return $ J.List []

-----------------------------------------------------------------------

-- | Pragma where exist
Expand Down Expand Up @@ -268,6 +277,3 @@ buildCompletion label =
J.CompletionItem label (Just J.CiKeyword) Nothing Nothing
Nothing Nothing Nothing Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing Nothing Nothing



74 changes: 64 additions & 10 deletions plugins/hls-pragmas-plugin/test/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -5,6 +5,8 @@ module Main
) where

import Control.Lens ((<&>), (^.))
import Data.Aeson
import Data.Foldable
import qualified Data.Text as T
import Ide.Plugin.Pragmas
import qualified Language.LSP.Types.Lens as L
Expand All @@ -25,6 +27,7 @@ tests =
, codeActionTests'
, completionTests
, completionSnippetTests
, dontSuggestCompletionTests
]

codeActionTests :: TestTree
Expand Down Expand Up @@ -127,29 +130,80 @@ completionSnippetTests :: TestTree
completionSnippetTests =
testGroup "expand snippet to pragma" $
validPragmas <&>
(\(insertText, label, detail, _) ->
let input = T.toLower $ T.init label
(\(insertText, label, detail, appearWhere) ->
let inputPrefix =
case appearWhere of
NewLine -> ""
CanInline -> "something "
input = inputPrefix <> (T.toLower $ T.init label)
in completionTest (T.unpack label)
"Completion.hs" input label (Just Snippet)
(Just $ "{-# " <> insertText <> " #-}") (Just detail)
[0, 0, 0, 34, 0, fromIntegral $ T.length input])

completionTest :: String -> String -> T.Text -> T.Text -> Maybe InsertTextFormat -> Maybe T.Text -> Maybe T.Text -> [UInt] -> TestTree
completionTest testComment fileName te' label textFormat insertText detail [a, b, c, d, x, y] =
dontSuggestCompletionTests :: TestTree
dontSuggestCompletionTests =
testGroup "do not suggest pragmas" $
let replaceFuncBody newBody = Just $ mkEdit (8,6) (8,8) newBody
writeInEmptyLine txt = Just $ mkEdit (3,0) (3,0) txt
generalTests = [ provideNoCompletionsTest "in imports" "Completion.hs" (Just $ mkEdit (3,0) (3,0) "import WA") (Position 3 8)
, provideNoCompletionsTest "when no word has been typed" "Completion.hs" Nothing (Position 3 0)
, provideNoCompletionsTest "when expecting auto complete on modules" "Completion.hs" (Just $ mkEdit (8,6) (8,8) "Data.Maybe.WA") (Position 8 19)
]
individualPragmaTests = validPragmas <&> \(insertText,label,detail,appearWhere) ->
let completionPrompt = T.toLower $ T.init label
promptLen = fromIntegral (T.length completionPrompt)
in case appearWhere of
CanInline ->
provideNoUndesiredCompletionsTest ("at new line: " <> T.unpack label) "Completion.hs" (Just label) (writeInEmptyLine completionPrompt) (Position 3 0)
NewLine ->
provideNoUndesiredCompletionsTest ("inline: " <> T.unpack label) "Completion.hs" (Just label) (replaceFuncBody completionPrompt) (Position 8 (6 + promptLen))
in generalTests ++ individualPragmaTests

mkEdit :: (UInt,UInt) -> (UInt,UInt) -> T.Text -> TextEdit
mkEdit (startLine, startCol) (endLine, endCol) newText =
TextEdit (Range (Position startLine startCol) (Position endLine endCol)) newText

completionTest :: String -> FilePath -> T.Text -> T.Text -> Maybe InsertTextFormat -> Maybe T.Text -> Maybe T.Text -> [UInt] -> TestTree
completionTest testComment fileName replacementText expectedLabel expectedFormat expectedInsertText detail [delFromLine, delFromCol, delToLine, delToCol, completeAtLine, completeAtCol] =
testCase testComment $ runSessionWithServer pragmasPlugin testDataDir $ do
doc <- openDoc fileName "haskell"
_ <- waitForDiagnostics
let te = TextEdit (Range (Position a b) (Position c d)) te'
let te = TextEdit (Range (Position delFromLine delFromCol) (Position delToLine delToCol)) replacementText
_ <- applyEdit doc te
compls <- getCompletions doc (Position x y)
item <- getCompletionByLabel label compls
compls <- getCompletions doc (Position completeAtLine completeAtCol)
item <- getCompletionByLabel expectedLabel compls
liftIO $ do
item ^. L.label @?= label
item ^. L.label @?= expectedLabel
item ^. L.kind @?= Just CiKeyword
item ^. L.insertTextFormat @?= textFormat
item ^. L.insertText @?= insertText
item ^. L.insertTextFormat @?= expectedFormat
item ^. L.insertText @?= expectedInsertText
item ^. L.detail @?= detail

provideNoCompletionsTest :: String -> FilePath -> Maybe TextEdit -> Position -> TestTree
provideNoCompletionsTest testComment fileName mTextEdit pos =
provideNoUndesiredCompletionsTest testComment fileName Nothing mTextEdit pos

provideNoUndesiredCompletionsTest :: String -> FilePath -> Maybe T.Text -> Maybe TextEdit -> Position -> TestTree
provideNoUndesiredCompletionsTest testComment fileName mUndesiredLabel mTextEdit pos =
testCase testComment $ runSessionWithServer pragmasPlugin testDataDir $ do
doc <- openDoc fileName "haskell"
_ <- waitForDiagnostics
_ <- sendConfigurationChanged disableGhcideCompletions
mapM_ (applyEdit doc) mTextEdit
compls <- getCompletions doc pos
liftIO $ case mUndesiredLabel of
Nothing -> compls @?= []
Just undesiredLabel -> do
case find (\c -> c ^. L.label == undesiredLabel) compls of
Just c -> assertFailure $
"Did not expect a completion with label=" <> T.unpack undesiredLabel
<> ", got completion: "<> show c
Nothing -> pure ()

disableGhcideCompletions :: Value
disableGhcideCompletions = object [ "haskell" .= object ["plugin" .= object [ "ghcide-completions" .= object ["globalOn" .= False]]] ]

goldenWithPragmas :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree
goldenWithPragmas title path = goldenWithHaskellDoc pragmasPlugin title testDataDir path "expected" "hs"

Expand Down

0 comments on commit 8ae29e3

Please sign in to comment.