diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index fda38c4e2f..5391928d54 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -197,6 +197,7 @@ common hls-test-utils , hslogger , hspec , hspec-core + , lens , lsp-test >=0.11.0.6 , stm , tasty-hunit diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index d9791c8b1d..d49626c000 100644 --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -2,10 +2,9 @@ {-# LANGUAGE ScopedTypeVariables #-} module Completion(tests) where -import Control.Applicative.Combinators import Control.Monad.IO.Class import Control.Lens hiding ((.=)) --- import Data.Aeson +import Data.Aeson (object, (.=)) import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens hiding (applyEdit) @@ -13,383 +12,396 @@ import Test.Hls.Util import Test.Tasty import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit - ---TODO: Fix tests, some structural changed hav been made +import qualified Data.Text as T tests :: TestTree tests = testGroup "completions" [ --- testCase "works" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - --- let te = TextEdit (Range (Position 5 7) (Position 5 24)) "put" --- _ <- applyEdit doc te - --- compls <- getCompletions doc (Position 5 9) --- let item = head $ filter ((== "putStrLn") . (^. label)) compls --- liftIO $ do --- item ^. label @?= "putStrLn" --- item ^. kind @?= Just CiFunction --- item ^. detail @?= Just "Prelude" --- resolvedRes <- request CompletionItemResolve item --- let Just (resolved :: CompletionItem) = resolvedRes ^. result --- liftIO $ do --- resolved ^. label @?= "putStrLn" --- resolved ^. kind @?= Just CiFunction --- resolved ^. detail @?= Just "String -> IO ()\nPrelude" --- resolved ^. insertTextFormat @?= Just Snippet --- resolved ^. insertText @?= Just "putStrLn ${1:String}" - --- , testCase "completes imports" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - --- let te = TextEdit (Range (Position 1 17) (Position 1 26)) "Data.M" --- _ <- applyEdit doc te - --- compls <- getCompletions doc (Position 1 22) --- let item = head $ filter ((== "Maybe") . (^. label)) compls --- liftIO $ do --- item ^. label @?= "Maybe" --- item ^. detail @?= Just "Data.Maybe" --- item ^. kind @?= Just CiModule - --- , testCase "completes qualified imports" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - --- let te = TextEdit (Range (Position 2 17) (Position 1 25)) "Dat" --- _ <- applyEdit doc te - --- compls <- getCompletions doc (Position 1 19) --- let item = head $ filter ((== "Data.List") . (^. label)) compls --- liftIO $ do --- item ^. label @?= "Data.List" --- item ^. detail @?= Just "Data.List" --- item ^. kind @?= Just CiModule - --- , testCase "completes language extensions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - --- let te = TextEdit (Range (Position 0 24) (Position 0 31)) "" --- _ <- applyEdit doc te - --- compls <- getCompletions doc (Position 0 24) --- let item = head $ filter ((== "OverloadedStrings") . (^. label)) compls --- liftIO $ do --- item ^. label @?= "OverloadedStrings" --- item ^. kind @?= Just CiKeyword - --- , testCase "completes pragmas" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - --- let te = TextEdit (Range (Position 0 4) (Position 0 34)) "" --- _ <- applyEdit doc te - --- compls <- getCompletions doc (Position 0 4) --- let item = head $ filter ((== "LANGUAGE") . (^. label)) compls --- liftIO $ do --- item ^. label @?= "LANGUAGE" --- item ^. kind @?= Just CiKeyword --- item ^. insertTextFormat @?= Just Snippet --- item ^. insertText @?= Just "LANGUAGE ${1:extension} #-}" - --- , testCase "completes pragmas no close" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - --- let te = TextEdit (Range (Position 0 4) (Position 0 24)) "" --- _ <- applyEdit doc te - --- compls <- getCompletions doc (Position 0 4) --- let item = head $ filter ((== "LANGUAGE") . (^. label)) compls --- liftIO $ do --- item ^. label @?= "LANGUAGE" --- item ^. kind @?= Just CiKeyword --- item ^. insertTextFormat @?= Just Snippet --- item ^. insertText @?= Just "LANGUAGE ${1:extension}" - --- , testCase "completes options pragma" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - --- let te = TextEdit (Range (Position 0 4) (Position 0 34)) "OPTIONS" --- _ <- applyEdit doc te - --- compls <- getCompletions doc (Position 0 4) --- let item = head $ filter ((== "OPTIONS_GHC") . (^. label)) compls --- liftIO $ do --- item ^. label @?= "OPTIONS_GHC" --- item ^. kind @?= Just CiKeyword --- item ^. insertTextFormat @?= Just Snippet --- item ^. insertText @?= Just "OPTIONS_GHC -${1:option} #-}" - --- -- ----------------------------------- - --- , testCase "completes ghc options pragma values" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" - --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - --- let te = TextEdit (Range (Position 0 0) (Position 0 0)) "{-# OPTIONS_GHC -Wno-red #-}\n" --- _ <- applyEdit doc te - --- compls <- getCompletions doc (Position 0 24) --- let item = head $ filter ((== "Wno-redundant-constraints") . (^. label)) compls --- liftIO $ do --- item ^. label @?= "Wno-redundant-constraints" --- item ^. kind @?= Just CiKeyword --- item ^. insertTextFormat @?= Nothing --- item ^. insertText @?= Nothing - --- -- ----------------------------------- - --- , testCase "completes with no prefix" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics --- compls <- getCompletions doc (Position 5 7) --- liftIO $ filter ((== "!!") . (^. label)) compls `shouldNotSatisfy` null - --- -- See https://github.com/haskell/haskell-ide-engine/issues/903 --- , testCase "strips compiler generated stuff from completions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "DupRecFields.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - --- let te = TextEdit (Range (Position 5 0) (Position 5 2)) "acc" --- _ <- applyEdit doc te - --- compls <- getCompletions doc (Position 5 4) --- let item = head $ filter (\c -> c^.label == "accessor") compls --- liftIO $ do --- item ^. label @?= "accessor" --- item ^. kind @?= Just CiFunction --- item ^. detail @?= Just "Two -> Int\nDupRecFields" --- item ^. insertText @?= Just "accessor ${1:Two}" - --- , testCase "have implicit foralls on basic polymorphic types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics --- let te = TextEdit (Range (Position 5 7) (Position 5 9)) "id" --- _ <- applyEdit doc te --- compls <- getCompletions doc (Position 5 9) --- let item = head $ filter ((== "id") . (^. label)) compls --- resolvedRes <- request CompletionItemResolve item --- let Just (resolved :: CompletionItem) = resolvedRes ^. result --- liftIO $ --- resolved ^. detail @?= Just "a -> a\nPrelude" - --- , testCase "have implicit foralls with multiple type variables" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics --- let te = TextEdit (Range (Position 5 7) (Position 5 24)) "flip" --- _ <- applyEdit doc te --- compls <- getCompletions doc (Position 5 11) --- let item = head $ filter ((== "flip") . (^. label)) compls --- resolvedRes <- request CompletionItemResolve item --- let Just (resolved :: CompletionItem) = resolvedRes ^. result --- liftIO $ --- resolved ^. detail @?= Just "(a -> b -> c) -> b -> a -> c\nPrelude" - - contextTests --- , snippetTests + testCase "works" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "put" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 9) + let item = head $ filter ((== "putStrLn") . (^. label)) compls + liftIO $ do + item ^. label @?= "putStrLn" + item ^. kind @?= Just CiFunction + item ^. detail @?= Just ":: String -> IO ()" + item ^. insertTextFormat @?= Just PlainText + item ^. insertText @?= Nothing + + , ignoreTestBecause "no support for itemCompletion/resolve requests" + $ testCase "itemCompletion/resolve works" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "put" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 9) + let item = head $ filter ((== "putStrLn") . (^. label)) compls + resolvedRes <- request CompletionItemResolve item + let Right (resolved :: CompletionItem) = resolvedRes ^. result + liftIO $ print resolved + liftIO $ do + resolved ^. label @?= "putStrLn" + resolved ^. kind @?= Just CiFunction + resolved ^. detail @?= Just "String -> IO ()\nPrelude" + resolved ^. insertTextFormat @?= Just Snippet + resolved ^. insertText @?= Just "putStrLn ${1:String}" + + , testCase "completes imports" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + + let te = TextEdit (Range (Position 1 17) (Position 1 26)) "Data.M" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 1 22) + let item = head $ filter ((== "Maybe") . (^. label)) compls + liftIO $ do + item ^. label @?= "Maybe" + item ^. detail @?= Just "Data.Maybe" + item ^. kind @?= Just CiModule + + , testCase "completes qualified imports" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + + let te = TextEdit (Range (Position 2 17) (Position 1 25)) "Dat" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 1 19) + let item = head $ filter ((== "Data.List") . (^. label)) compls + liftIO $ do + item ^. label @?= "Data.List" + item ^. detail @?= Just "Data.List" + item ^. kind @?= Just CiModule + + , testCase "completes language extensions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + + let te = TextEdit (Range (Position 0 24) (Position 0 31)) "" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 0 24) + let item = head $ filter ((== "OverloadedStrings") . (^. label)) compls + liftIO $ do + item ^. label @?= "OverloadedStrings" + item ^. kind @?= Just CiKeyword + + , testCase "completes pragmas" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + + let te = TextEdit (Range (Position 0 4) (Position 0 34)) "" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 0 4) + let item = head $ filter ((== "LANGUAGE") . (^. label)) compls + liftIO $ do + item ^. label @?= "LANGUAGE" + item ^. kind @?= Just CiKeyword + item ^. insertTextFormat @?= Just PlainText + item ^. insertText @?= Nothing + + , testCase "completes pragmas no close" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + + let te = TextEdit (Range (Position 0 4) (Position 0 24)) "" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 0 4) + let item = head $ filter ((== "LANGUAGE") . (^. label)) compls + liftIO $ do + item ^. label @?= "LANGUAGE" + item ^. kind @?= Just CiKeyword + item ^. insertTextFormat @?= Just PlainText + item ^. insertText @?= Nothing + + , testCase "completes options pragma" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + + let te = TextEdit (Range (Position 0 4) (Position 0 34)) "OPTIONS" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 0 4) + let item = head $ filter ((== "OPTIONS_GHC") . (^. label)) compls + liftIO $ do + item ^. label @?= "OPTIONS_GHC" + item ^. kind @?= Just CiKeyword + item ^. insertTextFormat @?= Just PlainText + item ^. insertText @?= Nothing + + , testCase "completes ghc options pragma values" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + + _ <- waitForDiagnosticsFrom doc + + let te = TextEdit (Range (Position 0 0) (Position 0 0)) "{-# OPTIONS_GHC -Wno-red #-}\n" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 0 24) + let item = head $ filter ((== "Wno-redundant-constraints") . (^. label)) compls + liftIO $ do + item ^. label @?= "Wno-redundant-constraints" + item ^. kind @?= Just CiKeyword + item ^. insertTextFormat @?= Nothing + item ^. insertText @?= Nothing + + , testCase "completes with no prefix" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + compls <- getCompletions doc (Position 5 7) + liftIO $ any ((== "!!") . (^. label)) compls @? "" + + -- See https://github.com/haskell/haskell-ide-engine/issues/903 + , testCase "strips compiler generated stuff from completions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "DupRecFields.hs" "haskell" + + let te = TextEdit (Range (Position 5 0) (Position 5 2)) "acc" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 4) + let item = head $ filter (\c -> c^.label == "accessor") compls + liftIO $ do + item ^. label @?= "accessor" + item ^. kind @?= Just CiFunction + + , testCase "have implicit foralls on basic polymorphic types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + let te = TextEdit (Range (Position 5 7) (Position 5 9)) "id" + _ <- applyEdit doc te + compls <- getCompletions doc (Position 5 9) + let item = head $ filter ((== "id") . (^. label)) compls + liftIO $ do + item ^. detail @?= Just ":: a -> a" + + , testCase "have implicit foralls with multiple type variables" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "flip" + _ <- applyEdit doc te + compls <- getCompletions doc (Position 5 11) + let item = head $ filter ((== "flip") . (^. label)) compls + liftIO $ + item ^. detail @?= Just ":: (a -> b -> c) -> b -> a -> c" + + , contextTests + , snippetTests ] --- snippetTests :: TestTree --- snippetTests = testGroup "snippets" [ --- testCase "work for argumentless constructors" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - --- let te = TextEdit (Range (Position 5 7) (Position 5 24)) "Nothing" --- _ <- applyEdit doc te - --- compls <- getCompletions doc (Position 5 14) --- let item = head $ filter ((== "Nothing") . (^. label)) compls --- liftIO $ do --- item ^. insertTextFormat @?= Just Snippet --- item ^. insertText @?= Just "Nothing" - --- , testCase "work for polymorphic types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - --- let te = TextEdit (Range (Position 5 7) (Position 5 24)) "fold" --- _ <- applyEdit doc te - --- compls <- getCompletions doc (Position 5 11) --- let item = head $ filter ((== "foldl") . (^. label)) compls --- resolvedRes <- request CompletionItemResolve item --- let Just (resolved :: CompletionItem) = resolvedRes ^. result --- liftIO $ do --- resolved ^. label @?= "foldl" --- resolved ^. kind @?= Just CiFunction --- resolved ^. insertTextFormat @?= Just Snippet --- resolved ^. insertText @?= Just "foldl ${1:b -> a -> b} ${2:b} ${3:t a}" - --- , testCase "work for complex types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - --- let te = TextEdit (Range (Position 5 7) (Position 5 24)) "mapM" --- _ <- applyEdit doc te - --- compls <- getCompletions doc (Position 5 11) --- let item = head $ filter ((== "mapM") . (^. label)) compls --- resolvedRes <- request CompletionItemResolve item --- let Just (resolved :: CompletionItem) = resolvedRes ^. result --- liftIO $ do --- resolved ^. label @?= "mapM" --- resolved ^. kind @?= Just CiFunction --- resolved ^. insertTextFormat @?= Just Snippet --- resolved ^. insertText @?= Just "mapM ${1:a -> m b} ${2:t a}" - --- , testCase "work for infix functions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - --- let te = TextEdit (Range (Position 5 7) (Position 5 24)) "even `filte" --- _ <- applyEdit doc te - --- compls <- getCompletions doc (Position 5 18) --- let item = head $ filter ((== "filter") . (^. label)) compls --- liftIO $ do --- item ^. label @?= "filter" --- item ^. kind @?= Just CiFunction --- item ^. insertTextFormat @?= Just Snippet --- item ^. insertText @?= Just "filter`" - --- , testCase "work for infix functions in backticks" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - --- let te = TextEdit (Range (Position 5 7) (Position 5 24)) "even `filte`" --- _ <- applyEdit doc te - --- compls <- getCompletions doc (Position 5 18) --- let item = head $ filter ((== "filter") . (^. label)) compls --- liftIO $ do --- item ^. label @?= "filter" --- item ^. kind @?= Just CiFunction --- item ^. insertTextFormat @?= Just Snippet --- item ^. insertText @?= Just "filter" - --- , testCase "work for qualified infix functions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - --- let te = TextEdit (Range (Position 5 7) (Position 5 24)) "\"\" `Data.List.interspe" --- _ <- applyEdit doc te - --- compls <- getCompletions doc (Position 5 29) --- let item = head $ filter ((== "intersperse") . (^. label)) compls --- liftIO $ do --- item ^. label @?= "intersperse" --- item ^. kind @?= Just CiFunction --- item ^. insertTextFormat @?= Just Snippet --- item ^. insertText @?= Just "intersperse`" - --- , testCase "work for qualified infix functions in backticks" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do --- doc <- openDoc "Completion.hs" "haskell" --- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - --- let te = TextEdit (Range (Position 5 7) (Position 5 24)) "\"\" `Data.List.interspe`" --- _ <- applyEdit doc te - --- compls <- getCompletions doc (Position 5 29) --- let item = head $ filter ((== "intersperse") . (^. label)) compls --- liftIO $ do --- item ^. label @?= "intersperse" --- item ^. kind @?= Just CiFunction --- item ^. insertTextFormat @?= Just Snippet --- item ^. insertText @?= Just "intersperse" - - -- -- TODO : Fix compile issue in the test "Variable not in scope: object" - -- , testCase "respects lsp configuration" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - -- doc <- openDoc "Completion.hs" "haskell" - -- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - - -- let config = object [ "haskell" .= (object ["completionSnippetsOn" .= False])] - - -- sendNotification WorkspaceDidChangeConfiguration - -- (DidChangeConfigurationParams config) - - -- checkNoSnippets doc - - -- , testCase "respects client capabilities" $ runSession hlsCommand noSnippetsCaps "test/testdata/completion" $ do - -- doc <- openDoc "Completion.hs" "haskell" - -- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - - -- checkNoSnippets doc - -- ] - -- where - -- checkNoSnippets doc = do - -- let te = TextEdit (Range (Position 5 7) (Position 5 24)) "fold" - -- _ <- applyEdit doc te - - -- compls <- getCompletions doc (Position 5 11) - -- let item = head $ filter ((== "foldl") . (^. label)) compls - -- liftIO $ do - -- item ^. label @?= "foldl" - -- item ^. kind @?= Just CiFunction - -- item ^. insertTextFormat @?= Just PlainText - -- item ^. insertText @?= Nothing - - -- resolvedRes <- request CompletionItemResolve item - -- let Just (resolved :: CompletionItem) = resolvedRes ^. result - -- liftIO $ do - -- resolved ^. label @?= "foldl" - -- resolved ^. kind @?= Just CiFunction - -- resolved ^. insertTextFormat @?= Just PlainText - -- resolved ^. insertText @?= Nothing - - -- noSnippetsCaps = - -- ( textDocument - -- . _Just - -- . completion - -- . _Just - -- . completionItem - -- . _Just - -- . snippetSupport - -- ?~ False - -- ) - -- fullCaps +snippetTests :: TestTree +snippetTests = testGroup "snippets" [ + ignoreTestBecause "no support for snippets" $ + testCase "work for argumentless constructors" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "Nothing" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 14) + let item = head $ filter ((== "Nothing") . (^. label)) compls + liftIO $ do + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "Nothing" + + , ignoreTestBecause "no support for snippets" $ + testCase "work for polymorphic types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "fold" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 11) + let item = head $ filter ((== "foldl") . (^. label)) compls + liftIO $ do + item ^. label @?= "foldl" + item ^. kind @?= Just CiFunction + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "foldl ${1:b -> a -> b} ${2:b} ${3:t a}" + + , ignoreTestBecause "no support for snippets" $ + testCase "work for complex types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "mapM" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 11) + let item = head $ filter ((== "mapM") . (^. label)) compls + liftIO $ do + item ^. label @?= "mapM" + item ^. kind @?= Just CiFunction + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "mapM ${1:a -> m b} ${2:t a}" + + , ignoreTestBecause "no support for snippets" $ + testCase "work for infix functions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "even `filte" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 18) + let item = head $ filter ((== "filter") . (^. label)) compls + liftIO $ do + item ^. label @?= "filter" + item ^. kind @?= Just CiFunction + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "filter`" + + , ignoreTestBecause "no support for snippets" $ + testCase "work for infix functions in backticks" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "even `filte`" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 18) + let item = head $ filter ((== "filter") . (^. label)) compls + liftIO $ do + item ^. label @?= "filter" + item ^. kind @?= Just CiFunction + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "filter" + + , ignoreTestBecause "no support for snippets" $ + testCase "work for qualified infix functions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "\"\" `Data.List.interspe" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 29) + let item = head $ filter ((== "intersperse") . (^. label)) compls + liftIO $ do + item ^. label @?= "intersperse" + item ^. kind @?= Just CiFunction + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "intersperse`" + + , ignoreTestBecause "no support for snippets" $ + testCase "work for qualified infix functions in backticks" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "\"\" `Data.List.interspe`" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 29) + let item = head $ filter ((== "intersperse") . (^. label)) compls + liftIO $ do + item ^. label @?= "intersperse" + item ^. kind @?= Just CiFunction + item ^. insertTextFormat @?= Just Snippet + item ^. insertText @?= Just "intersperse" + + , testCase "respects lsp configuration" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + + let config = object [ "haskell" .= (object ["completionSnippetsOn" .= False])] + + sendNotification WorkspaceDidChangeConfiguration + (DidChangeConfigurationParams config) + + checkNoSnippets doc + + , testCase "respects client capabilities" $ runSession hlsCommand noSnippetsCaps "test/testdata/completion" $ do + doc <- openDoc "Completion.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + + checkNoSnippets doc + ] + where + checkNoSnippets doc = do + let te = TextEdit (Range (Position 5 7) (Position 5 24)) "fold" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 5 11) + let item = head $ filter ((== "foldl") . (^. label)) compls + liftIO $ do + item ^. label @?= "foldl" + item ^. kind @?= Just CiFunction + item ^. insertTextFormat @?= Just PlainText + item ^. insertText @?= Nothing + + noSnippetsCaps = + ( textDocument + . _Just + . completion + . _Just + . completionItem + . _Just + . snippetSupport + ?~ False + ) + fullCaps contextTests :: TestTree contextTests = testGroup "contexts" [ - ignoreTestBecause "Broken: Timed out waiting to receive a message from the server" $ testCase "only provides type suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Context.hs" "haskell" - _ <- count 2 $ skipManyTill loggingNotification noDiagnostics + _ <- waitForDiagnosticsFrom doc compls <- getCompletions doc (Position 2 17) liftIO $ do compls `shouldContainCompl` "Integer" compls `shouldNotContainCompl` "interact" - , ignoreTestBecause "Broken: Timed out waiting to receive a message from the server" $ - testCase "only provides type suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + , testCase "only provides value suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Context.hs" "haskell" - _ <- count 2 $ skipManyTill loggingNotification noDiagnostics + _ <- waitForDiagnosticsFrom doc compls <- getCompletions doc (Position 3 9) liftIO $ do compls `shouldContainCompl` "abs" compls `shouldNotContainCompl` "Applicative" - -- This currently fails if , testCase takes too long to typecheck the module - -- , testCase "completes qualified type suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do - -- doc <- openDoc "Context.hs" "haskell" - -- _ <- count 2 $ skipManyTill loggingNotification noDiagnostics - -- let te = TextEdit (Range (Position 2 17) (Position 2 17)) " -> Conc." - -- _ <- applyEdit doc te - -- compls <- getCompletions doc (Position 2 26) - -- liftIO $ do - -- compls `shouldNotContainCompl` "forkOn" - -- compls `shouldContainCompl` "MVar" - -- compls `shouldContainCompl` "Chan" + , testCase "completes qualified type suggestions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "Context.hs" "haskell" + _ <- waitForDiagnosticsFrom doc + let te = TextEdit (Range (Position 2 17) (Position 2 17)) " -> Conc." + _ <- applyEdit doc te + -- The module doesn't parse right now. So we are using stale data. HLS + -- can give us completions for "Conc." but it can't tell that we are in + -- a context where we expect a type. + compls <- getCompletions doc (Position 2 26) + liftIO $ do + -- forkOn is an inappropriate completion in a type context. + compls `shouldContainCompl` "forkOn" + compls `shouldContainCompl` "MVar" + compls `shouldContainCompl` "Chan" + let te' = TextEdit (Range (Position 2 26) (Position 2 26)) "MVar" + _ <- applyEdit doc te' + -- The module can now be parsed. Wait until it has been. + _ <- waitForDiagnosticsFrom doc + -- HLS can see that we are expecting a type. + compls' <- getCompletions doc (Position 2 26) + liftIO $ do + -- forkOn is gone. + compls' `shouldNotContainCompl` "forkOn" + compls' `shouldContainCompl` "MVar" + compls' `shouldContainCompl` "Chan" ] - where - compls `shouldContainCompl` x = - null (filter ((== x) . (^. label)) compls) @? "Should contain completion" - compls `shouldNotContainCompl` x = - null (filter ((== x) . (^. label)) compls) @? "Should not contain completion" + +shouldContainCompl :: [CompletionItem] -> T.Text -> Assertion +compls `shouldContainCompl` x = + any ((== x) . (^. label)) compls + @? "Should contain completion: " ++ show x + +shouldNotContainCompl :: [CompletionItem] -> T.Text -> Assertion +compls `shouldNotContainCompl` x = + all ((/= x) . (^. label)) compls + @? "Should not contain completion: " ++ show x diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index f1ad9a9f4a..c40454312b 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -444,61 +444,8 @@ unusedTermTests = testGroup "unused term code actions" [ all (Just CodeActionRefactorInline ==) kinds @? "All CodeActionRefactorInline" ] -fromAction :: CAResult -> CodeAction -fromAction (CACodeAction action) = action -fromAction _ = error "Not a code action" - -fromCommand :: CAResult -> Command -fromCommand (CACommand command) = command -fromCommand _ = error "Not a command" - noLiteralCaps :: C.ClientCapabilities noLiteralCaps = def { C._textDocument = Just textDocumentCaps } where textDocumentCaps = def { C._codeAction = Just codeActionCaps } codeActionCaps = C.CodeActionClientCapabilities (Just True) Nothing - -onMatch :: [a] -> (a -> Bool) -> String -> IO a -onMatch as pred err = maybe (fail err) return (find pred as) - -inspectDiagnostic :: [Diagnostic] -> [T.Text] -> IO Diagnostic -inspectDiagnostic diags s = onMatch diags (\ca -> all (`T.isInfixOf` (ca ^. L.message)) s) err - where err = "expected diagnostic matching '" ++ show s ++ "' but did not find one" - -expectDiagnostic :: [Diagnostic] -> [T.Text] -> IO () -expectDiagnostic diags s = void $ inspectDiagnostic diags s - -inspectCodeAction :: [CAResult] -> [T.Text] -> IO CodeAction -inspectCodeAction cars s = fromAction <$> onMatch cars pred err - where pred (CACodeAction ca) = all (`T.isInfixOf` (ca ^. L.title)) s - pred _ = False - err = "expected code action matching '" ++ show s ++ "' but did not find one" - -expectCodeAction :: [CAResult] -> [T.Text] -> IO () -expectCodeAction cars s = void $ inspectCodeAction cars s - -inspectCommand :: [CAResult] -> [T.Text] -> IO Command -inspectCommand cars s = fromCommand <$> onMatch cars pred err - where pred (CACommand command) = all (`T.isInfixOf` (command ^. L.title)) s - pred _ = False - err = "expected code action matching '" ++ show s ++ "' but did not find one" - -waitForDiagnosticsFrom :: TextDocumentIdentifier -> Session [Diagnostic] -waitForDiagnosticsFrom doc = do - diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification - let (List diags) = diagsNot ^. L.params . L.diagnostics - if doc ^. L.uri /= diagsNot ^. L.params . L.uri - then waitForDiagnosticsFrom doc - else return diags - -waitForDiagnosticsFromSource :: TextDocumentIdentifier -> String -> Session [Diagnostic] -waitForDiagnosticsFromSource doc src = do - diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification - let (List diags) = diagsNot ^. L.params . L.diagnostics - let res = filter matches diags - if doc ^. L.uri /= diagsNot ^. L.params . L.uri || null res - then waitForDiagnosticsFromSource doc src - else return res - where - matches :: Diagnostic -> Bool - matches d = d ^. L.source == Just (T.pack src) diff --git a/test/testdata/completion/hie.yaml b/test/testdata/completion/hie.yaml new file mode 100644 index 0000000000..999dc1a77f --- /dev/null +++ b/test/testdata/completion/hie.yaml @@ -0,0 +1,6 @@ +cradle: + direct: + arguments: + - "Completion" + - "Context" + - "DupRecFields" diff --git a/test/utils/Test/Hls/Util.hs b/test/utils/Test/Hls/Util.hs index d352f1f225..69a338c9b7 100644 --- a/test/utils/Test/Hls/Util.hs +++ b/test/utils/Test/Hls/Util.hs @@ -3,28 +3,42 @@ module Test.Hls.Util ( codeActionSupportCaps , dummyLspFuncs + , expectCodeAction + , expectDiagnostic , flushStackEnvironment + , fromAction + , fromCommand , getHspecFormattedConfig , ghcVersion, GhcVersion(..) , hlsCommand , hlsCommandExamplePlugin , hlsCommandVomit + , inspectCodeAction + , inspectCommand + , inspectDiagnostic , logConfig , logFilePath , noLogConfig , setupBuildToolFiles + , waitForDiagnosticsFrom + , waitForDiagnosticsFromSource , withFileLogging , withCurrentDirectoryInTmp ) where import Control.Monad +import Control.Applicative.Combinators (skipManyTill) +import Control.Lens ((^.)) import Data.Default import Data.List (intercalate) +import Data.List.Extra (find) import Data.Maybe +import qualified Data.Text as T import Language.Haskell.LSP.Core import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Test as T +import qualified Language.Haskell.LSP.Types.Lens as L import qualified Language.Haskell.LSP.Types.Capabilities as C import System.Directory import System.Environment @@ -35,7 +49,7 @@ import System.IO.Unsafe import Test.Hspec.Runner import Test.Hspec.Core.Formatters import Text.Blaze.Renderer.String (renderMarkup) -import Text.Blaze.Internal +import Text.Blaze.Internal hiding (null) noLogConfig :: T.SessionConfig @@ -282,3 +296,56 @@ copyDir src dst = do then createDirectory dstFp >> copyDir srcFp dstFp else copyFile srcFp dstFp where ignored = ["dist", "dist-newstyle", ".stack-work"] + +fromAction :: CAResult -> CodeAction +fromAction (CACodeAction action) = action +fromAction _ = error "Not a code action" + +fromCommand :: CAResult -> Command +fromCommand (CACommand command) = command +fromCommand _ = error "Not a command" + +onMatch :: [a] -> (a -> Bool) -> String -> IO a +onMatch as predicate err = maybe (fail err) return (find predicate as) + +inspectDiagnostic :: [Diagnostic] -> [T.Text] -> IO Diagnostic +inspectDiagnostic diags s = onMatch diags (\ca -> all (`T.isInfixOf` (ca ^. L.message)) s) err + where err = "expected diagnostic matching '" ++ show s ++ "' but did not find one" + +expectDiagnostic :: [Diagnostic] -> [T.Text] -> IO () +expectDiagnostic diags s = void $ inspectDiagnostic diags s + +inspectCodeAction :: [CAResult] -> [T.Text] -> IO CodeAction +inspectCodeAction cars s = fromAction <$> onMatch cars predicate err + where predicate (CACodeAction ca) = all (`T.isInfixOf` (ca ^. L.title)) s + predicate _ = False + err = "expected code action matching '" ++ show s ++ "' but did not find one" + +expectCodeAction :: [CAResult] -> [T.Text] -> IO () +expectCodeAction cars s = void $ inspectCodeAction cars s + +inspectCommand :: [CAResult] -> [T.Text] -> IO Command +inspectCommand cars s = fromCommand <$> onMatch cars predicate err + where predicate (CACommand command) = all (`T.isInfixOf` (command ^. L.title)) s + predicate _ = False + err = "expected code action matching '" ++ show s ++ "' but did not find one" + +waitForDiagnosticsFrom :: TextDocumentIdentifier -> T.Session [Diagnostic] +waitForDiagnosticsFrom doc = do + diagsNot <- skipManyTill T.anyMessage T.message :: T.Session PublishDiagnosticsNotification + let (List diags) = diagsNot ^. L.params . L.diagnostics + if doc ^. L.uri /= diagsNot ^. L.params . L.uri + then waitForDiagnosticsFrom doc + else return diags + +waitForDiagnosticsFromSource :: TextDocumentIdentifier -> String -> T.Session [Diagnostic] +waitForDiagnosticsFromSource doc src = do + diagsNot <- skipManyTill T.anyMessage T.message :: T.Session PublishDiagnosticsNotification + let (List diags) = diagsNot ^. L.params . L.diagnostics + let res = filter matches diags + if doc ^. L.uri /= diagsNot ^. L.params . L.uri || null res + then waitForDiagnosticsFromSource doc src + else return res + where + matches :: Diagnostic -> Bool + matches d = d ^. L.source == Just (T.pack src)