From 662a9fe97821755a222a66340a31ca803510c292 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 24 Mar 2024 03:48:32 +0800 Subject: [PATCH 01/34] add core plugin --- .../Development/IDE/LSP/HoverDefinition.hs | 6 +- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 3 +- ghcide/test/exe/InitializeResponseTests.hs | 2 +- haskell-language-server.cabal | 79 ++++++++++ plugins/hls-core-plugin/README.md | 66 ++++++++ .../hls-core-plugin/src/Ide/Plugin/Core.hs | 40 +++++ plugins/hls-core-plugin/test/CoreTest.hs | 14 ++ .../test/exe/InitializeResponseTests.hs | 144 ++++++++++++++++++ .../hls-core-plugin/test/testdata/T1.expected | 81 ++++++++++ plugins/hls-core-plugin/test/testdata/T1.hs | 48 ++++++ .../test/testdata/TClass.expected | 5 + .../hls-core-plugin/test/testdata/TClass.hs | 6 + .../testdata/TClassImportedDeriving.expected | 3 + .../test/testdata/TClassImportedDeriving.hs | 10 ++ .../test/testdata/TDataFamily.expected | 12 ++ .../test/testdata/TDataFamily.hs | 11 ++ .../test/testdata/TDataType.expected | 4 + .../test/testdata/TDataType.hs | 3 + .../test/testdata/TDatatypeImported.expected | 5 + .../test/testdata/TDatatypeImported.hs | 6 + .../test/testdata/TDoc.expected | 5 + plugins/hls-core-plugin/test/testdata/TDoc.hs | 9 ++ .../test/testdata/TFunction.expected | 11 ++ .../test/testdata/TFunction.hs | 7 + .../test/testdata/TFunctionLet.expected | 5 + .../test/testdata/TFunctionLet.hs | 4 + .../test/testdata/TFunctionLocal.expected | 7 + .../test/testdata/TFunctionLocal.hs | 8 + .../TFunctionUnderTypeSynonym.expected | 17 +++ .../testdata/TFunctionUnderTypeSynonym.hs | 9 ++ .../test/testdata/TGADT.expected | 13 ++ .../hls-core-plugin/test/testdata/TGADT.hs | 7 + .../TInstanceClassMethodBind.expected | 7 + .../test/testdata/TInstanceClassMethodBind.hs | 6 + .../testdata/TInstanceClassMethodUse.expected | 2 + .../test/testdata/TInstanceClassMethodUse.hs | 5 + .../hls-core-plugin/test/testdata/TModuleA.hs | 5 + .../hls-core-plugin/test/testdata/TModuleB.hs | 8 + .../TNoneFunctionWithConstraint.expected | 6 + .../testdata/TNoneFunctionWithConstraint.hs | 5 + .../test/testdata/TOperator.expected | 33 ++++ .../test/testdata/TOperator.hs | 13 ++ .../test/testdata/TPatternMatch.expected | 2 + .../test/testdata/TPatternMatch.hs | 6 + .../test/testdata/TPatternSynonym.expected | 1 + .../test/testdata/TPatternSynonym.hs | 7 + .../test/testdata/TPatternbind.expected | 7 + .../test/testdata/TPatternbind.hs | 9 ++ .../test/testdata/TQualifiedName.expected | 12 ++ .../test/testdata/TQualifiedName.hs | 9 ++ .../test/testdata/TRecord.expected | 4 + .../hls-core-plugin/test/testdata/TRecord.hs | 7 + .../TRecordDuplicateRecordFields.expected | 4 + .../testdata/TRecordDuplicateRecordFields.hs | 5 + .../test/testdata/TTypefamily.expected | 8 + .../test/testdata/TTypefamily.hs | 6 + .../test/testdata/TUnicodeSyntax.expected | 1 + .../test/testdata/TUnicodeSyntax.hs | 5 + .../test/testdata/TValBind.expected | 4 + .../hls-core-plugin/test/testdata/TValBind.hs | 8 + src/HlsPlugins.hs | 2 + 61 files changed, 839 insertions(+), 8 deletions(-) create mode 100644 plugins/hls-core-plugin/README.md create mode 100644 plugins/hls-core-plugin/src/Ide/Plugin/Core.hs create mode 100644 plugins/hls-core-plugin/test/CoreTest.hs create mode 100644 plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs create mode 100644 plugins/hls-core-plugin/test/testdata/T1.expected create mode 100644 plugins/hls-core-plugin/test/testdata/T1.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TClass.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TClass.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TClassImportedDeriving.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TClassImportedDeriving.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TDataFamily.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TDataFamily.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TDataType.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TDataType.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TDatatypeImported.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TDatatypeImported.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TDoc.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TDoc.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TFunction.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TFunction.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TFunctionLet.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TFunctionLet.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TFunctionLocal.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TFunctionLocal.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TFunctionUnderTypeSynonym.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TFunctionUnderTypeSynonym.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TGADT.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TGADT.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TInstanceClassMethodBind.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TInstanceClassMethodBind.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TInstanceClassMethodUse.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TInstanceClassMethodUse.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TModuleA.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TModuleB.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TNoneFunctionWithConstraint.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TNoneFunctionWithConstraint.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TOperator.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TOperator.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TPatternMatch.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TPatternMatch.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TPatternSynonym.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TPatternSynonym.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TPatternbind.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TPatternbind.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TQualifiedName.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TQualifiedName.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TRecord.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TRecord.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TRecordDuplicateRecordFields.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TRecordDuplicateRecordFields.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TTypefamily.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TTypefamily.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TUnicodeSyntax.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TUnicodeSyntax.hs create mode 100644 plugins/hls-core-plugin/test/testdata/TValBind.expected create mode 100644 plugins/hls-core-plugin/test/testdata/TValBind.hs diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index c561243bf7..1aa531293e 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -11,7 +11,7 @@ module Development.IDE.LSP.HoverDefinition , gotoTypeDefinition , documentHighlight , references - , wsSymbols + -- , wsSymbols ) where import Control.Monad.Except (ExceptT) @@ -47,10 +47,6 @@ references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do " in file: " <> T.pack (show nfp) InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos) -wsSymbols :: PluginMethodHandler IdeState Method_WorkspaceSymbol -wsSymbols ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do - logDebug (ideLogger ide) $ "Workspace symbols request: " <> query - runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ InL . fromMaybe [] <$> workspaceSymbols query foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null foundHover (mbRange, contents) = diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index b3c7457275..bdd3ab222d 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -51,8 +51,7 @@ descriptor plId = (defaultPluginDescriptor plId desc) gotoTypeDefinition ide TextDocumentPositionParams{..}) <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> documentHighlight ide TextDocumentPositionParams{..}) - <> mkPluginHandler SMethod_TextDocumentReferences references - <> mkPluginHandler SMethod_WorkspaceSymbol wsSymbols, + <> mkPluginHandler SMethod_TextDocumentReferences references, pluginConfigDescriptor = defaultConfigDescriptor } diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs index a980efc12d..e4a47838aa 100644 --- a/ghcide/test/exe/InitializeResponseTests.hs +++ b/ghcide/test/exe/InitializeResponseTests.hs @@ -47,7 +47,7 @@ tests = withResource acquire release tests where , chk " find references" _referencesProvider (Just $ InR (ReferenceOptions (Just False))) , chk " doc highlight" _documentHighlightProvider (Just $ InR (DocumentHighlightOptions (Just False))) , chk " doc symbol" _documentSymbolProvider (Just $ InR (DocumentSymbolOptions (Just False) Nothing)) - , chk " workspace symbol" _workspaceSymbolProvider (Just $ InR (WorkspaceSymbolOptions (Just False) (Just False))) + -- , chk " workspace symbol" _workspaceSymbolProvider (Just $ InR (WorkspaceSymbolOptions (Just False) (Just False))) , chk "NO code action" _codeActionProvider Nothing , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just True)) , chk "NO doc formatting" _documentFormattingProvider Nothing diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index ad3b6ea097..d128eb5591 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1705,6 +1705,84 @@ test-suite hls-refactor-plugin-tests , tasty-expected-failure , tasty +----------------------------- +-- core plugin +----------------------------- + +-- flag semanticTokens +-- description: Enable semantic tokens plugin +-- default: True +-- manual: True + +common core + build-depends: haskell-language-server:hls-core-plugin + +library hls-core-plugin + import: defaults, pedantic, warnings + buildable: True + exposed-modules: + Ide.Plugin.Core + + hs-source-dirs: plugins/hls-core-plugin/src + build-depends: + , base >=4.12 && <5 + , containers + , extra + , text-rope + , mtl >= 2.2 + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , lens + , lsp >=2.4 + , text + , transformers + , bytestring + , syb + , array + , deepseq + , dlist + , hls-graph == 2.7.0.0 + , template-haskell + , data-default + , stm + , stm-containers + + default-extensions: DataKinds + +test-suite hls-core-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-core-plugin/test + , plugins/hls-core-plugin/test/exe + main-is: CoreTest.hs + other-modules: + InitializeResponseTests + + build-depends: + , aeson + , base + , containers + , filepath + , haskell-language-server:hls-core-plugin + , hls-test-utils == 2.7.0.0 + , ghcide:ghcide-test-utils + , hls-plugin-api + , lens + , lsp + , text-rope + , lsp-test + , text + , tasty + , tasty-hunit + , data-default + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , data-default + , row-types + , extra + , hls-test-utils + + ----------------------------- -- semantic tokens plugin ----------------------------- @@ -1886,6 +1964,7 @@ library , overloadedRecordDot , semanticTokens , notes + , core exposed-modules: Ide.Arguments diff --git a/plugins/hls-core-plugin/README.md b/plugins/hls-core-plugin/README.md new file mode 100644 index 0000000000..5d6be35ef5 --- /dev/null +++ b/plugins/hls-core-plugin/README.md @@ -0,0 +1,66 @@ +# Semantic tokens (LSP) plugin for Haskell language server + +## Purpose + +The purpose of this plugin is to provide semantic tokens for the Haskell language server, +according to the [LSP specification](https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens) +It can be used to provide semantic highlighting for Haskell code in editors by given semantic type and modifiers for some tokens. +A lot of editors support semantic highlighting through LSP, for example vscode, vim, emacs, etc. + +## Features + +### Semantic types and modifiers + +The handles request for semantic tokens for the whole file. +It supports semantic types and but not yet modifiers from the LSP specification. + +Default semantic types defined in lsp diverge greatly from the ones used in ghc. +But default semantic types allows user with less configuration to get semantic highlighting. +That is why we use default semantic types for now. By mapping ghc semantic types to lsp semantic types. +The mapping is defined in `Mapping.hs` file. + +### delta semantic tokens, range semantic tokens and refresh + +It is not yet support capabilities for delta semantic tokens, which might be +crucial for performance. +It should be implemented in the future. + +## checkList + +* Supported PluginMethodHandler + * [x] [textDocument/semanticTokens/full](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#semanticTokens_fullRequest). + * [ ] [textDocument/semanticTokens/full/delta](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#semanticTokens_deltaRequest) + * [ ] [workspace/semanticTokens/refresh](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#semanticTokens_refreshRequest) + +* Supported semantic tokens type: + * [x] class and class method + * [x] type family name (data family) + * [x] data constructor name (not distinguishing record and normal data, and GADT) + * [x] type constructor name (GADT) + * [x] record field name + * [x] type synonym + * [x] pattern synonym + * [x] ~~pattern bindings~~ In favor of differing functions and none-functions from its type + * [x] ~~value bindings~~ In favor of differing functions and none-functions from its type + * [x] functions + * [x] none-function variables + * [x] imported name + +* Supported modifiers(planning): + * [future] declaration (as in class declearations, type definition and type family) + * [future] definition (as in class instance declaration, left hand side value binding, and type family instance) + * [future] modification (as in rec field update) + +## Implementation details + +* [x] Compute visible names from renamedsource +* [x] Compute `NameSemanticMap` for imported and top level name tokens using `HscEnv`(with deps) and type checked result +* [x] Compute current module `NameSemanticMap` using `RefMap a` from the result of `GetHieAst` +* [x] Compute all visible `(Name, Span)` in current module, in turn compute their semantic token using the combination map of the above two `NameSemanticMap` +* [x] use default legends, Candidates map of token type with default token type: [Maps to default token types](https://github.com/soulomoon/haskell-language-server/blob/master/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs) +* [x] add args support to turn the plugin on and off +* [x] enhence test +* [x] enhence error reporting. +* [x] computation of semantic tokens is pushed into rule `getSemanticTokensRule` +* [future] make use of modifiers +* [future] hadling customize legends using server capabilities (how?) diff --git a/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs b/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs new file mode 100644 index 0000000000..e09a902e40 --- /dev/null +++ b/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module Ide.Plugin.Core(descriptor, CoreLog) where + +import Control.Monad.IO.Class (liftIO) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Development.IDE +import Development.IDE.Core.Actions (workspaceSymbols) +import qualified Development.IDE.Core.Shake as Shake +import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types (WorkspaceSymbolParams (..), + type (|?) (InL)) + +data CoreLog + = LogShake Shake.Log + | CoreLogMsg Text + +instance Pretty CoreLog where + pretty theLog = case theLog of + LogShake shakeLog -> pretty shakeLog + CoreLogMsg msg -> "Core Message: " <> pretty msg + + + +descriptor :: Recorder (WithPriority CoreLog) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = + (defaultPluginDescriptor plId "Provides core IDE features for Haskell") + { + Ide.Types.pluginHandlers = mkPluginHandler SMethod_WorkspaceSymbol (wsSymbols recorder) + } + + + +wsSymbols :: Recorder (WithPriority CoreLog) -> PluginMethodHandler IdeState Method_WorkspaceSymbol +wsSymbols logger ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do + logWith logger Debug $ CoreLogMsg $ "Workspace symbols request: " <> query + runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ InL . fromMaybe [] <$> workspaceSymbols query diff --git a/plugins/hls-core-plugin/test/CoreTest.hs b/plugins/hls-core-plugin/test/CoreTest.hs new file mode 100644 index 0000000000..6d52da2278 --- /dev/null +++ b/plugins/hls-core-plugin/test/CoreTest.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +import qualified InitializeResponseTests +import Test.Hls (defaultTestRunner, testGroup) + + +main :: IO () +main = + defaultTestRunner $ + testGroup + "core" + [ InitializeResponseTests.tests ] diff --git a/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs b/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs new file mode 100644 index 0000000000..2faf5da954 --- /dev/null +++ b/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs @@ -0,0 +1,144 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module InitializeResponseTests (tests) where + +import Control.Monad +import Data.List.Extra +import Data.Row +import qualified Data.Text as T +import Development.IDE.Plugin.TypeLenses (typeLensCommandId) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +-- import qualified Language.LSP.Protocol.Types hiding +-- (SemanticTokenAbsolute (..), +-- SemanticTokenRelative (..), +-- SemanticTokensEdit (..), +-- mkRange) +import Language.LSP.Test + +import Control.Lens ((^.)) +import Data.Default (def) +import Data.Text (Text) +import qualified Data.Text as Text +import Development.IDE.Plugin.Test (blockCommandId) +import qualified Ide.Plugin.Core as Core +import Language.LSP.Protocol.Types (CodeLensOptions (..), + CompletionOptions (..), + DefinitionOptions (DefinitionOptions), + DocumentHighlightOptions (..), + DocumentSymbolOptions (..), + ExecuteCommandOptions (..), + HoverOptions (..), + InitializeResult (..), + ReferenceOptions (..), + SaveOptions (..), + ServerCapabilities (..), + TextDocumentSyncKind (..), + TextDocumentSyncOptions (..), + TypeDefinitionOptions (..), + WorkspaceFoldersServerCapabilities (..), + WorkspaceSymbolOptions (..), + type (|?) (..)) +import System.FilePath (()) +import Test.Hls (PluginTestDescriptor, + mkPluginTestDescriptor, + runSessionWithServerInTmpDir) +import qualified Test.Hls.FileSystem as FS +import Test.Hls.FileSystem (file, text) +import Test.Tasty +import Test.Tasty.HUnit + +corePlugin :: PluginTestDescriptor Core.CoreLog +corePlugin = mkPluginTestDescriptor Core.descriptor "core" + +tests :: TestTree +tests = withResource acquire release tests where + + -- these tests document and monitor the evolution of the + -- capabilities announced by the server in the initialize + -- response. Currently the server advertises almost no capabilities + -- at all, in some cases failing to announce capabilities that it + -- actually does provide! Hopefully this will change ... + tests :: IO (TResponseMessage Method_Initialize) -> TestTree + tests getInitializeResponse = + testGroup "initialize response capabilities" + [ + chk " text doc sync" _textDocumentSync tds + , chk " hover" _hoverProvider (Just $ InR (HoverOptions (Just False))) + , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing (Just True) Nothing) + , chk "NO signature help" _signatureHelpProvider Nothing + , chk " goto definition" _definitionProvider (Just $ InR (DefinitionOptions (Just False))) + , chk " goto type definition" _typeDefinitionProvider (Just $ InR (InL (TypeDefinitionOptions (Just False)))) + -- BUG in lsp-test, this test fails, just change the accepted response + -- for now + , chk "NO goto implementation" _implementationProvider Nothing + , chk " find references" _referencesProvider (Just $ InR (ReferenceOptions (Just False))) + , chk " doc highlight" _documentHighlightProvider (Just $ InR (DocumentHighlightOptions (Just False))) + , chk " doc symbol" _documentSymbolProvider (Just $ InR (DocumentSymbolOptions (Just False) Nothing)) + , chk " workspace symbol" _workspaceSymbolProvider (Just $ InR (WorkspaceSymbolOptions (Just False) (Just False))) + , chk "NO code action" _codeActionProvider Nothing + , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just True)) + , chk "NO doc formatting" _documentFormattingProvider Nothing + , chk "NO doc range formatting" + _documentRangeFormattingProvider Nothing + , chk "NO doc formatting on typing" + _documentOnTypeFormattingProvider Nothing + , chk "NO renaming" _renameProvider Nothing + , chk "NO doc link" _documentLinkProvider Nothing + , chk "NO color" (^. L.colorProvider) Nothing + , chk "NO folding range" _foldingRangeProvider Nothing + , che " execute command" _executeCommandProvider [typeLensCommandId, blockCommandId] + , chk " workspace" (^. L.workspace) (Just $ #workspaceFolders .== Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )} + .+ #fileOperations .== Nothing) + , chk "NO experimental" (^. L.experimental) Nothing + ] where + + tds = Just (InL (TextDocumentSyncOptions + { _openClose = Just True + , _change = Just TextDocumentSyncKind_Incremental + , _willSave = Nothing + , _willSaveWaitUntil = Nothing + , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) + + chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree + chk title getActual expected = + testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir + + che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree + che title getActual expected = testCase title $ do + ir <- getInitializeResponse + ExecuteCommandOptions {_commands = commands} <- case getActual $ innerCaps ir of + Just eco -> pure eco + Nothing -> assertFailure "Was expecting Just ExecuteCommandOptions, got Nothing" + let commandNames = (!! 2) . T.splitOn ":" <$> commands + zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames) + + innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities + innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c + innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error" + + acquire :: IO (TResponseMessage Method_Initialize) + acquire = do + let content = Text.unlines ["module Hello where", "go _ = 1"] + let fs = mkFs $ directFile "Hello.hs" content + runSessionWithServerInTmpDir def corePlugin fs initializeResponse + + + release :: TResponseMessage Method_Initialize -> IO () + release = mempty + +directFile :: FilePath -> Text -> [FS.FileTree] +directFile fp content = + [ FS.directCradle [Text.pack fp] + , file fp (text content) + ] + +mkFs :: [FS.FileTree] -> FS.VirtualFileTree +mkFs = FS.mkVirtualFileTree testDataDir + +testDataDir :: FilePath +testDataDir = "plugins" "core-plugin" "test" "testdata" + diff --git a/plugins/hls-core-plugin/test/testdata/T1.expected b/plugins/hls-core-plugin/test/testdata/T1.expected new file mode 100644 index 0000000000..cbf7699f19 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/T1.expected @@ -0,0 +1,81 @@ +9:6-9 TTypeConstructor "Foo" +9:12-15 TDataConstructor "Foo" +9:18-21 TRecordField "foo" +9:25-28 TTypeConstructor "Int" +11:7-10 TClass "Boo" +11:11-12 TTypeVariable "a" +12:3-6 TClassMethod "boo" +12:10-11 TTypeVariable "a" +12:15-16 TTypeVariable "a" +14:10-13 TClass "Boo" +14:14-17 TTypeConstructor "Int" +15:5-8 TClassMethod "boo" +15:9-10 TVariable "x" +15:13-14 TVariable "x" +15:15-16 TOperator "+" +17:6-8 TTypeConstructor "Dd" +17:11-13 TDataConstructor "Dd" +17:14-17 TTypeConstructor "Int" +19:9-12 TPatternSynonym "One" +19:15-18 TDataConstructor "Foo" +21:1-4 TVariable "ggg" +21:7-10 TPatternSynonym "One" +23:6-9 TTypeConstructor "Doo" +23:12-15 TDataConstructor "Doo" +23:16-24 TModule "Prelude." +23:24-27 TTypeConstructor "Int" +24:6-10 TTypeSynonym "Bar1" +24:13-16 TTypeConstructor "Int" +25:6-10 TTypeSynonym "Bar2" +25:13-16 TTypeConstructor "Doo" +27:1-3 TFunction "bb" +27:8-11 TClass "Boo" +27:12-13 TTypeVariable "a" +27:18-19 TTypeVariable "a" +27:23-24 TTypeVariable "a" +28:1-3 TFunction "bb" +28:4-5 TVariable "x" +28:9-12 TClassMethod "boo" +28:13-14 TVariable "x" +29:1-3 TFunction "aa" +29:7-11 TTypeVariable "cool" +29:15-18 TTypeConstructor "Int" +29:22-26 TTypeVariable "cool" +30:1-3 TFunction "aa" +30:4-5 TVariable "x" +30:9-10 TVariable "c" +30:14-16 TFunction "aa" +30:17-18 TVariable "x" +30:19-20 TVariable "c" +31:12-14 TVariable "xx" +31:16-18 TVariable "yy" +32:11-13 TVariable "dd" +34:2-4 TVariable "zz" +34:6-8 TVariable "kk" +35:1-3 TFunction "cc" +35:7-10 TTypeConstructor "Foo" +35:15-18 TTypeConstructor "Int" +35:20-23 TTypeConstructor "Int" +35:28-31 TTypeConstructor "Int" +36:1-3 TFunction "cc" +36:4-5 TVariable "f" +36:7-9 TVariable "gg" +36:11-13 TVariable "vv" +37:10-12 TVariable "gg" +38:14-17 TRecordField "foo" +38:18-19 TOperator "$" +38:20-21 TVariable "f" +38:24-27 TRecordField "foo" +39:14-17 TRecordField "foo" +39:18-19 TOperator "$" +39:20-21 TVariable "f" +39:24-27 TRecordField "foo" +41:1-3 TFunction "go" +41:6-9 TRecordField "foo" +42:1-4 TFunction "add" +42:8-16 TModule "Prelude." +42:16-17 TOperator "+" +47:1-5 TVariable "main" +47:9-11 TTypeConstructor "IO" +48:1-5 TVariable "main" +48:8-16 TFunction "putStrLn" diff --git a/plugins/hls-core-plugin/test/testdata/T1.hs b/plugins/hls-core-plugin/test/testdata/T1.hs new file mode 100644 index 0000000000..07b0476c1e --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/T1.hs @@ -0,0 +1,48 @@ +-- patter syn +{-# LANGUAGE PatternSynonyms #-} + +module Main where + +-- import Data.Set (Set, insert) + + +data Foo = Foo { foo :: Int } + +class Boo a where + boo :: a -> a + +instance Boo Int where + boo x = x + 1 + +data Dd = Dd Int + +pattern One = Foo 1 + +ggg = One + +data Doo = Doo Prelude.Int +type Bar1 = Int +type Bar2 = Doo + +bb :: (Boo a) => a -> a +bb x = boo x +aa :: cool -> Int -> cool +aa x = \c -> aa x c + where (xx, yy) = (1, 2) + dd = 1 + +(zz, kk) = (1, 2) +cc :: Foo -> (Int, Int) -> Int +cc f (gg, vv)= + case gg of + 1 -> foo $ f { foo = 1 } + 2 -> foo $ f { foo = 1 } + +go = foo +add = (Prelude.+) + +-- sub :: Int -> Int -> Int +-- sub x y = add x y + +main :: IO () +main = putStrLn "Hello, Haskell!" diff --git a/plugins/hls-core-plugin/test/testdata/TClass.expected b/plugins/hls-core-plugin/test/testdata/TClass.expected new file mode 100644 index 0000000000..e369963b0e --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TClass.expected @@ -0,0 +1,5 @@ +4:7-10 TClass "Foo" +4:11-12 TTypeVariable "a" +5:3-6 TClassMethod "foo" +5:10-11 TTypeVariable "a" +5:15-18 TTypeConstructor "Int" diff --git a/plugins/hls-core-plugin/test/testdata/TClass.hs b/plugins/hls-core-plugin/test/testdata/TClass.hs new file mode 100644 index 0000000000..692754ec71 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TClass.hs @@ -0,0 +1,6 @@ +module TClass where + + +class Foo a where + foo :: a -> Int + diff --git a/plugins/hls-core-plugin/test/testdata/TClassImportedDeriving.expected b/plugins/hls-core-plugin/test/testdata/TClassImportedDeriving.expected new file mode 100644 index 0000000000..3bbeb3e66c --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TClassImportedDeriving.expected @@ -0,0 +1,3 @@ +4:6-9 TTypeConstructor "Foo" +4:12-15 TDataConstructor "Foo" +4:26-30 TClass "Show" diff --git a/plugins/hls-core-plugin/test/testdata/TClassImportedDeriving.hs b/plugins/hls-core-plugin/test/testdata/TClassImportedDeriving.hs new file mode 100644 index 0000000000..8afd8afbd9 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TClassImportedDeriving.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE StandaloneDeriving #-} +module TClassImportedDeriving where +-- deriving method source span of Show occurrence +data Foo = Foo deriving (Show) + +-- standalone deriving method not in the same position +-- deriving instance Eq Foo + +-- a :: Foo -> Foo -> Bool +-- a = (==) diff --git a/plugins/hls-core-plugin/test/testdata/TDataFamily.expected b/plugins/hls-core-plugin/test/testdata/TDataFamily.expected new file mode 100644 index 0000000000..c95c0689f0 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TDataFamily.expected @@ -0,0 +1,12 @@ +5:13-18 TTypeFamily "XList" +5:19-20 TTypeVariable "a" +8:15-20 TTypeFamily "XList" +8:21-25 TTypeConstructor "Char" +8:28-33 TDataConstructor "XCons" +8:35-39 TTypeConstructor "Char" +8:42-47 TTypeFamily "XList" +8:48-52 TTypeConstructor "Char" +8:56-60 TDataConstructor "XNil" +11:15-20 TTypeFamily "XList" +11:26-35 TDataConstructor "XListUnit" +11:37-40 TTypeConstructor "Int" diff --git a/plugins/hls-core-plugin/test/testdata/TDataFamily.hs b/plugins/hls-core-plugin/test/testdata/TDataFamily.hs new file mode 100644 index 0000000000..b9047a72d2 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TDataFamily.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} +module TDatafamily where + +-- Declare a list-like data family +data family XList a + +-- Declare a list-like instance for Char +data instance XList Char = XCons !Char !(XList Char) | XNil + +-- Declare a number-like instance for () +data instance XList () = XListUnit !Int diff --git a/plugins/hls-core-plugin/test/testdata/TDataType.expected b/plugins/hls-core-plugin/test/testdata/TDataType.expected new file mode 100644 index 0000000000..bdf280c45e --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TDataType.expected @@ -0,0 +1,4 @@ +3:6-9 TTypeConstructor "Foo" +3:12-15 TDataConstructor "Foo" +3:16-19 TTypeConstructor "Int" +3:30-32 TClass "Eq" diff --git a/plugins/hls-core-plugin/test/testdata/TDataType.hs b/plugins/hls-core-plugin/test/testdata/TDataType.hs new file mode 100644 index 0000000000..894065e391 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TDataType.hs @@ -0,0 +1,3 @@ +module TDataType where + +data Foo = Foo Int deriving (Eq) diff --git a/plugins/hls-core-plugin/test/testdata/TDatatypeImported.expected b/plugins/hls-core-plugin/test/testdata/TDatatypeImported.expected new file mode 100644 index 0000000000..2c2cd492a0 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TDatatypeImported.expected @@ -0,0 +1,5 @@ +3:8-17 TModule "System.IO" +5:1-3 TVariable "go" +5:7-9 TTypeConstructor "IO" +6:1-3 TVariable "go" +6:6-11 TFunction "print" diff --git a/plugins/hls-core-plugin/test/testdata/TDatatypeImported.hs b/plugins/hls-core-plugin/test/testdata/TDatatypeImported.hs new file mode 100644 index 0000000000..f6ac8996d9 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TDatatypeImported.hs @@ -0,0 +1,6 @@ +module TDatatypeImported where + +import System.IO + +go :: IO () +go = print 1 diff --git a/plugins/hls-core-plugin/test/testdata/TDoc.expected b/plugins/hls-core-plugin/test/testdata/TDoc.expected new file mode 100644 index 0000000000..405308c3c8 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TDoc.expected @@ -0,0 +1,5 @@ +4:5-10 TVariable "hello" +5:1-6 TVariable "hello" +5:10-13 TTypeConstructor "Int" +6:1-6 TVariable "hello" +6:9-15 TClassMethod "length" diff --git a/plugins/hls-core-plugin/test/testdata/TDoc.hs b/plugins/hls-core-plugin/test/testdata/TDoc.hs new file mode 100644 index 0000000000..dc5801b0e6 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TDoc.hs @@ -0,0 +1,9 @@ +module TDoc where + +-- | +-- `hello` +hello :: Int +hello = length "Hello, Haskell!" + + + diff --git a/plugins/hls-core-plugin/test/testdata/TFunction.expected b/plugins/hls-core-plugin/test/testdata/TFunction.expected new file mode 100644 index 0000000000..f34510728b --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TFunction.expected @@ -0,0 +1,11 @@ +3:1-2 TFunction "f" +3:13-14 TTypeVariable "a" +3:16-17 TTypeVariable "a" +3:21-22 TTypeVariable "a" +4:1-2 TFunction "f" +4:3-4 TVariable "x" +4:7-8 TVariable "x" +6:1-2 TVariable "x" +6:6-7 TTypeVariable "a" +7:1-2 TVariable "x" +7:5-14 TVariable "undefined" diff --git a/plugins/hls-core-plugin/test/testdata/TFunction.hs b/plugins/hls-core-plugin/test/testdata/TFunction.hs new file mode 100644 index 0000000000..4efe5cecc4 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TFunction.hs @@ -0,0 +1,7 @@ +module TFunction where + +f :: forall a. a -> a +f x = x + +x :: a +x = undefined diff --git a/plugins/hls-core-plugin/test/testdata/TFunctionLet.expected b/plugins/hls-core-plugin/test/testdata/TFunctionLet.expected new file mode 100644 index 0000000000..3f27b723db --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TFunctionLet.expected @@ -0,0 +1,5 @@ +3:1-2 TVariable "y" +3:6-9 TTypeConstructor "Int" +4:1-2 TVariable "y" +4:9-10 TFunction "f" +4:11-12 TVariable "x" diff --git a/plugins/hls-core-plugin/test/testdata/TFunctionLet.hs b/plugins/hls-core-plugin/test/testdata/TFunctionLet.hs new file mode 100644 index 0000000000..96854c34ad --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TFunctionLet.hs @@ -0,0 +1,4 @@ +module TFunctionLet where + +y :: Int +y = let f x = 1 in 1 diff --git a/plugins/hls-core-plugin/test/testdata/TFunctionLocal.expected b/plugins/hls-core-plugin/test/testdata/TFunctionLocal.expected new file mode 100644 index 0000000000..176606e396 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TFunctionLocal.expected @@ -0,0 +1,7 @@ +3:1-2 TFunction "f" +3:6-9 TTypeConstructor "Int" +3:13-16 TTypeConstructor "Int" +4:1-2 TFunction "f" +4:7-8 TFunction "g" +6:5-6 TFunction "g" +6:7-8 TVariable "x" diff --git a/plugins/hls-core-plugin/test/testdata/TFunctionLocal.hs b/plugins/hls-core-plugin/test/testdata/TFunctionLocal.hs new file mode 100644 index 0000000000..fed144b00c --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TFunctionLocal.hs @@ -0,0 +1,8 @@ +module TFunctionLocal where + +f :: Int -> Int +f 1 = g 1 + where + g x = 1 + + diff --git a/plugins/hls-core-plugin/test/testdata/TFunctionUnderTypeSynonym.expected b/plugins/hls-core-plugin/test/testdata/TFunctionUnderTypeSynonym.expected new file mode 100644 index 0000000000..010cf0c613 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TFunctionUnderTypeSynonym.expected @@ -0,0 +1,17 @@ +3:6-8 TTypeSynonym "T1" +3:11-14 TTypeConstructor "Int" +3:18-21 TTypeConstructor "Int" +4:6-8 TTypeSynonym "T2" +4:18-19 TTypeVariable "a" +4:21-22 TTypeVariable "a" +4:26-27 TTypeVariable "a" +5:1-3 TFunction "f1" +5:7-9 TTypeSynonym "T1" +6:1-3 TFunction "f1" +6:4-5 TVariable "x" +6:8-9 TVariable "x" +7:1-3 TFunction "f2" +7:7-9 TTypeSynonym "T2" +8:1-3 TFunction "f2" +8:4-5 TVariable "x" +8:8-9 TVariable "x" diff --git a/plugins/hls-core-plugin/test/testdata/TFunctionUnderTypeSynonym.hs b/plugins/hls-core-plugin/test/testdata/TFunctionUnderTypeSynonym.hs new file mode 100644 index 0000000000..6485232394 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TFunctionUnderTypeSynonym.hs @@ -0,0 +1,9 @@ +module TFunctionUnderTypeSynonym where + +type T1 = Int -> Int +type T2 = forall a. a -> a +f1 :: T1 +f1 x = x +f2 :: T2 +f2 x = x + diff --git a/plugins/hls-core-plugin/test/testdata/TGADT.expected b/plugins/hls-core-plugin/test/testdata/TGADT.expected new file mode 100644 index 0000000000..ad3ac0f086 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TGADT.expected @@ -0,0 +1,13 @@ +5:6-9 TTypeConstructor "Lam" +6:3-7 TDataConstructor "Lift" +6:11-12 TTypeVariable "a" +6:36-39 TTypeConstructor "Lam" +6:40-41 TTypeVariable "a" +7:3-6 TDataConstructor "Lam" +7:12-15 TTypeConstructor "Lam" +7:16-17 TTypeVariable "a" +7:21-24 TTypeConstructor "Lam" +7:25-26 TTypeVariable "b" +7:36-39 TTypeConstructor "Lam" +7:41-42 TTypeVariable "a" +7:46-47 TTypeVariable "b" diff --git a/plugins/hls-core-plugin/test/testdata/TGADT.hs b/plugins/hls-core-plugin/test/testdata/TGADT.hs new file mode 100644 index 0000000000..e0cccf8bed --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TGADT.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +module TGADT where + +data Lam :: * -> * where + Lift :: a -> Lam a -- ^ lifted value + Lam :: (Lam a -> Lam b) -> Lam (a -> b) -- ^ lambda abstraction diff --git a/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodBind.expected b/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodBind.expected new file mode 100644 index 0000000000..a4a6ef98e0 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodBind.expected @@ -0,0 +1,7 @@ +4:6-9 TTypeConstructor "Foo" +4:12-15 TDataConstructor "Foo" +4:16-19 TTypeConstructor "Int" +5:10-14 TClass "Show" +5:15-18 TTypeConstructor "Foo" +6:5-9 TClassMethod "show" +6:12-21 TVariable "undefined" diff --git a/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodBind.hs b/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodBind.hs new file mode 100644 index 0000000000..33976a48c1 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodBind.hs @@ -0,0 +1,6 @@ +module TInstanceClassMethodBind where + + +data Foo = Foo Int +instance Show Foo where + show = undefined diff --git a/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodUse.expected b/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodUse.expected new file mode 100644 index 0000000000..2bf39be435 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodUse.expected @@ -0,0 +1,2 @@ +4:1-3 TFunction "go" +4:8-12 TClassMethod "show" diff --git a/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodUse.hs b/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodUse.hs new file mode 100644 index 0000000000..689d1643d4 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodUse.hs @@ -0,0 +1,5 @@ +module TInstanceClassMethodUse where + + +go = show + diff --git a/plugins/hls-core-plugin/test/testdata/TModuleA.hs b/plugins/hls-core-plugin/test/testdata/TModuleA.hs new file mode 100644 index 0000000000..d76f64fc1f --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TModuleA.hs @@ -0,0 +1,5 @@ +module TModuleA where + +data Game = Game {a𐐀b :: Int} + + diff --git a/plugins/hls-core-plugin/test/testdata/TModuleB.hs b/plugins/hls-core-plugin/test/testdata/TModuleB.hs new file mode 100644 index 0000000000..d2bfe4b7fa --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TModuleB.hs @@ -0,0 +1,8 @@ +module TModuleB where + +import TModuleA +import qualified TModuleA + +go = Game 1 + +a𐐀bb = TModuleA.a𐐀b go diff --git a/plugins/hls-core-plugin/test/testdata/TNoneFunctionWithConstraint.expected b/plugins/hls-core-plugin/test/testdata/TNoneFunctionWithConstraint.expected new file mode 100644 index 0000000000..2dd89fd1da --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TNoneFunctionWithConstraint.expected @@ -0,0 +1,6 @@ +3:1-2 TVariable "x" +3:7-9 TClass "Eq" +3:10-11 TTypeVariable "a" +3:16-17 TTypeVariable "a" +4:1-2 TVariable "x" +4:5-14 TVariable "undefined" diff --git a/plugins/hls-core-plugin/test/testdata/TNoneFunctionWithConstraint.hs b/plugins/hls-core-plugin/test/testdata/TNoneFunctionWithConstraint.hs new file mode 100644 index 0000000000..9a7119dbdb --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TNoneFunctionWithConstraint.hs @@ -0,0 +1,5 @@ +module TNoneFunctionWithConstraint where + +x :: (Eq a) => a +x = undefined + diff --git a/plugins/hls-core-plugin/test/testdata/TOperator.expected b/plugins/hls-core-plugin/test/testdata/TOperator.expected new file mode 100644 index 0000000000..c19e7cb904 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TOperator.expected @@ -0,0 +1,33 @@ +4:1-3 TFunction "go" +4:4-5 TFunction "f" +4:6-7 TVariable "x" +4:10-11 TFunction "f" +4:11-12 TOperator "$" +4:12-13 TVariable "x" +6:2-6 TOperator "$$$$" +7:1-2 TVariable "x" +7:7-11 TOperator "$$$$" +8:6-7 TTypeVariable "a" +8:8-11 TOperator ":+:" +8:12-13 TTypeVariable "b" +8:16-19 TDataConstructor "Add" +8:20-21 TTypeVariable "a" +8:22-23 TTypeVariable "b" +9:7-10 TOperator ":-:" +9:12-13 TTypeVariable "a" +9:14-15 TTypeVariable "b" +9:19-20 TTypeVariable "a" +9:22-23 TTypeVariable "b" +11:1-4 TFunction "add" +11:8-11 TTypeConstructor "Int" +11:12-15 TOperator ":+:" +11:16-19 TTypeConstructor "Int" +11:23-26 TTypeConstructor "Int" +11:27-30 TOperator ":-:" +11:31-34 TTypeConstructor "Int" +13:1-4 TFunction "add" +13:6-9 TDataConstructor "Add" +13:10-11 TVariable "x" +13:12-13 TVariable "y" +13:18-19 TVariable "x" +13:21-22 TVariable "y" diff --git a/plugins/hls-core-plugin/test/testdata/TOperator.hs b/plugins/hls-core-plugin/test/testdata/TOperator.hs new file mode 100644 index 0000000000..e2f06c92fa --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TOperator.hs @@ -0,0 +1,13 @@ +module TOperator where + +-- imported operator +go f x = f$x +-- operator defined in local module +($$$$) = b +x = 1 $$$$ 2 +data a :+: b = Add a b +type (:-:) a b = (a, b) +-- type take precedence over operator +add :: Int :+: Int -> Int :-: Int +-- class method take precedence over operator +add (Add x y) = (x, y) diff --git a/plugins/hls-core-plugin/test/testdata/TPatternMatch.expected b/plugins/hls-core-plugin/test/testdata/TPatternMatch.expected new file mode 100644 index 0000000000..0535662e63 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TPatternMatch.expected @@ -0,0 +1,2 @@ +4:1-2 TFunction "g" +4:4-11 TDataConstructor "Nothing" diff --git a/plugins/hls-core-plugin/test/testdata/TPatternMatch.hs b/plugins/hls-core-plugin/test/testdata/TPatternMatch.hs new file mode 100644 index 0000000000..95e97c1abb --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TPatternMatch.hs @@ -0,0 +1,6 @@ +module TPatternMatch where + + +g (Nothing, _) = 1 + + diff --git a/plugins/hls-core-plugin/test/testdata/TPatternSynonym.expected b/plugins/hls-core-plugin/test/testdata/TPatternSynonym.expected new file mode 100644 index 0000000000..7cdf5260cb --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TPatternSynonym.expected @@ -0,0 +1 @@ +5:9-12 TPatternSynonym "Foo" diff --git a/plugins/hls-core-plugin/test/testdata/TPatternSynonym.hs b/plugins/hls-core-plugin/test/testdata/TPatternSynonym.hs new file mode 100644 index 0000000000..adff673ce8 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TPatternSynonym.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +module TPatternSynonym where + + +pattern Foo = 1 + + diff --git a/plugins/hls-core-plugin/test/testdata/TPatternbind.expected b/plugins/hls-core-plugin/test/testdata/TPatternbind.expected new file mode 100644 index 0000000000..6c62634487 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TPatternbind.expected @@ -0,0 +1,7 @@ +3:2-3 TVariable "a" +3:5-6 TVariable "b" +5:1-2 TFunction "f" +5:3-4 TFunction "g" +5:5-6 TVariable "y" +5:9-10 TFunction "g" +5:11-12 TVariable "y" diff --git a/plugins/hls-core-plugin/test/testdata/TPatternbind.hs b/plugins/hls-core-plugin/test/testdata/TPatternbind.hs new file mode 100644 index 0000000000..49e642a35d --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TPatternbind.hs @@ -0,0 +1,9 @@ +module TVariable where + +(a, b) = (1, 2) + +f g y = g y + + + + diff --git a/plugins/hls-core-plugin/test/testdata/TQualifiedName.expected b/plugins/hls-core-plugin/test/testdata/TQualifiedName.expected new file mode 100644 index 0000000000..0ca7cd7d5b --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TQualifiedName.expected @@ -0,0 +1,12 @@ +3:18-27 TModule "Data.List" +6:1-2 TVariable "a" +6:5-13 TModule "Prelude." +6:13-22 TVariable "undefined" +7:1-2 TVariable "b" +7:8-18 TModule "Data.List." +7:18-22 TClassMethod "elem" +8:1-2 TVariable "c" +8:6-14 TModule "Prelude." +8:14-15 TOperator "+" +9:1-2 TVariable "d" +9:6-7 TOperator "+" diff --git a/plugins/hls-core-plugin/test/testdata/TQualifiedName.hs b/plugins/hls-core-plugin/test/testdata/TQualifiedName.hs new file mode 100644 index 0000000000..5dbdcc1d52 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TQualifiedName.hs @@ -0,0 +1,9 @@ +module TQualifiedName where + +import qualified Data.List + + +a = Prelude.undefined +b = 1 `Data.List.elem` [1, 2] +c = (Prelude.+) 1 1 +d = (+) 1 1 diff --git a/plugins/hls-core-plugin/test/testdata/TRecord.expected b/plugins/hls-core-plugin/test/testdata/TRecord.expected new file mode 100644 index 0000000000..43b8e4d3b0 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TRecord.expected @@ -0,0 +1,4 @@ +4:6-9 TTypeConstructor "Foo" +4:12-15 TDataConstructor "Foo" +4:18-21 TRecordField "foo" +4:25-28 TTypeConstructor "Int" diff --git a/plugins/hls-core-plugin/test/testdata/TRecord.hs b/plugins/hls-core-plugin/test/testdata/TRecord.hs new file mode 100644 index 0000000000..b3176a154f --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TRecord.hs @@ -0,0 +1,7 @@ +module TRecord where + + +data Foo = Foo { foo :: Int } + + + diff --git a/plugins/hls-core-plugin/test/testdata/TRecordDuplicateRecordFields.expected b/plugins/hls-core-plugin/test/testdata/TRecordDuplicateRecordFields.expected new file mode 100644 index 0000000000..70fdc63e18 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TRecordDuplicateRecordFields.expected @@ -0,0 +1,4 @@ +5:6-9 TTypeConstructor "Foo" +5:12-15 TDataConstructor "Foo" +5:18-21 TRecordField "boo" +5:26-32 TTypeSynonym "String" diff --git a/plugins/hls-core-plugin/test/testdata/TRecordDuplicateRecordFields.hs b/plugins/hls-core-plugin/test/testdata/TRecordDuplicateRecordFields.hs new file mode 100644 index 0000000000..395a1d3731 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TRecordDuplicateRecordFields.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module TRecordDuplicateRecordFields where + +data Foo = Foo { boo :: !String } diff --git a/plugins/hls-core-plugin/test/testdata/TTypefamily.expected b/plugins/hls-core-plugin/test/testdata/TTypefamily.expected new file mode 100644 index 0000000000..08019bc3f3 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TTypefamily.expected @@ -0,0 +1,8 @@ +4:13-16 TTypeFamily "Foo" +4:17-18 TTypeVariable "a" +5:3-6 TTypeFamily "Foo" +5:7-10 TTypeConstructor "Int" +5:13-16 TTypeConstructor "Int" +6:3-6 TTypeFamily "Foo" +6:7-8 TTypeVariable "a" +6:11-17 TTypeSynonym "String" diff --git a/plugins/hls-core-plugin/test/testdata/TTypefamily.hs b/plugins/hls-core-plugin/test/testdata/TTypefamily.hs new file mode 100644 index 0000000000..d8c925e370 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TTypefamily.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +module TTypefamily where + +type family Foo a where + Foo Int = Int + Foo a = String diff --git a/plugins/hls-core-plugin/test/testdata/TUnicodeSyntax.expected b/plugins/hls-core-plugin/test/testdata/TUnicodeSyntax.expected new file mode 100644 index 0000000000..0b94b7c045 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TUnicodeSyntax.expected @@ -0,0 +1 @@ +3:1-4 TVariable "a\66560b" diff --git a/plugins/hls-core-plugin/test/testdata/TUnicodeSyntax.hs b/plugins/hls-core-plugin/test/testdata/TUnicodeSyntax.hs new file mode 100644 index 0000000000..1b8c7c1baa --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TUnicodeSyntax.hs @@ -0,0 +1,5 @@ +module TUnicodeSyntax where + +a𐐀b = "a𐐀b" + + diff --git a/plugins/hls-core-plugin/test/testdata/TValBind.expected b/plugins/hls-core-plugin/test/testdata/TValBind.expected new file mode 100644 index 0000000000..ec20b01e56 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TValBind.expected @@ -0,0 +1,4 @@ +4:1-6 TVariable "hello" +4:10-13 TTypeConstructor "Int" +5:1-6 TVariable "hello" +5:9-15 TClassMethod "length" diff --git a/plugins/hls-core-plugin/test/testdata/TValBind.hs b/plugins/hls-core-plugin/test/testdata/TValBind.hs new file mode 100644 index 0000000000..506af37a42 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/TValBind.hs @@ -0,0 +1,8 @@ +module TValBind where + + +hello :: Int +hello = length "Hello, Haskell!" + + + diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 1f5d091dc5..4e10e4b501 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -130,6 +130,7 @@ import qualified Development.IDE.Plugin.CodeAction as Refactor #if hls_semanticTokens import qualified Ide.Plugin.SemanticTokens as SemanticTokens #endif +import qualified Ide.Plugin.Core as Core data Log = forall a. (Pretty a) => Log PluginId a @@ -150,6 +151,7 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins pluginRecorder :: forall log. (Pretty log) => PluginId -> Recorder (WithPriority log) pluginRecorder pluginId = cmapWithPrio (Log pluginId) recorder allPlugins = + let pId = "core" in Core.descriptor (pluginRecorder pId) pId: #if hls_cabal let pId = "cabal" in Cabal.descriptor (pluginRecorder pId) pId : #endif From efe6bbc3a34b5bd939cda0dc777e8935e29582cd Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 24 Mar 2024 03:50:29 +0800 Subject: [PATCH 02/34] update readme --- plugins/hls-core-plugin/README.md | 65 +------------------------------ 1 file changed, 2 insertions(+), 63 deletions(-) diff --git a/plugins/hls-core-plugin/README.md b/plugins/hls-core-plugin/README.md index 5d6be35ef5..622671029b 100644 --- a/plugins/hls-core-plugin/README.md +++ b/plugins/hls-core-plugin/README.md @@ -1,66 +1,5 @@ -# Semantic tokens (LSP) plugin for Haskell language server +# Core (LSP) plugin for Haskell language server ## Purpose -The purpose of this plugin is to provide semantic tokens for the Haskell language server, -according to the [LSP specification](https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens) -It can be used to provide semantic highlighting for Haskell code in editors by given semantic type and modifiers for some tokens. -A lot of editors support semantic highlighting through LSP, for example vscode, vim, emacs, etc. - -## Features - -### Semantic types and modifiers - -The handles request for semantic tokens for the whole file. -It supports semantic types and but not yet modifiers from the LSP specification. - -Default semantic types defined in lsp diverge greatly from the ones used in ghc. -But default semantic types allows user with less configuration to get semantic highlighting. -That is why we use default semantic types for now. By mapping ghc semantic types to lsp semantic types. -The mapping is defined in `Mapping.hs` file. - -### delta semantic tokens, range semantic tokens and refresh - -It is not yet support capabilities for delta semantic tokens, which might be -crucial for performance. -It should be implemented in the future. - -## checkList - -* Supported PluginMethodHandler - * [x] [textDocument/semanticTokens/full](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#semanticTokens_fullRequest). - * [ ] [textDocument/semanticTokens/full/delta](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#semanticTokens_deltaRequest) - * [ ] [workspace/semanticTokens/refresh](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#semanticTokens_refreshRequest) - -* Supported semantic tokens type: - * [x] class and class method - * [x] type family name (data family) - * [x] data constructor name (not distinguishing record and normal data, and GADT) - * [x] type constructor name (GADT) - * [x] record field name - * [x] type synonym - * [x] pattern synonym - * [x] ~~pattern bindings~~ In favor of differing functions and none-functions from its type - * [x] ~~value bindings~~ In favor of differing functions and none-functions from its type - * [x] functions - * [x] none-function variables - * [x] imported name - -* Supported modifiers(planning): - * [future] declaration (as in class declearations, type definition and type family) - * [future] definition (as in class instance declaration, left hand side value binding, and type family instance) - * [future] modification (as in rec field update) - -## Implementation details - -* [x] Compute visible names from renamedsource -* [x] Compute `NameSemanticMap` for imported and top level name tokens using `HscEnv`(with deps) and type checked result -* [x] Compute current module `NameSemanticMap` using `RefMap a` from the result of `GetHieAst` -* [x] Compute all visible `(Name, Span)` in current module, in turn compute their semantic token using the combination map of the above two `NameSemanticMap` -* [x] use default legends, Candidates map of token type with default token type: [Maps to default token types](https://github.com/soulomoon/haskell-language-server/blob/master/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs) -* [x] add args support to turn the plugin on and off -* [x] enhence test -* [x] enhence error reporting. -* [x] computation of semantic tokens is pushed into rule `getSemanticTokensRule` -* [future] make use of modifiers -* [future] hadling customize legends using server capabilities (how?) +This plugin provides the core functionality for the Haskell language server. It is based on the [Haskell IDE Engine]. From 38232b4b003cb9ea4e2322e55861d630efd78d30 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 24 Mar 2024 03:51:16 +0800 Subject: [PATCH 03/34] update core testdata --- .../hls-core-plugin/test/testdata/T1.expected | 81 ------------------- plugins/hls-core-plugin/test/testdata/T1.hs | 48 ----------- .../test/testdata/TClass.expected | 5 -- .../hls-core-plugin/test/testdata/TClass.hs | 6 -- .../testdata/TClassImportedDeriving.expected | 3 - .../test/testdata/TClassImportedDeriving.hs | 10 --- .../test/testdata/TDataFamily.expected | 12 --- .../test/testdata/TDataFamily.hs | 11 --- .../test/testdata/TDataType.expected | 4 - .../test/testdata/TDataType.hs | 3 - .../test/testdata/TDatatypeImported.expected | 5 -- .../test/testdata/TDatatypeImported.hs | 6 -- .../test/testdata/TDoc.expected | 5 -- plugins/hls-core-plugin/test/testdata/TDoc.hs | 9 --- .../test/testdata/TFunction.expected | 11 --- .../test/testdata/TFunction.hs | 7 -- .../test/testdata/TFunctionLet.expected | 5 -- .../test/testdata/TFunctionLet.hs | 4 - .../test/testdata/TFunctionLocal.expected | 7 -- .../test/testdata/TFunctionLocal.hs | 8 -- .../TFunctionUnderTypeSynonym.expected | 17 ---- .../testdata/TFunctionUnderTypeSynonym.hs | 9 --- .../test/testdata/TGADT.expected | 13 --- .../hls-core-plugin/test/testdata/TGADT.hs | 7 -- .../TInstanceClassMethodBind.expected | 7 -- .../test/testdata/TInstanceClassMethodBind.hs | 6 -- .../testdata/TInstanceClassMethodUse.expected | 2 - .../test/testdata/TInstanceClassMethodUse.hs | 5 -- .../hls-core-plugin/test/testdata/TModuleA.hs | 5 -- .../hls-core-plugin/test/testdata/TModuleB.hs | 8 -- .../TNoneFunctionWithConstraint.expected | 6 -- .../testdata/TNoneFunctionWithConstraint.hs | 5 -- .../test/testdata/TOperator.expected | 33 -------- .../test/testdata/TOperator.hs | 13 --- .../test/testdata/TPatternMatch.expected | 2 - .../test/testdata/TPatternMatch.hs | 6 -- .../test/testdata/TPatternSynonym.expected | 1 - .../test/testdata/TPatternSynonym.hs | 7 -- .../test/testdata/TPatternbind.expected | 7 -- .../test/testdata/TPatternbind.hs | 9 --- .../test/testdata/TQualifiedName.expected | 12 --- .../test/testdata/TQualifiedName.hs | 9 --- .../test/testdata/TRecord.expected | 4 - .../hls-core-plugin/test/testdata/TRecord.hs | 7 -- .../TRecordDuplicateRecordFields.expected | 4 - .../testdata/TRecordDuplicateRecordFields.hs | 5 -- .../test/testdata/TTypefamily.expected | 8 -- .../test/testdata/TTypefamily.hs | 6 -- .../test/testdata/TUnicodeSyntax.expected | 1 - .../test/testdata/TUnicodeSyntax.hs | 5 -- .../test/testdata/TValBind.expected | 4 - .../hls-core-plugin/test/testdata/TValBind.hs | 8 -- 52 files changed, 491 deletions(-) delete mode 100644 plugins/hls-core-plugin/test/testdata/T1.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/T1.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TClass.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TClass.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TClassImportedDeriving.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TClassImportedDeriving.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TDataFamily.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TDataFamily.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TDataType.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TDataType.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TDatatypeImported.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TDatatypeImported.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TDoc.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TDoc.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TFunction.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TFunction.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TFunctionLet.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TFunctionLet.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TFunctionLocal.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TFunctionLocal.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TFunctionUnderTypeSynonym.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TFunctionUnderTypeSynonym.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TGADT.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TGADT.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TInstanceClassMethodBind.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TInstanceClassMethodBind.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TInstanceClassMethodUse.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TInstanceClassMethodUse.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TModuleA.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TModuleB.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TNoneFunctionWithConstraint.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TNoneFunctionWithConstraint.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TOperator.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TOperator.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TPatternMatch.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TPatternMatch.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TPatternSynonym.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TPatternSynonym.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TPatternbind.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TPatternbind.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TQualifiedName.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TQualifiedName.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TRecord.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TRecord.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TRecordDuplicateRecordFields.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TRecordDuplicateRecordFields.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TTypefamily.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TTypefamily.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TUnicodeSyntax.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TUnicodeSyntax.hs delete mode 100644 plugins/hls-core-plugin/test/testdata/TValBind.expected delete mode 100644 plugins/hls-core-plugin/test/testdata/TValBind.hs diff --git a/plugins/hls-core-plugin/test/testdata/T1.expected b/plugins/hls-core-plugin/test/testdata/T1.expected deleted file mode 100644 index cbf7699f19..0000000000 --- a/plugins/hls-core-plugin/test/testdata/T1.expected +++ /dev/null @@ -1,81 +0,0 @@ -9:6-9 TTypeConstructor "Foo" -9:12-15 TDataConstructor "Foo" -9:18-21 TRecordField "foo" -9:25-28 TTypeConstructor "Int" -11:7-10 TClass "Boo" -11:11-12 TTypeVariable "a" -12:3-6 TClassMethod "boo" -12:10-11 TTypeVariable "a" -12:15-16 TTypeVariable "a" -14:10-13 TClass "Boo" -14:14-17 TTypeConstructor "Int" -15:5-8 TClassMethod "boo" -15:9-10 TVariable "x" -15:13-14 TVariable "x" -15:15-16 TOperator "+" -17:6-8 TTypeConstructor "Dd" -17:11-13 TDataConstructor "Dd" -17:14-17 TTypeConstructor "Int" -19:9-12 TPatternSynonym "One" -19:15-18 TDataConstructor "Foo" -21:1-4 TVariable "ggg" -21:7-10 TPatternSynonym "One" -23:6-9 TTypeConstructor "Doo" -23:12-15 TDataConstructor "Doo" -23:16-24 TModule "Prelude." -23:24-27 TTypeConstructor "Int" -24:6-10 TTypeSynonym "Bar1" -24:13-16 TTypeConstructor "Int" -25:6-10 TTypeSynonym "Bar2" -25:13-16 TTypeConstructor "Doo" -27:1-3 TFunction "bb" -27:8-11 TClass "Boo" -27:12-13 TTypeVariable "a" -27:18-19 TTypeVariable "a" -27:23-24 TTypeVariable "a" -28:1-3 TFunction "bb" -28:4-5 TVariable "x" -28:9-12 TClassMethod "boo" -28:13-14 TVariable "x" -29:1-3 TFunction "aa" -29:7-11 TTypeVariable "cool" -29:15-18 TTypeConstructor "Int" -29:22-26 TTypeVariable "cool" -30:1-3 TFunction "aa" -30:4-5 TVariable "x" -30:9-10 TVariable "c" -30:14-16 TFunction "aa" -30:17-18 TVariable "x" -30:19-20 TVariable "c" -31:12-14 TVariable "xx" -31:16-18 TVariable "yy" -32:11-13 TVariable "dd" -34:2-4 TVariable "zz" -34:6-8 TVariable "kk" -35:1-3 TFunction "cc" -35:7-10 TTypeConstructor "Foo" -35:15-18 TTypeConstructor "Int" -35:20-23 TTypeConstructor "Int" -35:28-31 TTypeConstructor "Int" -36:1-3 TFunction "cc" -36:4-5 TVariable "f" -36:7-9 TVariable "gg" -36:11-13 TVariable "vv" -37:10-12 TVariable "gg" -38:14-17 TRecordField "foo" -38:18-19 TOperator "$" -38:20-21 TVariable "f" -38:24-27 TRecordField "foo" -39:14-17 TRecordField "foo" -39:18-19 TOperator "$" -39:20-21 TVariable "f" -39:24-27 TRecordField "foo" -41:1-3 TFunction "go" -41:6-9 TRecordField "foo" -42:1-4 TFunction "add" -42:8-16 TModule "Prelude." -42:16-17 TOperator "+" -47:1-5 TVariable "main" -47:9-11 TTypeConstructor "IO" -48:1-5 TVariable "main" -48:8-16 TFunction "putStrLn" diff --git a/plugins/hls-core-plugin/test/testdata/T1.hs b/plugins/hls-core-plugin/test/testdata/T1.hs deleted file mode 100644 index 07b0476c1e..0000000000 --- a/plugins/hls-core-plugin/test/testdata/T1.hs +++ /dev/null @@ -1,48 +0,0 @@ --- patter syn -{-# LANGUAGE PatternSynonyms #-} - -module Main where - --- import Data.Set (Set, insert) - - -data Foo = Foo { foo :: Int } - -class Boo a where - boo :: a -> a - -instance Boo Int where - boo x = x + 1 - -data Dd = Dd Int - -pattern One = Foo 1 - -ggg = One - -data Doo = Doo Prelude.Int -type Bar1 = Int -type Bar2 = Doo - -bb :: (Boo a) => a -> a -bb x = boo x -aa :: cool -> Int -> cool -aa x = \c -> aa x c - where (xx, yy) = (1, 2) - dd = 1 - -(zz, kk) = (1, 2) -cc :: Foo -> (Int, Int) -> Int -cc f (gg, vv)= - case gg of - 1 -> foo $ f { foo = 1 } - 2 -> foo $ f { foo = 1 } - -go = foo -add = (Prelude.+) - --- sub :: Int -> Int -> Int --- sub x y = add x y - -main :: IO () -main = putStrLn "Hello, Haskell!" diff --git a/plugins/hls-core-plugin/test/testdata/TClass.expected b/plugins/hls-core-plugin/test/testdata/TClass.expected deleted file mode 100644 index e369963b0e..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TClass.expected +++ /dev/null @@ -1,5 +0,0 @@ -4:7-10 TClass "Foo" -4:11-12 TTypeVariable "a" -5:3-6 TClassMethod "foo" -5:10-11 TTypeVariable "a" -5:15-18 TTypeConstructor "Int" diff --git a/plugins/hls-core-plugin/test/testdata/TClass.hs b/plugins/hls-core-plugin/test/testdata/TClass.hs deleted file mode 100644 index 692754ec71..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TClass.hs +++ /dev/null @@ -1,6 +0,0 @@ -module TClass where - - -class Foo a where - foo :: a -> Int - diff --git a/plugins/hls-core-plugin/test/testdata/TClassImportedDeriving.expected b/plugins/hls-core-plugin/test/testdata/TClassImportedDeriving.expected deleted file mode 100644 index 3bbeb3e66c..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TClassImportedDeriving.expected +++ /dev/null @@ -1,3 +0,0 @@ -4:6-9 TTypeConstructor "Foo" -4:12-15 TDataConstructor "Foo" -4:26-30 TClass "Show" diff --git a/plugins/hls-core-plugin/test/testdata/TClassImportedDeriving.hs b/plugins/hls-core-plugin/test/testdata/TClassImportedDeriving.hs deleted file mode 100644 index 8afd8afbd9..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TClassImportedDeriving.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -module TClassImportedDeriving where --- deriving method source span of Show occurrence -data Foo = Foo deriving (Show) - --- standalone deriving method not in the same position --- deriving instance Eq Foo - --- a :: Foo -> Foo -> Bool --- a = (==) diff --git a/plugins/hls-core-plugin/test/testdata/TDataFamily.expected b/plugins/hls-core-plugin/test/testdata/TDataFamily.expected deleted file mode 100644 index c95c0689f0..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TDataFamily.expected +++ /dev/null @@ -1,12 +0,0 @@ -5:13-18 TTypeFamily "XList" -5:19-20 TTypeVariable "a" -8:15-20 TTypeFamily "XList" -8:21-25 TTypeConstructor "Char" -8:28-33 TDataConstructor "XCons" -8:35-39 TTypeConstructor "Char" -8:42-47 TTypeFamily "XList" -8:48-52 TTypeConstructor "Char" -8:56-60 TDataConstructor "XNil" -11:15-20 TTypeFamily "XList" -11:26-35 TDataConstructor "XListUnit" -11:37-40 TTypeConstructor "Int" diff --git a/plugins/hls-core-plugin/test/testdata/TDataFamily.hs b/plugins/hls-core-plugin/test/testdata/TDataFamily.hs deleted file mode 100644 index b9047a72d2..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TDataFamily.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module TDatafamily where - --- Declare a list-like data family -data family XList a - --- Declare a list-like instance for Char -data instance XList Char = XCons !Char !(XList Char) | XNil - --- Declare a number-like instance for () -data instance XList () = XListUnit !Int diff --git a/plugins/hls-core-plugin/test/testdata/TDataType.expected b/plugins/hls-core-plugin/test/testdata/TDataType.expected deleted file mode 100644 index bdf280c45e..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TDataType.expected +++ /dev/null @@ -1,4 +0,0 @@ -3:6-9 TTypeConstructor "Foo" -3:12-15 TDataConstructor "Foo" -3:16-19 TTypeConstructor "Int" -3:30-32 TClass "Eq" diff --git a/plugins/hls-core-plugin/test/testdata/TDataType.hs b/plugins/hls-core-plugin/test/testdata/TDataType.hs deleted file mode 100644 index 894065e391..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TDataType.hs +++ /dev/null @@ -1,3 +0,0 @@ -module TDataType where - -data Foo = Foo Int deriving (Eq) diff --git a/plugins/hls-core-plugin/test/testdata/TDatatypeImported.expected b/plugins/hls-core-plugin/test/testdata/TDatatypeImported.expected deleted file mode 100644 index 2c2cd492a0..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TDatatypeImported.expected +++ /dev/null @@ -1,5 +0,0 @@ -3:8-17 TModule "System.IO" -5:1-3 TVariable "go" -5:7-9 TTypeConstructor "IO" -6:1-3 TVariable "go" -6:6-11 TFunction "print" diff --git a/plugins/hls-core-plugin/test/testdata/TDatatypeImported.hs b/plugins/hls-core-plugin/test/testdata/TDatatypeImported.hs deleted file mode 100644 index f6ac8996d9..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TDatatypeImported.hs +++ /dev/null @@ -1,6 +0,0 @@ -module TDatatypeImported where - -import System.IO - -go :: IO () -go = print 1 diff --git a/plugins/hls-core-plugin/test/testdata/TDoc.expected b/plugins/hls-core-plugin/test/testdata/TDoc.expected deleted file mode 100644 index 405308c3c8..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TDoc.expected +++ /dev/null @@ -1,5 +0,0 @@ -4:5-10 TVariable "hello" -5:1-6 TVariable "hello" -5:10-13 TTypeConstructor "Int" -6:1-6 TVariable "hello" -6:9-15 TClassMethod "length" diff --git a/plugins/hls-core-plugin/test/testdata/TDoc.hs b/plugins/hls-core-plugin/test/testdata/TDoc.hs deleted file mode 100644 index dc5801b0e6..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TDoc.hs +++ /dev/null @@ -1,9 +0,0 @@ -module TDoc where - --- | --- `hello` -hello :: Int -hello = length "Hello, Haskell!" - - - diff --git a/plugins/hls-core-plugin/test/testdata/TFunction.expected b/plugins/hls-core-plugin/test/testdata/TFunction.expected deleted file mode 100644 index f34510728b..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TFunction.expected +++ /dev/null @@ -1,11 +0,0 @@ -3:1-2 TFunction "f" -3:13-14 TTypeVariable "a" -3:16-17 TTypeVariable "a" -3:21-22 TTypeVariable "a" -4:1-2 TFunction "f" -4:3-4 TVariable "x" -4:7-8 TVariable "x" -6:1-2 TVariable "x" -6:6-7 TTypeVariable "a" -7:1-2 TVariable "x" -7:5-14 TVariable "undefined" diff --git a/plugins/hls-core-plugin/test/testdata/TFunction.hs b/plugins/hls-core-plugin/test/testdata/TFunction.hs deleted file mode 100644 index 4efe5cecc4..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TFunction.hs +++ /dev/null @@ -1,7 +0,0 @@ -module TFunction where - -f :: forall a. a -> a -f x = x - -x :: a -x = undefined diff --git a/plugins/hls-core-plugin/test/testdata/TFunctionLet.expected b/plugins/hls-core-plugin/test/testdata/TFunctionLet.expected deleted file mode 100644 index 3f27b723db..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TFunctionLet.expected +++ /dev/null @@ -1,5 +0,0 @@ -3:1-2 TVariable "y" -3:6-9 TTypeConstructor "Int" -4:1-2 TVariable "y" -4:9-10 TFunction "f" -4:11-12 TVariable "x" diff --git a/plugins/hls-core-plugin/test/testdata/TFunctionLet.hs b/plugins/hls-core-plugin/test/testdata/TFunctionLet.hs deleted file mode 100644 index 96854c34ad..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TFunctionLet.hs +++ /dev/null @@ -1,4 +0,0 @@ -module TFunctionLet where - -y :: Int -y = let f x = 1 in 1 diff --git a/plugins/hls-core-plugin/test/testdata/TFunctionLocal.expected b/plugins/hls-core-plugin/test/testdata/TFunctionLocal.expected deleted file mode 100644 index 176606e396..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TFunctionLocal.expected +++ /dev/null @@ -1,7 +0,0 @@ -3:1-2 TFunction "f" -3:6-9 TTypeConstructor "Int" -3:13-16 TTypeConstructor "Int" -4:1-2 TFunction "f" -4:7-8 TFunction "g" -6:5-6 TFunction "g" -6:7-8 TVariable "x" diff --git a/plugins/hls-core-plugin/test/testdata/TFunctionLocal.hs b/plugins/hls-core-plugin/test/testdata/TFunctionLocal.hs deleted file mode 100644 index fed144b00c..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TFunctionLocal.hs +++ /dev/null @@ -1,8 +0,0 @@ -module TFunctionLocal where - -f :: Int -> Int -f 1 = g 1 - where - g x = 1 - - diff --git a/plugins/hls-core-plugin/test/testdata/TFunctionUnderTypeSynonym.expected b/plugins/hls-core-plugin/test/testdata/TFunctionUnderTypeSynonym.expected deleted file mode 100644 index 010cf0c613..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TFunctionUnderTypeSynonym.expected +++ /dev/null @@ -1,17 +0,0 @@ -3:6-8 TTypeSynonym "T1" -3:11-14 TTypeConstructor "Int" -3:18-21 TTypeConstructor "Int" -4:6-8 TTypeSynonym "T2" -4:18-19 TTypeVariable "a" -4:21-22 TTypeVariable "a" -4:26-27 TTypeVariable "a" -5:1-3 TFunction "f1" -5:7-9 TTypeSynonym "T1" -6:1-3 TFunction "f1" -6:4-5 TVariable "x" -6:8-9 TVariable "x" -7:1-3 TFunction "f2" -7:7-9 TTypeSynonym "T2" -8:1-3 TFunction "f2" -8:4-5 TVariable "x" -8:8-9 TVariable "x" diff --git a/plugins/hls-core-plugin/test/testdata/TFunctionUnderTypeSynonym.hs b/plugins/hls-core-plugin/test/testdata/TFunctionUnderTypeSynonym.hs deleted file mode 100644 index 6485232394..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TFunctionUnderTypeSynonym.hs +++ /dev/null @@ -1,9 +0,0 @@ -module TFunctionUnderTypeSynonym where - -type T1 = Int -> Int -type T2 = forall a. a -> a -f1 :: T1 -f1 x = x -f2 :: T2 -f2 x = x - diff --git a/plugins/hls-core-plugin/test/testdata/TGADT.expected b/plugins/hls-core-plugin/test/testdata/TGADT.expected deleted file mode 100644 index ad3ac0f086..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TGADT.expected +++ /dev/null @@ -1,13 +0,0 @@ -5:6-9 TTypeConstructor "Lam" -6:3-7 TDataConstructor "Lift" -6:11-12 TTypeVariable "a" -6:36-39 TTypeConstructor "Lam" -6:40-41 TTypeVariable "a" -7:3-6 TDataConstructor "Lam" -7:12-15 TTypeConstructor "Lam" -7:16-17 TTypeVariable "a" -7:21-24 TTypeConstructor "Lam" -7:25-26 TTypeVariable "b" -7:36-39 TTypeConstructor "Lam" -7:41-42 TTypeVariable "a" -7:46-47 TTypeVariable "b" diff --git a/plugins/hls-core-plugin/test/testdata/TGADT.hs b/plugins/hls-core-plugin/test/testdata/TGADT.hs deleted file mode 100644 index e0cccf8bed..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TGADT.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} -module TGADT where - -data Lam :: * -> * where - Lift :: a -> Lam a -- ^ lifted value - Lam :: (Lam a -> Lam b) -> Lam (a -> b) -- ^ lambda abstraction diff --git a/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodBind.expected b/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodBind.expected deleted file mode 100644 index a4a6ef98e0..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodBind.expected +++ /dev/null @@ -1,7 +0,0 @@ -4:6-9 TTypeConstructor "Foo" -4:12-15 TDataConstructor "Foo" -4:16-19 TTypeConstructor "Int" -5:10-14 TClass "Show" -5:15-18 TTypeConstructor "Foo" -6:5-9 TClassMethod "show" -6:12-21 TVariable "undefined" diff --git a/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodBind.hs b/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodBind.hs deleted file mode 100644 index 33976a48c1..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodBind.hs +++ /dev/null @@ -1,6 +0,0 @@ -module TInstanceClassMethodBind where - - -data Foo = Foo Int -instance Show Foo where - show = undefined diff --git a/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodUse.expected b/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodUse.expected deleted file mode 100644 index 2bf39be435..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodUse.expected +++ /dev/null @@ -1,2 +0,0 @@ -4:1-3 TFunction "go" -4:8-12 TClassMethod "show" diff --git a/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodUse.hs b/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodUse.hs deleted file mode 100644 index 689d1643d4..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TInstanceClassMethodUse.hs +++ /dev/null @@ -1,5 +0,0 @@ -module TInstanceClassMethodUse where - - -go = show - diff --git a/plugins/hls-core-plugin/test/testdata/TModuleA.hs b/plugins/hls-core-plugin/test/testdata/TModuleA.hs deleted file mode 100644 index d76f64fc1f..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TModuleA.hs +++ /dev/null @@ -1,5 +0,0 @@ -module TModuleA where - -data Game = Game {a𐐀b :: Int} - - diff --git a/plugins/hls-core-plugin/test/testdata/TModuleB.hs b/plugins/hls-core-plugin/test/testdata/TModuleB.hs deleted file mode 100644 index d2bfe4b7fa..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TModuleB.hs +++ /dev/null @@ -1,8 +0,0 @@ -module TModuleB where - -import TModuleA -import qualified TModuleA - -go = Game 1 - -a𐐀bb = TModuleA.a𐐀b go diff --git a/plugins/hls-core-plugin/test/testdata/TNoneFunctionWithConstraint.expected b/plugins/hls-core-plugin/test/testdata/TNoneFunctionWithConstraint.expected deleted file mode 100644 index 2dd89fd1da..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TNoneFunctionWithConstraint.expected +++ /dev/null @@ -1,6 +0,0 @@ -3:1-2 TVariable "x" -3:7-9 TClass "Eq" -3:10-11 TTypeVariable "a" -3:16-17 TTypeVariable "a" -4:1-2 TVariable "x" -4:5-14 TVariable "undefined" diff --git a/plugins/hls-core-plugin/test/testdata/TNoneFunctionWithConstraint.hs b/plugins/hls-core-plugin/test/testdata/TNoneFunctionWithConstraint.hs deleted file mode 100644 index 9a7119dbdb..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TNoneFunctionWithConstraint.hs +++ /dev/null @@ -1,5 +0,0 @@ -module TNoneFunctionWithConstraint where - -x :: (Eq a) => a -x = undefined - diff --git a/plugins/hls-core-plugin/test/testdata/TOperator.expected b/plugins/hls-core-plugin/test/testdata/TOperator.expected deleted file mode 100644 index c19e7cb904..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TOperator.expected +++ /dev/null @@ -1,33 +0,0 @@ -4:1-3 TFunction "go" -4:4-5 TFunction "f" -4:6-7 TVariable "x" -4:10-11 TFunction "f" -4:11-12 TOperator "$" -4:12-13 TVariable "x" -6:2-6 TOperator "$$$$" -7:1-2 TVariable "x" -7:7-11 TOperator "$$$$" -8:6-7 TTypeVariable "a" -8:8-11 TOperator ":+:" -8:12-13 TTypeVariable "b" -8:16-19 TDataConstructor "Add" -8:20-21 TTypeVariable "a" -8:22-23 TTypeVariable "b" -9:7-10 TOperator ":-:" -9:12-13 TTypeVariable "a" -9:14-15 TTypeVariable "b" -9:19-20 TTypeVariable "a" -9:22-23 TTypeVariable "b" -11:1-4 TFunction "add" -11:8-11 TTypeConstructor "Int" -11:12-15 TOperator ":+:" -11:16-19 TTypeConstructor "Int" -11:23-26 TTypeConstructor "Int" -11:27-30 TOperator ":-:" -11:31-34 TTypeConstructor "Int" -13:1-4 TFunction "add" -13:6-9 TDataConstructor "Add" -13:10-11 TVariable "x" -13:12-13 TVariable "y" -13:18-19 TVariable "x" -13:21-22 TVariable "y" diff --git a/plugins/hls-core-plugin/test/testdata/TOperator.hs b/plugins/hls-core-plugin/test/testdata/TOperator.hs deleted file mode 100644 index e2f06c92fa..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TOperator.hs +++ /dev/null @@ -1,13 +0,0 @@ -module TOperator where - --- imported operator -go f x = f$x --- operator defined in local module -($$$$) = b -x = 1 $$$$ 2 -data a :+: b = Add a b -type (:-:) a b = (a, b) --- type take precedence over operator -add :: Int :+: Int -> Int :-: Int --- class method take precedence over operator -add (Add x y) = (x, y) diff --git a/plugins/hls-core-plugin/test/testdata/TPatternMatch.expected b/plugins/hls-core-plugin/test/testdata/TPatternMatch.expected deleted file mode 100644 index 0535662e63..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TPatternMatch.expected +++ /dev/null @@ -1,2 +0,0 @@ -4:1-2 TFunction "g" -4:4-11 TDataConstructor "Nothing" diff --git a/plugins/hls-core-plugin/test/testdata/TPatternMatch.hs b/plugins/hls-core-plugin/test/testdata/TPatternMatch.hs deleted file mode 100644 index 95e97c1abb..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TPatternMatch.hs +++ /dev/null @@ -1,6 +0,0 @@ -module TPatternMatch where - - -g (Nothing, _) = 1 - - diff --git a/plugins/hls-core-plugin/test/testdata/TPatternSynonym.expected b/plugins/hls-core-plugin/test/testdata/TPatternSynonym.expected deleted file mode 100644 index 7cdf5260cb..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TPatternSynonym.expected +++ /dev/null @@ -1 +0,0 @@ -5:9-12 TPatternSynonym "Foo" diff --git a/plugins/hls-core-plugin/test/testdata/TPatternSynonym.hs b/plugins/hls-core-plugin/test/testdata/TPatternSynonym.hs deleted file mode 100644 index adff673ce8..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TPatternSynonym.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module TPatternSynonym where - - -pattern Foo = 1 - - diff --git a/plugins/hls-core-plugin/test/testdata/TPatternbind.expected b/plugins/hls-core-plugin/test/testdata/TPatternbind.expected deleted file mode 100644 index 6c62634487..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TPatternbind.expected +++ /dev/null @@ -1,7 +0,0 @@ -3:2-3 TVariable "a" -3:5-6 TVariable "b" -5:1-2 TFunction "f" -5:3-4 TFunction "g" -5:5-6 TVariable "y" -5:9-10 TFunction "g" -5:11-12 TVariable "y" diff --git a/plugins/hls-core-plugin/test/testdata/TPatternbind.hs b/plugins/hls-core-plugin/test/testdata/TPatternbind.hs deleted file mode 100644 index 49e642a35d..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TPatternbind.hs +++ /dev/null @@ -1,9 +0,0 @@ -module TVariable where - -(a, b) = (1, 2) - -f g y = g y - - - - diff --git a/plugins/hls-core-plugin/test/testdata/TQualifiedName.expected b/plugins/hls-core-plugin/test/testdata/TQualifiedName.expected deleted file mode 100644 index 0ca7cd7d5b..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TQualifiedName.expected +++ /dev/null @@ -1,12 +0,0 @@ -3:18-27 TModule "Data.List" -6:1-2 TVariable "a" -6:5-13 TModule "Prelude." -6:13-22 TVariable "undefined" -7:1-2 TVariable "b" -7:8-18 TModule "Data.List." -7:18-22 TClassMethod "elem" -8:1-2 TVariable "c" -8:6-14 TModule "Prelude." -8:14-15 TOperator "+" -9:1-2 TVariable "d" -9:6-7 TOperator "+" diff --git a/plugins/hls-core-plugin/test/testdata/TQualifiedName.hs b/plugins/hls-core-plugin/test/testdata/TQualifiedName.hs deleted file mode 100644 index 5dbdcc1d52..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TQualifiedName.hs +++ /dev/null @@ -1,9 +0,0 @@ -module TQualifiedName where - -import qualified Data.List - - -a = Prelude.undefined -b = 1 `Data.List.elem` [1, 2] -c = (Prelude.+) 1 1 -d = (+) 1 1 diff --git a/plugins/hls-core-plugin/test/testdata/TRecord.expected b/plugins/hls-core-plugin/test/testdata/TRecord.expected deleted file mode 100644 index 43b8e4d3b0..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TRecord.expected +++ /dev/null @@ -1,4 +0,0 @@ -4:6-9 TTypeConstructor "Foo" -4:12-15 TDataConstructor "Foo" -4:18-21 TRecordField "foo" -4:25-28 TTypeConstructor "Int" diff --git a/plugins/hls-core-plugin/test/testdata/TRecord.hs b/plugins/hls-core-plugin/test/testdata/TRecord.hs deleted file mode 100644 index b3176a154f..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TRecord.hs +++ /dev/null @@ -1,7 +0,0 @@ -module TRecord where - - -data Foo = Foo { foo :: Int } - - - diff --git a/plugins/hls-core-plugin/test/testdata/TRecordDuplicateRecordFields.expected b/plugins/hls-core-plugin/test/testdata/TRecordDuplicateRecordFields.expected deleted file mode 100644 index 70fdc63e18..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TRecordDuplicateRecordFields.expected +++ /dev/null @@ -1,4 +0,0 @@ -5:6-9 TTypeConstructor "Foo" -5:12-15 TDataConstructor "Foo" -5:18-21 TRecordField "boo" -5:26-32 TTypeSynonym "String" diff --git a/plugins/hls-core-plugin/test/testdata/TRecordDuplicateRecordFields.hs b/plugins/hls-core-plugin/test/testdata/TRecordDuplicateRecordFields.hs deleted file mode 100644 index 395a1d3731..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TRecordDuplicateRecordFields.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} - -module TRecordDuplicateRecordFields where - -data Foo = Foo { boo :: !String } diff --git a/plugins/hls-core-plugin/test/testdata/TTypefamily.expected b/plugins/hls-core-plugin/test/testdata/TTypefamily.expected deleted file mode 100644 index 08019bc3f3..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TTypefamily.expected +++ /dev/null @@ -1,8 +0,0 @@ -4:13-16 TTypeFamily "Foo" -4:17-18 TTypeVariable "a" -5:3-6 TTypeFamily "Foo" -5:7-10 TTypeConstructor "Int" -5:13-16 TTypeConstructor "Int" -6:3-6 TTypeFamily "Foo" -6:7-8 TTypeVariable "a" -6:11-17 TTypeSynonym "String" diff --git a/plugins/hls-core-plugin/test/testdata/TTypefamily.hs b/plugins/hls-core-plugin/test/testdata/TTypefamily.hs deleted file mode 100644 index d8c925e370..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TTypefamily.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module TTypefamily where - -type family Foo a where - Foo Int = Int - Foo a = String diff --git a/plugins/hls-core-plugin/test/testdata/TUnicodeSyntax.expected b/plugins/hls-core-plugin/test/testdata/TUnicodeSyntax.expected deleted file mode 100644 index 0b94b7c045..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TUnicodeSyntax.expected +++ /dev/null @@ -1 +0,0 @@ -3:1-4 TVariable "a\66560b" diff --git a/plugins/hls-core-plugin/test/testdata/TUnicodeSyntax.hs b/plugins/hls-core-plugin/test/testdata/TUnicodeSyntax.hs deleted file mode 100644 index 1b8c7c1baa..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TUnicodeSyntax.hs +++ /dev/null @@ -1,5 +0,0 @@ -module TUnicodeSyntax where - -a𐐀b = "a𐐀b" - - diff --git a/plugins/hls-core-plugin/test/testdata/TValBind.expected b/plugins/hls-core-plugin/test/testdata/TValBind.expected deleted file mode 100644 index ec20b01e56..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TValBind.expected +++ /dev/null @@ -1,4 +0,0 @@ -4:1-6 TVariable "hello" -4:10-13 TTypeConstructor "Int" -5:1-6 TVariable "hello" -5:9-15 TClassMethod "length" diff --git a/plugins/hls-core-plugin/test/testdata/TValBind.hs b/plugins/hls-core-plugin/test/testdata/TValBind.hs deleted file mode 100644 index 506af37a42..0000000000 --- a/plugins/hls-core-plugin/test/testdata/TValBind.hs +++ /dev/null @@ -1,8 +0,0 @@ -module TValBind where - - -hello :: Int -hello = length "Hello, Haskell!" - - - From f906b04f526494fdfbdb3c8fdc0b901773c6c72c Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 24 Mar 2024 04:33:00 +0800 Subject: [PATCH 04/34] update workflow --- .github/workflows/test.yml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 0fbfc1c8c8..6401fea4c4 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -114,6 +114,10 @@ jobs: name: Test hls-graph run: cabal test hls-graph + - if: matrix.test + name: Test hls-core-plugin test suite + run: cabal test hls-core-plugin + - if: needs.pre_job.outputs.should_skip_ghcide != 'true' && matrix.test name: Test ghcide # run the tests without parallelism to avoid running out of memory @@ -254,6 +258,7 @@ jobs: name: Test hls-notes-plugin test suite run: cabal test hls-notes-plugin-tests || cabal test hls-notes-plugin-tests + test_post_job: if: always() runs-on: ubuntu-latest From 61cd7b93593908d843770c4c410cecad740aecb7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 24 Mar 2024 04:38:42 +0800 Subject: [PATCH 05/34] remove gheide test from core plugin --- haskell-language-server.cabal | 1 - plugins/hls-core-plugin/src/Ide/Plugin/Core.hs | 1 - plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs | 5 ----- 3 files changed, 7 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index d128eb5591..46ed50754f 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1765,7 +1765,6 @@ test-suite hls-core-plugin-tests , filepath , haskell-language-server:hls-core-plugin , hls-test-utils == 2.7.0.0 - , ghcide:ghcide-test-utils , hls-plugin-api , lens , lsp diff --git a/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs b/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs index e09a902e40..c953a2dd13 100644 --- a/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs +++ b/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs @@ -33,7 +33,6 @@ descriptor recorder plId = } - wsSymbols :: Recorder (WithPriority CoreLog) -> PluginMethodHandler IdeState Method_WorkspaceSymbol wsSymbols logger ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do logWith logger Debug $ CoreLogMsg $ "Workspace symbols request: " <> query diff --git a/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs b/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs index 2faf5da954..5d6e27c4d6 100644 --- a/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs +++ b/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs @@ -12,11 +12,6 @@ import qualified Data.Text as T import Development.IDE.Plugin.TypeLenses (typeLensCommandId) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message --- import qualified Language.LSP.Protocol.Types hiding --- (SemanticTokenAbsolute (..), --- SemanticTokenRelative (..), --- SemanticTokensEdit (..), --- mkRange) import Language.LSP.Test import Control.Lens ((^.)) From 313c58594d177c31b894eb19e4b3c280449a3bb0 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 24 Mar 2024 04:57:09 +0800 Subject: [PATCH 06/34] fix workflows --- .github/workflows/test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 6401fea4c4..611d2fa569 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -116,7 +116,7 @@ jobs: - if: matrix.test name: Test hls-core-plugin test suite - run: cabal test hls-core-plugin + run: cabal test hls-core-plugin-test - if: needs.pre_job.outputs.should_skip_ghcide != 'true' && matrix.test name: Test ghcide From 748336ebbc8d689e117cdfd13ce2e9242ee8e344 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 24 Mar 2024 05:11:28 +0800 Subject: [PATCH 07/34] fix workflows --- .github/workflows/test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 611d2fa569..7798566e18 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -116,7 +116,7 @@ jobs: - if: matrix.test name: Test hls-core-plugin test suite - run: cabal test hls-core-plugin-test + run: cabal test hls-core-plugin-tests - if: needs.pre_job.outputs.should_skip_ghcide != 'true' && matrix.test name: Test ghcide From 71094ef61382aeb54b52201b38617541334e0563 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 5 Apr 2024 11:39:33 +0800 Subject: [PATCH 08/34] move references out --- .../Development/IDE/LSP/HoverDefinition.hs | 10 +-------- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 2 +- .../hls-core-plugin/src/Ide/Plugin/Core.hs | 22 ++++++++++++++++--- 3 files changed, 21 insertions(+), 13 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index 1aa531293e..cc2844a7de 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -10,7 +10,7 @@ module Development.IDE.LSP.HoverDefinition , gotoDefinition , gotoTypeDefinition , documentHighlight - , references + -- , references -- , wsSymbols ) where @@ -39,14 +39,6 @@ gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) hover = request "Hover" getAtPoint (InR Null) foundHover documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL -references :: PluginMethodHandler IdeState Method_TextDocumentReferences -references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do - nfp <- getNormalizedFilePathE uri - liftIO $ logDebug (ideLogger ide) $ - "References request at position " <> T.pack (showPosition pos) <> - " in file: " <> T.pack (show nfp) - InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos) - foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null foundHover (mbRange, contents) = diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index bdd3ab222d..f89a80f5aa 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -51,7 +51,7 @@ descriptor plId = (defaultPluginDescriptor plId desc) gotoTypeDefinition ide TextDocumentPositionParams{..}) <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> documentHighlight ide TextDocumentPositionParams{..}) - <> mkPluginHandler SMethod_TextDocumentReferences references, + , pluginConfigDescriptor = defaultConfigDescriptor } diff --git a/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs b/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs index c953a2dd13..138981e04c 100644 --- a/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs +++ b/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs @@ -6,12 +6,16 @@ module Ide.Plugin.Core(descriptor, CoreLog) where import Control.Monad.IO.Class (liftIO) import Data.Maybe (fromMaybe) import Data.Text (Text) +import qualified Data.Text as T import Development.IDE -import Development.IDE.Core.Actions (workspaceSymbols) +import Development.IDE.Core.Actions (refsAtPoint, workspaceSymbols) import qualified Development.IDE.Core.Shake as Shake +import Ide.Plugin.Error (getNormalizedFilePathE) import Ide.Types import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types (WorkspaceSymbolParams (..), +import Language.LSP.Protocol.Types (ReferenceParams (..), + TextDocumentIdentifier (..), + WorkspaceSymbolParams (..), type (|?) (InL)) data CoreLog @@ -29,7 +33,9 @@ descriptor :: Recorder (WithPriority CoreLog) -> PluginId -> PluginDescriptor Id descriptor recorder plId = (defaultPluginDescriptor plId "Provides core IDE features for Haskell") { - Ide.Types.pluginHandlers = mkPluginHandler SMethod_WorkspaceSymbol (wsSymbols recorder) + Ide.Types.pluginHandlers = + mkPluginHandler SMethod_WorkspaceSymbol (wsSymbols recorder) + <> mkPluginHandler SMethod_TextDocumentReferences references } @@ -37,3 +43,13 @@ wsSymbols :: Recorder (WithPriority CoreLog) -> PluginMethodHandler IdeState Met wsSymbols logger ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do logWith logger Debug $ CoreLogMsg $ "Workspace symbols request: " <> query runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ InL . fromMaybe [] <$> workspaceSymbols query + + + +references :: PluginMethodHandler IdeState Method_TextDocumentReferences +references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do + nfp <- getNormalizedFilePathE uri + liftIO $ logDebug (ideLogger ide) $ + "References request at position " <> T.pack (showPosition pos) <> + " in file: " <> T.pack (show nfp) + InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos) From bd3616ce7ce9ef5b829d4f4835e59fcca7aa25bd Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 5 Apr 2024 11:45:24 +0800 Subject: [PATCH 09/34] add core actions --- ghcide/src/Development/IDE/Core/Actions.hs | 13 ------- haskell-language-server.cabal | 1 + .../hls-core-plugin/src/Ide/Plugin/Core.hs | 2 +- .../src/Ide/Plugin/Core/Actions.hs | 39 +++++++++++++++++++ 4 files changed, 41 insertions(+), 14 deletions(-) create mode 100644 plugins/hls-core-plugin/src/Ide/Plugin/Core/Actions.hs diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 4c808f21d9..5232302213 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -4,7 +4,6 @@ module Development.IDE.Core.Actions , getDefinition , getTypeDefinition , highlightAtPoint -, refsAtPoint , workspaceSymbols , lookupMod ) where @@ -124,16 +123,4 @@ highlightAtPoint file pos = runMaybeT $ do let toCurrentHighlight (DocumentHighlight range t) = flip DocumentHighlight t <$> toCurrentRange mapping range mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos' --- Refs are not an IDE action, so it is OK to be slow and (more) accurate -refsAtPoint :: NormalizedFilePath -> Position -> Action [Location] -refsAtPoint file pos = do - ShakeExtras{withHieDb} <- getShakeExtras - fs <- HM.keys <$> getFilesOfInterestUntracked - asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst fs - AtPoint.referencesAtPoint withHieDb file pos (AtPoint.FOIReferences asts) -workspaceSymbols :: T.Text -> IdeAction (Maybe [SymbolInformation]) -workspaceSymbols query = runMaybeT $ do - ShakeExtras{withHieDb} <- ask - res <- liftIO $ withHieDb (\hieDb -> HieDb.searchDef hieDb $ T.unpack query) - pure $ mapMaybe AtPoint.defRowToSymbolInfo res diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 46ed50754f..41a22d164b 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1722,6 +1722,7 @@ library hls-core-plugin buildable: True exposed-modules: Ide.Plugin.Core + Ide.Plugin.Core.Actions hs-source-dirs: plugins/hls-core-plugin/src build-depends: diff --git a/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs b/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs index 138981e04c..2cc888bf5b 100644 --- a/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs +++ b/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs @@ -8,8 +8,8 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Development.IDE -import Development.IDE.Core.Actions (refsAtPoint, workspaceSymbols) import qualified Development.IDE.Core.Shake as Shake +import Ide.Plugin.Core.Actions (refsAtPoint, workspaceSymbols) import Ide.Plugin.Error (getNormalizedFilePathE) import Ide.Types import Language.LSP.Protocol.Message diff --git a/plugins/hls-core-plugin/src/Ide/Plugin/Core/Actions.hs b/plugins/hls-core-plugin/src/Ide/Plugin/Core/Actions.hs new file mode 100644 index 0000000000..cf88c7431b --- /dev/null +++ b/plugins/hls-core-plugin/src/Ide/Plugin/Core/Actions.hs @@ -0,0 +1,39 @@ +module Ide.Plugin.Core.Actions where + +import Control.Monad.Extra (mapMaybeM) +import Control.Monad.Reader +import Control.Monad.Trans.Maybe +import Data.Maybe +import qualified Data.Text as T +import Data.Tuple.Extra +import Development.IDE.Core.OfInterest +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.PositionMapping +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Service +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat hiding (writeHieFile) +import Development.IDE.Graph +import qualified Development.IDE.Spans.AtPoint as AtPoint +import Development.IDE.Types.HscEnvEq (hscEnv) +import Development.IDE.Types.Location +import Language.LSP.Protocol.Types (DocumentHighlight (..), + SymbolInformation (..), + normalizedFilePathToUri, + uriToNormalizedFilePath) + + +-- Refs are not an IDE action, so it is OK to be slow and (more) accurate +refsAtPoint :: NormalizedFilePath -> Position -> Action [Location] +refsAtPoint file pos = do + ShakeExtras{withHieDb} <- getShakeExtras + fs <- HM.keys <$> getFilesOfInterestUntracked + asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst fs + AtPoint.referencesAtPoint withHieDb file pos (AtPoint.FOIReferences asts) + + +workspaceSymbols :: T.Text -> IdeAction (Maybe [SymbolInformation]) +workspaceSymbols query = runMaybeT $ do + ShakeExtras{withHieDb} <- ask + res <- liftIO $ withHieDb (\hieDb -> HieDb.searchDef hieDb $ T.unpack query) + pure $ mapMaybe AtPoint.defRowToSymbolInfo res From ac8edef6b929df33b8068402bde3102f0c35712d Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 5 Apr 2024 11:46:26 +0800 Subject: [PATCH 10/34] fix export of actions --- ghcide/src/Development/IDE/Core/Actions.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 5232302213..a3045301b9 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -4,7 +4,6 @@ module Development.IDE.Core.Actions , getDefinition , getTypeDefinition , highlightAtPoint -, workspaceSymbols , lookupMod ) where From 722e8536539937da0b40401b62b60a546a2ca575 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 5 Apr 2024 11:51:45 +0800 Subject: [PATCH 11/34] fix deps --- haskell-language-server.cabal | 2 ++ plugins/hls-core-plugin/src/Ide/Plugin/Core/Actions.hs | 3 +++ 2 files changed, 5 insertions(+) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 41a22d164b..5147a10104 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1728,6 +1728,7 @@ library hls-core-plugin build-depends: , base >=4.12 && <5 , containers + , unordered-containers , extra , text-rope , mtl >= 2.2 @@ -1735,6 +1736,7 @@ library hls-core-plugin , hls-plugin-api == 2.7.0.0 , lens , lsp >=2.4 + , hiedb ^>= 0.6.0.0 , text , transformers , bytestring diff --git a/plugins/hls-core-plugin/src/Ide/Plugin/Core/Actions.hs b/plugins/hls-core-plugin/src/Ide/Plugin/Core/Actions.hs index cf88c7431b..4a5d3879f5 100644 --- a/plugins/hls-core-plugin/src/Ide/Plugin/Core/Actions.hs +++ b/plugins/hls-core-plugin/src/Ide/Plugin/Core/Actions.hs @@ -22,6 +22,9 @@ import Language.LSP.Protocol.Types (DocumentHighlight (..), normalizedFilePathToUri, uriToNormalizedFilePath) +import qualified Data.HashMap.Strict as HM +import qualified HieDb + -- Refs are not an IDE action, so it is OK to be slow and (more) accurate refsAtPoint :: NormalizedFilePath -> Position -> Action [Location] From ec55c2162f73c2f5ef57a3fa942ad4125a332b4b Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 5 Apr 2024 12:32:43 +0800 Subject: [PATCH 12/34] move more --- .pre-commit-config.yaml | 3 +- ghcide/ghcide.cabal | 3 - .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 27 +----- ghcide/test/exe/InitializeResponseTests.hs | 97 ------------------- ghcide/test/exe/Main.hs | 2 - haskell-language-server.cabal | 3 + .../hls-core-plugin/src/Ide/Plugin/Core.hs | 46 ++++++--- .../src/Ide/Plugin/Core}/HoverDefinition.hs | 7 +- .../src/Ide/Plugin/Core}/Outline.hs | 7 +- 9 files changed, 52 insertions(+), 143 deletions(-) delete mode 100644 ghcide/test/exe/InitializeResponseTests.hs rename {ghcide/src/Development/IDE/LSP => plugins/hls-core-plugin/src/Ide/Plugin/Core}/HoverDefinition.hs (94%) rename {ghcide/src/Development/IDE/LSP => plugins/hls-core-plugin/src/Ide/Plugin/Core}/Outline.hs (98%) diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml index 9ef5013bd1..455c151fcc 100644 --- a/.pre-commit-config.yaml +++ b/.pre-commit-config.yaml @@ -4,7 +4,8 @@ "hooks": [ { "entry": "stylish-haskell --inplace", - "exclude": "(^Setup.hs$|test/testdata/.*$|test/data/.*$|test/manual/lhs/.*$|^hie-compat/.*$|^plugins/hls-tactics-plugin/.*$|^ghcide/src/Development/IDE/GHC/Compat.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs$|^ghcide/src/Development/IDE/GHC/Compat/Core.hs$|^ghcide/src/Development/IDE/Spans/Pragmas.hs$|^ghcide/src/Development/IDE/LSP/Outline.hs$|^plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs$|^ghcide/test/exe/Main.hs$|^ghcide/src/Development/IDE/Core/Rules.hs$|^hls-test-utils/src/Test/Hls/Util.hs$|^ghcide/src/Development/IDE/Core/Compile.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs$)", + "exclude": "(^Setup.hs$|test/testdata/.*$|test/data/.*$|test/manual/lhs/.*$|^hie-compat/.*$|^plugins/hls-tactics-plugin/.*$|^ghcide/src/Development/IDE/GHC/Compat.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs$|^ghcide/src/Development/IDE/GHC/Compat/Core.hs$|^ghcide/src/Development/IDE/Spans/Pragmas.hs$|^ghcide/src/Development/IDE/LSP/Outline.hs$|^plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs$|^ghcide/test/exe/Main.hs$|^ghcide/src/Development/IDE/Core/Rules.hs$|^hls-test-utils/src/Test/Hls/Util.hs$|^ghcide/src/Development/IDE/Core/Compile.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs$ + |^plugins/hls-core-plugin/Core/Outline.hs$)", "files": "\\.l?hs$", "id": "stylish-haskell", "language": "system", diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 16aeaa06de..393f521150 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -164,10 +164,8 @@ library Development.IDE.GHC.Util Development.IDE.Import.DependencyInformation Development.IDE.Import.FindImports - Development.IDE.LSP.HoverDefinition Development.IDE.LSP.LanguageServer Development.IDE.LSP.Notifications - Development.IDE.LSP.Outline Development.IDE.LSP.Server Development.IDE.Main Development.IDE.Main.HeapStats @@ -371,7 +369,6 @@ test-suite ghcide-tests HieDbRetry HighlightTests IfaceTests - InitializeResponseTests LogType NonLspCommandLine OpenCloseTest diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index f89a80f5aa..831747737b 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -9,15 +9,13 @@ module Development.IDE.Plugin.HLS.GhcIde ) where import Control.Monad.IO.Class import Development.IDE -import Development.IDE.LSP.HoverDefinition -import qualified Development.IDE.LSP.Notifications as Notifications -import Development.IDE.LSP.Outline -import qualified Development.IDE.Plugin.Completions as Completions -import qualified Development.IDE.Plugin.TypeLenses as TypeLenses +import qualified Development.IDE.LSP.Notifications as Notifications +import qualified Development.IDE.Plugin.Completions as Completions +import qualified Development.IDE.Plugin.TypeLenses as TypeLenses import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import Text.Regex.TDFA.Text () +import Text.Regex.TDFA.Text () data Log = LogNotifications Notifications.Log @@ -43,24 +41,9 @@ descriptors recorder = descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId desc) - { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover hover' - <> mkPluginHandler SMethod_TextDocumentDocumentSymbol moduleOutline - <> mkPluginHandler SMethod_TextDocumentDefinition (\ide _ DefinitionParams{..} -> - gotoDefinition ide TextDocumentPositionParams{..}) - <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} -> - gotoTypeDefinition ide TextDocumentPositionParams{..}) - <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> - documentHighlight ide TextDocumentPositionParams{..}) - , - - pluginConfigDescriptor = defaultConfigDescriptor - } + { pluginConfigDescriptor = defaultConfigDescriptor } where desc = "Provides core IDE features for Haskell" -- --------------------------------------------------------------------- -hover' :: PluginMethodHandler IdeState Method_TextDocumentHover -hover' ideState _ HoverParams{..} = do - liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ - hover ideState TextDocumentPositionParams{..} diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs deleted file mode 100644 index e4a47838aa..0000000000 --- a/ghcide/test/exe/InitializeResponseTests.hs +++ /dev/null @@ -1,97 +0,0 @@ - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedLabels #-} - -module InitializeResponseTests (tests) where - -import Control.Monad -import Data.List.Extra -import Data.Row -import qualified Data.Text as T -import Development.IDE.Plugin.TypeLenses (typeLensCommandId) -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding - (SemanticTokenAbsolute (..), - SemanticTokenRelative (..), - SemanticTokensEdit (..), - mkRange) -import Language.LSP.Test - -import Control.Lens ((^.)) -import Development.IDE.Plugin.Test (blockCommandId) -import Test.Tasty -import Test.Tasty.HUnit -import TestUtils - -tests :: TestTree -tests = withResource acquire release tests where - - -- these tests document and monitor the evolution of the - -- capabilities announced by the server in the initialize - -- response. Currently the server advertises almost no capabilities - -- at all, in some cases failing to announce capabilities that it - -- actually does provide! Hopefully this will change ... - tests :: IO (TResponseMessage Method_Initialize) -> TestTree - tests getInitializeResponse = - testGroup "initialize response capabilities" - [ chk " text doc sync" _textDocumentSync tds - , chk " hover" _hoverProvider (Just $ InR (HoverOptions (Just False))) - , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing (Just True) Nothing) - , chk "NO signature help" _signatureHelpProvider Nothing - , chk " goto definition" _definitionProvider (Just $ InR (DefinitionOptions (Just False))) - , chk " goto type definition" _typeDefinitionProvider (Just $ InR (InL (TypeDefinitionOptions (Just False)))) - -- BUG in lsp-test, this test fails, just change the accepted response - -- for now - , chk "NO goto implementation" _implementationProvider Nothing - , chk " find references" _referencesProvider (Just $ InR (ReferenceOptions (Just False))) - , chk " doc highlight" _documentHighlightProvider (Just $ InR (DocumentHighlightOptions (Just False))) - , chk " doc symbol" _documentSymbolProvider (Just $ InR (DocumentSymbolOptions (Just False) Nothing)) - -- , chk " workspace symbol" _workspaceSymbolProvider (Just $ InR (WorkspaceSymbolOptions (Just False) (Just False))) - , chk "NO code action" _codeActionProvider Nothing - , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just True)) - , chk "NO doc formatting" _documentFormattingProvider Nothing - , chk "NO doc range formatting" - _documentRangeFormattingProvider Nothing - , chk "NO doc formatting on typing" - _documentOnTypeFormattingProvider Nothing - , chk "NO renaming" _renameProvider Nothing - , chk "NO doc link" _documentLinkProvider Nothing - , chk "NO color" (^. L.colorProvider) Nothing - , chk "NO folding range" _foldingRangeProvider Nothing - , che " execute command" _executeCommandProvider [typeLensCommandId, blockCommandId] - , chk " workspace" (^. L.workspace) (Just $ #workspaceFolders .== Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )} - .+ #fileOperations .== Nothing) - , chk "NO experimental" (^. L.experimental) Nothing - ] where - - tds = Just (InL (TextDocumentSyncOptions - { _openClose = Just True - , _change = Just TextDocumentSyncKind_Incremental - , _willSave = Nothing - , _willSaveWaitUntil = Nothing - , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) - - chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree - chk title getActual expected = - testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir - - che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree - che title getActual expected = testCase title $ do - ir <- getInitializeResponse - ExecuteCommandOptions {_commands = commands} <- case getActual $ innerCaps ir of - Just eco -> pure eco - Nothing -> assertFailure "Was expecting Just ExecuteCommandOptions, got Nothing" - let commandNames = (!! 2) . T.splitOn ":" <$> commands - zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames) - - innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities - innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c - innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error" - - acquire :: IO (TResponseMessage Method_Initialize) - acquire = run initializeResponse - - release :: TResponseMessage Method_Initialize -> IO () - release = mempty - diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 412a6969fe..8cc408187b 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -47,7 +47,6 @@ import Test.Tasty.Ingredients.Rerun import LogType () import OpenCloseTest -import InitializeResponseTests import CompletionTests import CPPTests import DiagnosticTests @@ -93,7 +92,6 @@ main = do -- We mess with env vars so run single-threaded. defaultMainWithRerun $ testGroup "ghcide" [ OpenCloseTest.tests - , InitializeResponseTests.tests , CompletionTests.tests , CPPTests.tests , DiagnosticTests.tests diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 5147a10104..a2f7b4349f 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1723,6 +1723,8 @@ library hls-core-plugin exposed-modules: Ide.Plugin.Core Ide.Plugin.Core.Actions + Ide.Plugin.Core.HoverDefinition + Ide.Plugin.Core.Outline hs-source-dirs: plugins/hls-core-plugin/src build-depends: @@ -1730,6 +1732,7 @@ library hls-core-plugin , containers , unordered-containers , extra + , ghc , text-rope , mtl >= 2.2 , ghcide == 2.7.0.0 diff --git a/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs b/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs index 2cc888bf5b..8af8fa993d 100644 --- a/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs +++ b/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs @@ -1,22 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Ide.Plugin.Core(descriptor, CoreLog) where -import Control.Monad.IO.Class (liftIO) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T +import Control.Monad.IO.Class (liftIO) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T import Development.IDE -import qualified Development.IDE.Core.Shake as Shake -import Ide.Plugin.Core.Actions (refsAtPoint, workspaceSymbols) -import Ide.Plugin.Error (getNormalizedFilePathE) +import qualified Development.IDE.Core.Shake as Shake +import Ide.Plugin.Core.Actions (refsAtPoint, workspaceSymbols) +import Ide.Plugin.Core.HoverDefinition +import Ide.Plugin.Core.Outline (moduleOutline) +import Ide.Plugin.Error (getNormalizedFilePathE) import Ide.Types import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types (ReferenceParams (..), - TextDocumentIdentifier (..), - WorkspaceSymbolParams (..), - type (|?) (InL)) +import Language.LSP.Protocol.Types (DefinitionParams (..), + DocumentHighlightParams (..), + HoverParams (..), + ReferenceParams (..), + TextDocumentIdentifier (..), + TextDocumentPositionParams (..), + TypeDefinitionParams (..), + WorkspaceSymbolParams (..), + type (|?) (InL)) data CoreLog = LogShake Shake.Log @@ -34,7 +42,15 @@ descriptor recorder plId = (defaultPluginDescriptor plId "Provides core IDE features for Haskell") { Ide.Types.pluginHandlers = - mkPluginHandler SMethod_WorkspaceSymbol (wsSymbols recorder) + mkPluginHandler SMethod_TextDocumentDocumentSymbol moduleOutline + <> mkPluginHandler SMethod_TextDocumentDefinition (\ide _ DefinitionParams{..} -> + gotoDefinition ide TextDocumentPositionParams{..}) + <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} -> + gotoTypeDefinition ide TextDocumentPositionParams{..}) + <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> + documentHighlight ide TextDocumentPositionParams{..}) + <> mkPluginHandler SMethod_TextDocumentHover hover' + <> mkPluginHandler SMethod_WorkspaceSymbol (wsSymbols recorder) <> mkPluginHandler SMethod_TextDocumentReferences references } @@ -53,3 +69,9 @@ references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do "References request at position " <> T.pack (showPosition pos) <> " in file: " <> T.pack (show nfp) InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos) + + +hover' :: PluginMethodHandler IdeState Method_TextDocumentHover +hover' ideState _ HoverParams{..} = do + liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ + hover ideState TextDocumentPositionParams{..} diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/plugins/hls-core-plugin/src/Ide/Plugin/Core/HoverDefinition.hs similarity index 94% rename from ghcide/src/Development/IDE/LSP/HoverDefinition.hs rename to plugins/hls-core-plugin/src/Ide/Plugin/Core/HoverDefinition.hs index cc2844a7de..5ebc03e5c3 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/plugins/hls-core-plugin/src/Ide/Plugin/Core/HoverDefinition.hs @@ -1,9 +1,8 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} -- | Display information on hover. -module Development.IDE.LSP.HoverDefinition +module Ide.Plugin.Core.HoverDefinition ( -- * For haskell-language-server hover diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/plugins/hls-core-plugin/src/Ide/Plugin/Core/Outline.hs similarity index 98% rename from ghcide/src/Development/IDE/LSP/Outline.hs rename to plugins/hls-core-plugin/src/Ide/Plugin/Core/Outline.hs index 4f350b52d0..96679dd907 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/plugins/hls-core-plugin/src/Ide/Plugin/Core/Outline.hs @@ -1,9 +1,12 @@ {-# LANGUAGE CPP #-} - {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} -module Development.IDE.LSP.Outline +module Ide.Plugin.Core.Outline ( moduleOutline ) where From 4f91a2084b686a449bcdcddc4a5c0dbaa0a12003 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 5 Apr 2024 12:59:37 +0800 Subject: [PATCH 13/34] add test --- ghcide/ghcide.cabal | 1 - ghcide/test/exe/Main.hs | 1 - ghcide/test/exe/OutlineTests.hs | 189 ---------------- haskell-language-server.cabal | 3 + .../hls-core-plugin/src/Ide/Plugin/Core.hs | 6 +- plugins/hls-core-plugin/test/CoreTest.hs | 5 +- .../test/exe/InitializeResponseTests.hs | 15 +- .../hls-core-plugin/test/exe/OutlineTests.hs | 209 ++++++++++++++++++ plugins/hls-core-plugin/test/exe/Util.hs | 27 +++ 9 files changed, 247 insertions(+), 209 deletions(-) delete mode 100644 ghcide/test/exe/OutlineTests.hs create mode 100644 plugins/hls-core-plugin/test/exe/OutlineTests.hs create mode 100644 plugins/hls-core-plugin/test/exe/Util.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 393f521150..a64e027d14 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -372,7 +372,6 @@ test-suite ghcide-tests LogType NonLspCommandLine OpenCloseTest - OutlineTests PluginSimpleTests PositionMappingTests PreprocessorTests diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 8cc408187b..0bd4af5b0d 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -96,7 +96,6 @@ main = do , CPPTests.tests , DiagnosticTests.tests , CodeLensTests.tests - , OutlineTests.tests , HighlightTests.tests , FindDefinitionAndHoverTests.tests , PluginSimpleTests.tests diff --git a/ghcide/test/exe/OutlineTests.hs b/ghcide/test/exe/OutlineTests.hs deleted file mode 100644 index 6459e1deca..0000000000 --- a/ghcide/test/exe/OutlineTests.hs +++ /dev/null @@ -1,189 +0,0 @@ - -module OutlineTests (tests) where - -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text as T -import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), - SemanticTokenRelative (..), - SemanticTokensEdit (..), mkRange) -import Language.LSP.Test -import Test.Tasty -import Test.Tasty.HUnit -import TestUtils - -tests :: TestTree -tests = testGroup - "outline" - [ testSessionWait "type class" $ do - let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ moduleSymbol - "A" - (R 0 7 0 8) - [ classSymbol "A a" - (R 1 0 1 30) - [docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)] - ] - ] - , testSessionWait "type class instance " $ do - let source = T.unlines ["class A a where", "instance A () where"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ classSymbol "A a" (R 0 0 0 15) [] - , docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19) - ] - , testSessionWait "type family" $ do - let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)] - , testSessionWait "type family instance " $ do - let source = T.unlines - [ "{-# language TypeFamilies #-}" - , "type family A a" - , "type instance A () = ()" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15) - , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23) - ] - , testSessionWait "data family" $ do - let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)] - , testSessionWait "data family instance " $ do - let source = T.unlines - [ "{-# language TypeFamilies #-}" - , "data family A a" - , "data instance A () = A ()" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 11) - , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25) - ] - , testSessionWait "constant" $ do - let source = T.unlines ["a = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbol "a" SymbolKind_Function (R 0 0 0 6)] - , testSessionWait "pattern" $ do - let source = T.unlines ["Just foo = Just 21"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)] - , testSessionWait "pattern with type signature" $ do - let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)] - , testSessionWait "function" $ do - let source = T.unlines ["a _x = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right [docSymbol "a" SymbolKind_Function (R 0 0 0 9)] - , testSessionWait "type synonym" $ do - let source = T.unlines ["type A = Bool"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)] - , testSessionWait "datatype" $ do - let source = T.unlines ["data A = C"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ docSymbolWithChildren "A" - SymbolKind_Struct - (R 0 0 0 10) - [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)] - ] - , testSessionWait "record fields" $ do - let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 2 13) - [ docSymbolWithChildren' "B" SymbolKind_Constructor (R 0 9 2 13) (R 0 9 0 10) - [ docSymbol "x" SymbolKind_Field (R 1 2 1 3) - , docSymbol "y" SymbolKind_Field (R 2 4 2 5) - ] - ] - ] - , testSessionWait "import" $ do - let source = T.unlines ["import Data.Maybe ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbolWithChildren "imports" - SymbolKind_Module - (R 0 0 0 20) - [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20) - ] - ] - , testSessionWait "multiple import" $ do - let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right - [docSymbolWithChildren "imports" - SymbolKind_Module - (R 1 0 3 27) - [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20) - , docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27) - ] - ] - , testSessionWait "foreign import" $ do - let source = T.unlines - [ "{-# language ForeignFunctionInterface #-}" - , "foreign import ccall \"a\" a :: Int" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)] - , testSessionWait "foreign export" $ do - let source = T.unlines - [ "{-# language ForeignFunctionInterface #-}" - , "foreign export ccall odd :: Int -> Bool" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Right [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)] - ] - where - docSymbol name kind loc = - DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing - docSymbol' name kind loc selectionLoc = - DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing - docSymbolD name detail kind loc = - DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing - docSymbolWithChildren name kind loc cc = - DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc) - docSymbolWithChildren' name kind loc selectionLoc cc = - DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc) - moduleSymbol name loc cc = DocumentSymbol name - Nothing - SymbolKind_File - Nothing - Nothing - (R 0 0 maxBound 0) - loc - (Just cc) - classSymbol name loc cc = DocumentSymbol name - (Just "class") - SymbolKind_Interface - Nothing - Nothing - loc - loc - (Just cc) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index a2f7b4349f..e1ded7221d 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1763,6 +1763,9 @@ test-suite hls-core-plugin-tests main-is: CoreTest.hs other-modules: InitializeResponseTests + OutlineTests + Util + build-depends: , aeson diff --git a/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs b/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs index 8af8fa993d..7ad26a2859 100644 --- a/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs +++ b/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs @@ -49,9 +49,9 @@ descriptor recorder plId = gotoTypeDefinition ide TextDocumentPositionParams{..}) <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> documentHighlight ide TextDocumentPositionParams{..}) - <> mkPluginHandler SMethod_TextDocumentHover hover' - <> mkPluginHandler SMethod_WorkspaceSymbol (wsSymbols recorder) - <> mkPluginHandler SMethod_TextDocumentReferences references + <> mkPluginHandler SMethod_TextDocumentHover hover' + <> mkPluginHandler SMethod_WorkspaceSymbol (wsSymbols recorder) + <> mkPluginHandler SMethod_TextDocumentReferences references } diff --git a/plugins/hls-core-plugin/test/CoreTest.hs b/plugins/hls-core-plugin/test/CoreTest.hs index 6d52da2278..bf08baf968 100644 --- a/plugins/hls-core-plugin/test/CoreTest.hs +++ b/plugins/hls-core-plugin/test/CoreTest.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} import qualified InitializeResponseTests +import qualified OutlineTests import Test.Hls (defaultTestRunner, testGroup) @@ -11,4 +12,6 @@ main = defaultTestRunner $ testGroup "core" - [ InitializeResponseTests.tests ] + [ InitializeResponseTests.tests + , OutlineTests.tests + ] diff --git a/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs b/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs index 5d6e27c4d6..b784e61f70 100644 --- a/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs +++ b/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs @@ -13,6 +13,7 @@ import Development.IDE.Plugin.TypeLenses (typeLensCommandId) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Test +import Util import Control.Lens ((^.)) import Data.Default (def) @@ -46,9 +47,6 @@ import Test.Hls.FileSystem (file, text) import Test.Tasty import Test.Tasty.HUnit -corePlugin :: PluginTestDescriptor Core.CoreLog -corePlugin = mkPluginTestDescriptor Core.descriptor "core" - tests :: TestTree tests = withResource acquire release tests where @@ -125,15 +123,4 @@ tests = withResource acquire release tests where release :: TResponseMessage Method_Initialize -> IO () release = mempty -directFile :: FilePath -> Text -> [FS.FileTree] -directFile fp content = - [ FS.directCradle [Text.pack fp] - , file fp (text content) - ] - -mkFs :: [FS.FileTree] -> FS.VirtualFileTree -mkFs = FS.mkVirtualFileTree testDataDir - -testDataDir :: FilePath -testDataDir = "plugins" "core-plugin" "test" "testdata" diff --git a/plugins/hls-core-plugin/test/exe/OutlineTests.hs b/plugins/hls-core-plugin/test/exe/OutlineTests.hs new file mode 100644 index 0000000000..40ab844642 --- /dev/null +++ b/plugins/hls-core-plugin/test/exe/OutlineTests.hs @@ -0,0 +1,209 @@ + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module OutlineTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text as Text +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import System.FilePath (()) +import Test.Hls (PluginTestDescriptor, + mkPluginTestDescriptor, + runSessionWithServerInTmpDir) +import qualified Test.Hls.FileSystem as FS +import Test.Hls.FileSystem (file, text) +import Test.Tasty +import Test.Tasty.HUnit +import Util +-- import TestUtils + +pattern R :: UInt -> UInt -> UInt -> UInt -> Range +pattern R x y x' y' = Range (Position x y) (Position x' y') + +tests :: TestTree +tests = testGroup + "outline" + [ + -- runSessionWithServerInTmpDir def "type class" $ do + -- let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] + -- docId <- createDoc "A.hs" "haskell" source + -- symbols <- getDocumentSymbols docId + -- liftIO $ symbols @?= Right + -- [ moduleSymbol + -- "A" + -- (R 0 7 0 8) + -- [ classSymbol "A a" + -- (R 1 0 1 30) + -- [docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)] + -- ] + -- ] +-- , testSessionWait "type class instance " $ do +-- let source = T.unlines ["class A a where", "instance A () where"] +-- docId <- createDoc "A.hs" "haskell" source +-- symbols <- getDocumentSymbols docId +-- liftIO $ symbols @?= Right +-- [ classSymbol "A a" (R 0 0 0 15) [] +-- , docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19) +-- ] +-- , testSessionWait "type family" $ do +-- let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] +-- docId <- createDoc "A.hs" "haskell" source +-- symbols <- getDocumentSymbols docId +-- liftIO $ symbols @?= Right [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)] +-- , testSessionWait "type family instance " $ do +-- let source = T.unlines +-- [ "{-# language TypeFamilies #-}" +-- , "type family A a" +-- , "type instance A () = ()" +-- ] +-- docId <- createDoc "A.hs" "haskell" source +-- symbols <- getDocumentSymbols docId +-- liftIO $ symbols @?= Right +-- [ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15) +-- , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23) +-- ] +-- , testSessionWait "data family" $ do +-- let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] +-- docId <- createDoc "A.hs" "haskell" source +-- symbols <- getDocumentSymbols docId +-- liftIO $ symbols @?= Right [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)] +-- , testSessionWait "data family instance " $ do +-- let source = T.unlines +-- [ "{-# language TypeFamilies #-}" +-- , "data family A a" +-- , "data instance A () = A ()" +-- ] +-- docId <- createDoc "A.hs" "haskell" source +-- symbols <- getDocumentSymbols docId +-- liftIO $ symbols @?= Right +-- [ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 11) +-- , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25) +-- ] +-- , testSessionWait "constant" $ do +-- let source = T.unlines ["a = ()"] +-- docId <- createDoc "A.hs" "haskell" source +-- symbols <- getDocumentSymbols docId +-- liftIO $ symbols @?= Right +-- [docSymbol "a" SymbolKind_Function (R 0 0 0 6)] +-- , testSessionWait "pattern" $ do +-- let source = T.unlines ["Just foo = Just 21"] +-- docId <- createDoc "A.hs" "haskell" source +-- symbols <- getDocumentSymbols docId +-- liftIO $ symbols @?= Right +-- [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)] +-- , testSessionWait "pattern with type signature" $ do +-- let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] +-- docId <- createDoc "A.hs" "haskell" source +-- symbols <- getDocumentSymbols docId +-- liftIO $ symbols @?= Right +-- [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)] +-- , testSessionWait "function" $ do +-- let source = T.unlines ["a _x = ()"] +-- docId <- createDoc "A.hs" "haskell" source +-- symbols <- getDocumentSymbols docId +-- liftIO $ symbols @?= Right [docSymbol "a" SymbolKind_Function (R 0 0 0 9)] +-- , testSessionWait "type synonym" $ do +-- let source = T.unlines ["type A = Bool"] +-- docId <- createDoc "A.hs" "haskell" source +-- symbols <- getDocumentSymbols docId +-- liftIO $ symbols @?= Right +-- [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)] +-- , testSessionWait "datatype" $ do +-- let source = T.unlines ["data A = C"] +-- docId <- createDoc "A.hs" "haskell" source +-- symbols <- getDocumentSymbols docId +-- liftIO $ symbols @?= Right +-- [ docSymbolWithChildren "A" +-- SymbolKind_Struct +-- (R 0 0 0 10) +-- [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)] +-- ] +-- , testSessionWait "record fields" $ do +-- let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] +-- docId <- createDoc "A.hs" "haskell" source +-- symbols <- getDocumentSymbols docId +-- liftIO $ symbols @?= Right +-- [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 2 13) +-- [ docSymbolWithChildren' "B" SymbolKind_Constructor (R 0 9 2 13) (R 0 9 0 10) +-- [ docSymbol "x" SymbolKind_Field (R 1 2 1 3) +-- , docSymbol "y" SymbolKind_Field (R 2 4 2 5) +-- ] +-- ] +-- ] +-- , testSessionWait "import" $ do +-- let source = T.unlines ["import Data.Maybe ()"] +-- docId <- createDoc "A.hs" "haskell" source +-- symbols <- getDocumentSymbols docId +-- liftIO $ symbols @?= Right +-- [docSymbolWithChildren "imports" +-- SymbolKind_Module +-- (R 0 0 0 20) +-- [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20) +-- ] +-- ] +-- , testSessionWait "multiple import" $ do +-- let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] +-- docId <- createDoc "A.hs" "haskell" source +-- symbols <- getDocumentSymbols docId +-- liftIO $ symbols @?= Right +-- [docSymbolWithChildren "imports" +-- SymbolKind_Module +-- (R 1 0 3 27) +-- [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20) +-- , docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27) +-- ] +-- ] +-- , testSessionWait "foreign import" $ do +-- let source = T.unlines +-- [ "{-# language ForeignFunctionInterface #-}" +-- , "foreign import ccall \"a\" a :: Int" +-- ] +-- docId <- createDoc "A.hs" "haskell" source +-- symbols <- getDocumentSymbols docId +-- liftIO $ symbols @?= Right [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)] +-- , testSessionWait "foreign export" $ do +-- let source = T.unlines +-- [ "{-# language ForeignFunctionInterface #-}" +-- , "foreign export ccall odd :: Int -> Bool" +-- ] +-- docId <- createDoc "A.hs" "haskell" source +-- symbols <- getDocumentSymbols docId +-- liftIO $ symbols @?= Right [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)] + ] + where + docSymbol name kind loc = + DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing + docSymbol' name kind loc selectionLoc = + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing + docSymbolD name detail kind loc = + DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing + docSymbolWithChildren name kind loc cc = + DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc) + docSymbolWithChildren' name kind loc selectionLoc cc = + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc) + moduleSymbol name loc cc = DocumentSymbol name + Nothing + SymbolKind_File + Nothing + Nothing + (R 0 0 maxBound 0) + loc + (Just cc) + classSymbol name loc cc = DocumentSymbol name + (Just "class") + SymbolKind_Interface + Nothing + Nothing + loc + loc + (Just cc) diff --git a/plugins/hls-core-plugin/test/exe/Util.hs b/plugins/hls-core-plugin/test/exe/Util.hs new file mode 100644 index 0000000000..2dc0d99e73 --- /dev/null +++ b/plugins/hls-core-plugin/test/exe/Util.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Util where + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Ide.Plugin.Core as Core +import System.FilePath (()) +import Test.Hls (PluginTestDescriptor, + mkPluginTestDescriptor) +import qualified Test.Hls.FileSystem as FS +import Test.Hls.FileSystem (file, text) + +corePlugin :: PluginTestDescriptor Core.CoreLog +corePlugin = mkPluginTestDescriptor Core.descriptor "core" + +directFile :: FilePath -> Text -> [FS.FileTree] +directFile fp content = + [ FS.directCradle [Text.pack fp] + , file fp (text content) + ] + +mkFs :: [FS.FileTree] -> FS.VirtualFileTree +mkFs = FS.mkVirtualFileTree testDataDir + +testDataDir :: FilePath +testDataDir = "plugins" "core-plugin" "test" "testdata" From 42a0792a8d4b665768f5279de543987a6ad66ad2 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 26 Mar 2024 07:35:32 +0800 Subject: [PATCH 14/34] surface the problem --- ghcide/src/Development/IDE/Core/FileStore.hs | 6 ++++++ plugins/hls-refactor-plugin/test/Main.hs | 10 ++++++---- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 7be4c71827..7046ff1661 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -49,6 +49,7 @@ import Development.IDE.Import.DependencyInformation import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options +import GHC.Conc.Sync (unsafeIOToSTM) import HieDb.Create (deleteMissingRealFiles) import Ide.Logger (Pretty (pretty), Priority (Info), @@ -246,11 +247,16 @@ typecheckParentsAction recorder nfp = do -- independently tracks which files are modified. setSomethingModified :: VFSModified -> IdeState -> [Key] -> String -> IO () setSomethingModified vfs state keys reason = do + L.logDebug (Shake.ideLogger state) "begin restartShakeSession" -- Update database to remove any files that might have been renamed/deleted atomically $ do + unsafeIOToSTM $ L.logDebug (Shake.ideLogger state) "begin writing indexQueue" writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) + unsafeIOToSTM $ L.logDebug (Shake.ideLogger state) "begin writing dirtyKeys" modifyTVar' (dirtyKeys $ shakeExtras state) $ \x -> foldl' (flip insertKeySet) x keys + + L.logDebug (Shake.ideLogger state) "setSomethingModified before restartShakeSession" void $ restartShakeSession (shakeExtras state) vfs reason [] registerFileWatches :: [String] -> LSP.LspT Config IO Bool diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 09635e898a..3111755a9b 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -71,9 +71,9 @@ tests :: TestTree tests = testGroup "refactor" [ initializeTests - , codeActionTests - , codeActionHelperFunctionTests - , completionTests +-- , codeActionTests +-- , codeActionHelperFunctionTests +-- , completionTests ] initializeTests :: TestTree @@ -99,7 +99,9 @@ initializeTests = withResource acquire release tests mapM_ (\e -> any (\o -> T.isSuffixOf e o) commands @? show (expected, show commands)) expected acquire :: IO (TResponseMessage Method_Initialize) - acquire = run initializeResponse + acquire = do + -- liftIO $ sleep 0.01 + run initializeResponse release :: TResponseMessage Method_Initialize -> IO () release = mempty From ccf2b523a7e0d9a5047f838c0b9dac81ab9423a5 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 26 Mar 2024 08:23:58 +0800 Subject: [PATCH 15/34] move stopReactor to exit --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 5663165f02..c55d50d9d1 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -169,7 +169,7 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do let asyncHandlers = mconcat [ userHandlers , cancelHandler cancelRequest - , exitHandler exit + , exitHandler stopReactorLoop >> exit , shutdownHandler stopReactorLoop ] -- Cancel requests are special since they need to be handled @@ -266,7 +266,7 @@ shutdownHandler stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> d (_, ide) <- ask liftIO $ logDebug (ideLogger ide) "Received shutdown message" -- stop the reactor to free up the hiedb connection - liftIO stopReactor + -- liftIO stopReactor -- flush out the Shake session to record a Shake profile if applicable liftIO $ shakeShut ide resp $ Right Null From 2e2d8e96aecdd63992f11298a6ef0dfaf63d17e8 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 26 Mar 2024 08:24:21 +0800 Subject: [PATCH 16/34] move stopReactor to exit --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index c55d50d9d1..6177628056 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -169,7 +169,7 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do let asyncHandlers = mconcat [ userHandlers , cancelHandler cancelRequest - , exitHandler stopReactorLoop >> exit + , exitHandler $ stopReactorLoop >> exit , shutdownHandler stopReactorLoop ] -- Cancel requests are special since they need to be handled From e3e54301f6b640cdea1a74156e563b71be80266d Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 26 Mar 2024 08:38:21 +0800 Subject: [PATCH 17/34] wait for reactor close --- ghcide/src/Development/IDE/Core/FileStore.hs | 2 +- .../src/Development/IDE/LSP/LanguageServer.hs | 19 ++++++++++++++----- 2 files changed, 15 insertions(+), 6 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 7046ff1661..a02e23e207 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -247,7 +247,7 @@ typecheckParentsAction recorder nfp = do -- independently tracks which files are modified. setSomethingModified :: VFSModified -> IdeState -> [Key] -> String -> IO () setSomethingModified vfs state keys reason = do - L.logDebug (Shake.ideLogger state) "begin restartShakeSession" + L.logDebug (Shake.ideLogger state) "begin setSomethingModified" -- Update database to remove any files that might have been renamed/deleted atomically $ do unsafeIOToSTM $ L.logDebug (Shake.ideLogger state) "begin writing indexQueue" diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 6177628056..54c961d926 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -142,6 +142,11 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do reactorLifetime <- newEmptyMVar let stopReactorLoop = void $ tryPutMVar reactorLifetime () + -- An MVar to control the lifetime of the reactor loop. + -- The loop will be stopped and resources freed when it's full + waitForReactor <- newEmptyMVar + let finishEndReactor = void $ tryPutMVar waitForReactor () + -- Forcefully exit let exit = void $ tryPutMVar clientMsgVar () @@ -166,17 +171,18 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do cancelled <- readTVar cancelledRequests unless (reqId `Set.member` cancelled) retry + + let doInitialize = handleInit recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan finishEndReactor + let asyncHandlers = mconcat [ userHandlers , cancelHandler cancelRequest - , exitHandler $ stopReactorLoop >> exit + , exitHandler $ stopReactorLoop >> takeMVar waitForReactor >> exit , shutdownHandler stopReactorLoop ] -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. - let doInitialize = handleInit recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan - let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO pure (doInitialize, asyncHandlers, interpretHandler) @@ -191,8 +197,10 @@ handleInit -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage - -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) -handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do + -> IO () + -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize + -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) +handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan finishEndReactor env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params let root = LSP.resRootPath env dir <- maybe getCurrentDirectory return root @@ -245,6 +253,7 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa ReactorNotification act -> handle exceptionInHandler act ReactorRequest _id act k -> void $ async $ checkCancelled _id act k logWith recorder Info LogReactorThreadStopped + finishEndReactor pure $ Right (env,ide) From b43dd6fa0bff3ed770afb40708b7922d9a9af3d4 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 26 Mar 2024 09:42:03 +0800 Subject: [PATCH 18/34] push the update of config to reactor thread --- .../src/Development/IDE/LSP/LanguageServer.hs | 27 +++++------------ ghcide/src/Development/IDE/Main.hs | 30 ++++++++++++------- 2 files changed, 28 insertions(+), 29 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 54c961d926..c45b1ef23e 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -128,25 +128,18 @@ setupLSP :: -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> LSP.Handlers (ServerM config) -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> Chan ReactorMessage -> MVar () -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), LSP.Handlers (ServerM config), (LanguageContextEnv config, IdeState) -> ServerM config <~> IO) -setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do - -- Send everything over a channel, since you need to wait until after initialise before - -- LspFuncs is available - clientMsgChan :: Chan ReactorMessage <- newChan +setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgChan clientMsgVar = do -- An MVar to control the lifetime of the reactor loop. -- The loop will be stopped and resources freed when it's full reactorLifetime <- newEmptyMVar let stopReactorLoop = void $ tryPutMVar reactorLifetime () - -- An MVar to control the lifetime of the reactor loop. - -- The loop will be stopped and resources freed when it's full - waitForReactor <- newEmptyMVar - let finishEndReactor = void $ tryPutMVar waitForReactor () - -- Forcefully exit let exit = void $ tryPutMVar clientMsgVar () @@ -171,18 +164,17 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do cancelled <- readTVar cancelledRequests unless (reqId `Set.member` cancelled) retry - - let doInitialize = handleInit recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan finishEndReactor - let asyncHandlers = mconcat [ userHandlers , cancelHandler cancelRequest - , exitHandler $ stopReactorLoop >> takeMVar waitForReactor >> exit + , exitHandler exit , shutdownHandler stopReactorLoop ] -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. + let doInitialize = handleInit recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan + let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO pure (doInitialize, asyncHandlers, interpretHandler) @@ -197,10 +189,8 @@ handleInit -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage - -> IO () - -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize - -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) -handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan finishEndReactor env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do + -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) +handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params let root = LSP.resRootPath env dir <- maybe getCurrentDirectory return root @@ -253,7 +243,6 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa ReactorNotification act -> handle exceptionInHandler act ReactorRequest _id act k -> void $ async $ checkCancelled _id act k logWith recorder Info LogReactorThreadStopped - finishEndReactor pure $ Right (env,ide) @@ -275,7 +264,7 @@ shutdownHandler stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> d (_, ide) <- ask liftIO $ logDebug (ideLogger ide) "Received shutdown message" -- stop the reactor to free up the hiedb connection - -- liftIO stopReactor + liftIO stopReactor -- flush out the Shake session to record a Shake profile if applicable liftIO $ shakeShut ide resp $ Right Null diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index a05ab88e2a..2052ae05b9 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -11,7 +11,9 @@ module Development.IDE.Main ,Log(..) ) where -import Control.Concurrent.Extra (withNumCapabilities) +import Control.Concurrent.Extra (Chan, newChan, + withNumCapabilities, + writeChan) import Control.Concurrent.MVar (newEmptyMVar, putMVar, tryReadMVar) import Control.Concurrent.STM.Stats (dumpSTMStats) @@ -63,6 +65,7 @@ import Development.IDE.Graph (action) import Development.IDE.LSP.LanguageServer (runLanguageServer, setupLSP) import qualified Development.IDE.LSP.LanguageServer as LanguageServer +import Development.IDE.LSP.Server import Development.IDE.Main.HeapStats (withHeapStats) import qualified Development.IDE.Main.HeapStats as HeapStats import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry @@ -355,19 +358,26 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re putMVar ideStateVar ide pure ide - let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState + -- Send everything over a channel, since you need to wait until after initialise before + -- LspFuncs is available + clientMsgChan :: Chan ReactorMessage <- newChan + + let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState clientMsgChan -- See Note [Client configuration in Rules] onConfigChange cfg = do -- TODO: this is nuts, we're converting back to JSON just to get a fingerprint let cfgObj = J.toJSON cfg - mide <- liftIO $ tryReadMVar ideStateVar - case mide of - Nothing -> pure () - Just ide -> liftIO $ do - let msg = T.pack $ show cfg - logDebug (Shake.ideLogger ide) $ "Configuration changed: " <> msg - modifyClientSettings ide (const $ Just cfgObj) - setSomethingModified Shake.VFSUnmodified ide [toKey Rules.GetClientSettings emptyFilePath] "config change" + let configChangeIO = do + mide <- liftIO $ tryReadMVar ideStateVar + case mide of + Nothing -> pure () + Just ide -> liftIO $ do + let msg = T.pack $ show cfg + logDebug (Shake.ideLogger ide) $ "Configuration changed: " <> msg + modifyClientSettings ide (const $ Just cfgObj) + setSomethingModified Shake.VFSUnmodified ide [toKey Rules.GetClientSettings emptyFilePath] "config change" + liftIO $ writeChan clientMsgChan $ ReactorNotification configChangeIO + runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup dumpSTMStats From 3e1640f12b10130bb330079dd8e1a240164ec805 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 26 Mar 2024 10:20:44 +0800 Subject: [PATCH 19/34] remove log setSomethingModified --- ghcide/src/Development/IDE/Core/FileStore.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index a02e23e207..47a34ce128 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -247,16 +247,11 @@ typecheckParentsAction recorder nfp = do -- independently tracks which files are modified. setSomethingModified :: VFSModified -> IdeState -> [Key] -> String -> IO () setSomethingModified vfs state keys reason = do - L.logDebug (Shake.ideLogger state) "begin setSomethingModified" -- Update database to remove any files that might have been renamed/deleted atomically $ do - unsafeIOToSTM $ L.logDebug (Shake.ideLogger state) "begin writing indexQueue" writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) - unsafeIOToSTM $ L.logDebug (Shake.ideLogger state) "begin writing dirtyKeys" modifyTVar' (dirtyKeys $ shakeExtras state) $ \x -> foldl' (flip insertKeySet) x keys - - L.logDebug (Shake.ideLogger state) "setSomethingModified before restartShakeSession" void $ restartShakeSession (shakeExtras state) vfs reason [] registerFileWatches :: [String] -> LSP.LspT Config IO Bool From d00f18ad8c855c99fc34640ec45427a28e175aa0 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 26 Mar 2024 11:18:00 +0800 Subject: [PATCH 20/34] cleanup dirty trick --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index c45b1ef23e..2b1568dc1f 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -195,18 +195,11 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa let root = LSP.resRootPath env dir <- maybe getCurrentDirectory return root dbLoc <- getHieDbLoc dir - - -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference - -- to 'getIdeState', so we use this dirty trick dbMVar <- newEmptyMVar - ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar - - ide <- getIdeState env root withHieDb hieChan let initConfig = parseConfiguration params logWith recorder Info $ LogRegisteringIdeConfig initConfig - registerIdeConfiguration (shakeExtras ide) initConfig let handleServerException (Left e) = do logWith recorder Error $ LogReactorThreadException e @@ -243,6 +236,10 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa ReactorNotification act -> handle exceptionInHandler act ReactorRequest _id act k -> void $ async $ checkCancelled _id act k logWith recorder Info LogReactorThreadStopped + + (WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar + ide <- getIdeState env root withHieDb hieChan + registerIdeConfiguration (shakeExtras ide) initConfig pure $ Right (env,ide) From e10b127d92f7972a8d9615c526edf62aa94e83e4 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 26 Mar 2024 18:45:12 +0800 Subject: [PATCH 21/34] Revert "cleanup dirty trick" This reverts commit 14eff93d6eea44cca1e8139ff1bd9fe9b7310f9b. --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 2b1568dc1f..c45b1ef23e 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -195,11 +195,18 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa let root = LSP.resRootPath env dir <- maybe getCurrentDirectory return root dbLoc <- getHieDbLoc dir + + -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference + -- to 'getIdeState', so we use this dirty trick dbMVar <- newEmptyMVar + ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar + + ide <- getIdeState env root withHieDb hieChan let initConfig = parseConfiguration params logWith recorder Info $ LogRegisteringIdeConfig initConfig + registerIdeConfiguration (shakeExtras ide) initConfig let handleServerException (Left e) = do logWith recorder Error $ LogReactorThreadException e @@ -236,10 +243,6 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa ReactorNotification act -> handle exceptionInHandler act ReactorRequest _id act k -> void $ async $ checkCancelled _id act k logWith recorder Info LogReactorThreadStopped - - (WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar - ide <- getIdeState env root withHieDb hieChan - registerIdeConfiguration (shakeExtras ide) initConfig pure $ Right (env,ide) From 286cd60e7dc8f1071471a24e0e2f5cae15622369 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 26 Mar 2024 19:43:52 +0800 Subject: [PATCH 22/34] clean up --- ghcide/src/Development/IDE/Core/FileStore.hs | 1 - plugins/hls-refactor-plugin/test/Main.hs | 10 ++++------ 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 47a34ce128..7be4c71827 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -49,7 +49,6 @@ import Development.IDE.Import.DependencyInformation import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options -import GHC.Conc.Sync (unsafeIOToSTM) import HieDb.Create (deleteMissingRealFiles) import Ide.Logger (Pretty (pretty), Priority (Info), diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 3111755a9b..09635e898a 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -71,9 +71,9 @@ tests :: TestTree tests = testGroup "refactor" [ initializeTests --- , codeActionTests --- , codeActionHelperFunctionTests --- , completionTests + , codeActionTests + , codeActionHelperFunctionTests + , completionTests ] initializeTests :: TestTree @@ -99,9 +99,7 @@ initializeTests = withResource acquire release tests mapM_ (\e -> any (\o -> T.isSuffixOf e o) commands @? show (expected, show commands)) expected acquire :: IO (TResponseMessage Method_Initialize) - acquire = do - -- liftIO $ sleep 0.01 - run initializeResponse + acquire = run initializeResponse release :: TResponseMessage Method_Initialize -> IO () release = mempty From 210b89f901b6eca88fbb01d16f4278b7b5b90820 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 5 Apr 2024 13:24:50 +0800 Subject: [PATCH 23/34] move outline test to core plugin --- .../hls-core-plugin/test/exe/OutlineTests.hs | 216 ++++++------------ plugins/hls-core-plugin/test/exe/Util.hs | 20 +- 2 files changed, 89 insertions(+), 147 deletions(-) diff --git a/plugins/hls-core-plugin/test/exe/OutlineTests.hs b/plugins/hls-core-plugin/test/exe/OutlineTests.hs index 40ab844642..49c91d1580 100644 --- a/plugins/hls-core-plugin/test/exe/OutlineTests.hs +++ b/plugins/hls-core-plugin/test/exe/OutlineTests.hs @@ -30,155 +30,81 @@ import Util pattern R :: UInt -> UInt -> UInt -> UInt -> Range pattern R x y x' y' = Range (Position x y) (Position x' y') +testSymbols :: (HasCallStack) => TestName -> FilePath -> [Text] -> [DocumentSymbol] -> TestTree +testSymbols testName path content expectedSymbols = + testSessionWithCorePluginSingleFile testName path (T.unlines content) $ do + docId <- openDoc path "haskell" + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right expectedSymbols + +testSymbolsA :: (HasCallStack) => TestName -> [Text] -> [DocumentSymbol] -> TestTree +testSymbolsA testName content expectedSymbols = + testSymbols testName "A.hs" content expectedSymbols + tests :: TestTree tests = testGroup "outline" [ - -- runSessionWithServerInTmpDir def "type class" $ do - -- let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] - -- docId <- createDoc "A.hs" "haskell" source - -- symbols <- getDocumentSymbols docId - -- liftIO $ symbols @?= Right - -- [ moduleSymbol - -- "A" - -- (R 0 7 0 8) - -- [ classSymbol "A a" - -- (R 1 0 1 30) - -- [docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)] - -- ] - -- ] --- , testSessionWait "type class instance " $ do --- let source = T.unlines ["class A a where", "instance A () where"] --- docId <- createDoc "A.hs" "haskell" source --- symbols <- getDocumentSymbols docId --- liftIO $ symbols @?= Right --- [ classSymbol "A a" (R 0 0 0 15) [] --- , docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19) --- ] --- , testSessionWait "type family" $ do --- let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] --- docId <- createDoc "A.hs" "haskell" source --- symbols <- getDocumentSymbols docId --- liftIO $ symbols @?= Right [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)] --- , testSessionWait "type family instance " $ do --- let source = T.unlines --- [ "{-# language TypeFamilies #-}" --- , "type family A a" --- , "type instance A () = ()" --- ] --- docId <- createDoc "A.hs" "haskell" source --- symbols <- getDocumentSymbols docId --- liftIO $ symbols @?= Right --- [ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15) --- , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23) --- ] --- , testSessionWait "data family" $ do --- let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] --- docId <- createDoc "A.hs" "haskell" source --- symbols <- getDocumentSymbols docId --- liftIO $ symbols @?= Right [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)] --- , testSessionWait "data family instance " $ do --- let source = T.unlines --- [ "{-# language TypeFamilies #-}" --- , "data family A a" --- , "data instance A () = A ()" --- ] --- docId <- createDoc "A.hs" "haskell" source --- symbols <- getDocumentSymbols docId --- liftIO $ symbols @?= Right --- [ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 11) --- , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25) --- ] --- , testSessionWait "constant" $ do --- let source = T.unlines ["a = ()"] --- docId <- createDoc "A.hs" "haskell" source --- symbols <- getDocumentSymbols docId --- liftIO $ symbols @?= Right --- [docSymbol "a" SymbolKind_Function (R 0 0 0 6)] --- , testSessionWait "pattern" $ do --- let source = T.unlines ["Just foo = Just 21"] --- docId <- createDoc "A.hs" "haskell" source --- symbols <- getDocumentSymbols docId --- liftIO $ symbols @?= Right --- [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)] --- , testSessionWait "pattern with type signature" $ do --- let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] --- docId <- createDoc "A.hs" "haskell" source --- symbols <- getDocumentSymbols docId --- liftIO $ symbols @?= Right --- [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)] --- , testSessionWait "function" $ do --- let source = T.unlines ["a _x = ()"] --- docId <- createDoc "A.hs" "haskell" source --- symbols <- getDocumentSymbols docId --- liftIO $ symbols @?= Right [docSymbol "a" SymbolKind_Function (R 0 0 0 9)] --- , testSessionWait "type synonym" $ do --- let source = T.unlines ["type A = Bool"] --- docId <- createDoc "A.hs" "haskell" source --- symbols <- getDocumentSymbols docId --- liftIO $ symbols @?= Right --- [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)] --- , testSessionWait "datatype" $ do --- let source = T.unlines ["data A = C"] --- docId <- createDoc "A.hs" "haskell" source --- symbols <- getDocumentSymbols docId --- liftIO $ symbols @?= Right --- [ docSymbolWithChildren "A" --- SymbolKind_Struct --- (R 0 0 0 10) --- [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)] --- ] --- , testSessionWait "record fields" $ do --- let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] --- docId <- createDoc "A.hs" "haskell" source --- symbols <- getDocumentSymbols docId --- liftIO $ symbols @?= Right --- [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 2 13) --- [ docSymbolWithChildren' "B" SymbolKind_Constructor (R 0 9 2 13) (R 0 9 0 10) --- [ docSymbol "x" SymbolKind_Field (R 1 2 1 3) --- , docSymbol "y" SymbolKind_Field (R 2 4 2 5) --- ] --- ] --- ] --- , testSessionWait "import" $ do --- let source = T.unlines ["import Data.Maybe ()"] --- docId <- createDoc "A.hs" "haskell" source --- symbols <- getDocumentSymbols docId --- liftIO $ symbols @?= Right --- [docSymbolWithChildren "imports" --- SymbolKind_Module --- (R 0 0 0 20) --- [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20) --- ] --- ] --- , testSessionWait "multiple import" $ do --- let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] --- docId <- createDoc "A.hs" "haskell" source --- symbols <- getDocumentSymbols docId --- liftIO $ symbols @?= Right --- [docSymbolWithChildren "imports" --- SymbolKind_Module --- (R 1 0 3 27) --- [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20) --- , docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27) --- ] --- ] --- , testSessionWait "foreign import" $ do --- let source = T.unlines --- [ "{-# language ForeignFunctionInterface #-}" --- , "foreign import ccall \"a\" a :: Int" --- ] --- docId <- createDoc "A.hs" "haskell" source --- symbols <- getDocumentSymbols docId --- liftIO $ symbols @?= Right [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)] --- , testSessionWait "foreign export" $ do --- let source = T.unlines --- [ "{-# language ForeignFunctionInterface #-}" --- , "foreign export ccall odd :: Int -> Bool" --- ] --- docId <- createDoc "A.hs" "haskell" source --- symbols <- getDocumentSymbols docId --- liftIO $ symbols @?= Right [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)] + testSymbolsA "module" ["module A where", "class A a where a :: a -> Bool"] + [ moduleSymbol + "A" + (R 0 7 0 8) + [ classSymbol "A a" + (R 1 0 1 30) + [docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)] + ] ] + , testSymbolsA "type class instance " ["class A a where", "instance A () where"] + [ classSymbol "A a" (R 0 0 0 15) [] + , docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19) + ] + , testSymbolsA "type family" ["{-# language TypeFamilies #-}", "type family A"] [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)] + , testSymbolsA "type family instance " [ "{-# language TypeFamilies #-}" , "type family A a" , "type instance A () = ()"] + [ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15) + , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23) + ] + , testSymbolsA "data family" ["{-# language TypeFamilies #-}", "data family A"] [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)] + , testSymbolsA "data family instance " [ "{-# language TypeFamilies #-}" , "data family A a" , "data instance A () = A ()" ] + [ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 11) + , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25) + ] + , testSymbolsA "constant" ["a = ()"] [docSymbol "a" SymbolKind_Function (R 0 0 0 6)] + , testSymbolsA "pattern" ["Just foo = Just 21"] [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)] + , testSymbolsA "pattern with type signature" ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)] + , testSymbolsA "function" ["a _x = ()"] [docSymbol "a" SymbolKind_Function (R 0 0 0 9)] + , testSymbolsA "type synonym" ["type A = Bool"] [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)] + , testSymbolsA "datatype" ["data A = C"] [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 0 10) [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)] ] + , testSymbolsA "record fields" ["data A = B {", " x :: Int", " , y :: Int}"] + [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 2 13) + [ docSymbolWithChildren' "B" SymbolKind_Constructor (R 0 9 2 13) (R 0 9 0 10) + [ docSymbol "x" SymbolKind_Field (R 1 2 1 3) + , docSymbol "y" SymbolKind_Field (R 2 4 2 5) + ] + ] + ] + , testSymbolsA "import" ["import Data.Maybe ()"] + [docSymbolWithChildren "imports" + SymbolKind_Module + (R 0 0 0 20) + [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20) + ] + ] + , testSymbolsA "multiple import" ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] + [docSymbolWithChildren "imports" + SymbolKind_Module + (R 1 0 3 27) + [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20) + , docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27) + ] + ] + , testSymbolsA "foreign import" + [ "{-# language ForeignFunctionInterface #-}" + , "foreign import ccall \"a\" a :: Int" + ] [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)] + , testSymbolsA "foreign export" + [ "{-# language ForeignFunctionInterface #-}" + , "foreign export ccall odd :: Int -> Bool" + ] + [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)] ] where docSymbol name kind loc = diff --git a/plugins/hls-core-plugin/test/exe/Util.hs b/plugins/hls-core-plugin/test/exe/Util.hs index 2dc0d99e73..433812bc5e 100644 --- a/plugins/hls-core-plugin/test/exe/Util.hs +++ b/plugins/hls-core-plugin/test/exe/Util.hs @@ -2,18 +2,34 @@ module Util where +import Data.Default (Default (..)) import Data.Text (Text) import qualified Data.Text as Text import qualified Ide.Plugin.Core as Core +import Language.LSP.Test (Session) import System.FilePath (()) -import Test.Hls (PluginTestDescriptor, - mkPluginTestDescriptor) +import Test.Hls (Assertion, PluginTestDescriptor, TestName, + TestTree, mkPluginTestDescriptor, + runSessionWithServerInTmpDir, testCase) import qualified Test.Hls.FileSystem as FS import Test.Hls.FileSystem (file, text) + +runSessionWithCorePlugin :: FS.VirtualFileTree -> Session a -> IO a +runSessionWithCorePlugin = runSessionWithServerInTmpDir def corePlugin + +runSessionWithCorePluginSingleFile :: FilePath -> Text -> Session a -> IO a +runSessionWithCorePluginSingleFile fp content = runSessionWithCorePlugin (mkSingleFileFs fp content) + +testSessionWithCorePluginSingleFile :: TestName -> FilePath -> Text -> Session () -> TestTree +testSessionWithCorePluginSingleFile caseName fp content = testCase caseName . runSessionWithCorePluginSingleFile fp content + corePlugin :: PluginTestDescriptor Core.CoreLog corePlugin = mkPluginTestDescriptor Core.descriptor "core" +mkSingleFileFs :: FilePath -> Text -> FS.VirtualFileTree +mkSingleFileFs fp = mkFs . directFile fp + directFile :: FilePath -> Text -> [FS.FileTree] directFile fp content = [ FS.directCradle [Text.pack fp] From f8d62ad0ae296234ce22cda16e913c967e3304ea Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 5 Apr 2024 13:35:00 +0800 Subject: [PATCH 24/34] fix --- ghcide/test/exe/Main.hs | 1 - .../test/exe/InitializeResponseTests.hs | 9 +-------- plugins/hls-core-plugin/test/exe/OutlineTests.hs | 10 ---------- plugins/hls-core-plugin/test/exe/Util.hs | 4 ++-- 4 files changed, 3 insertions(+), 21 deletions(-) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 0bd4af5b0d..9ae7a45836 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -51,7 +51,6 @@ import CompletionTests import CPPTests import DiagnosticTests import CodeLensTests -import OutlineTests import HighlightTests import FindDefinitionAndHoverTests import PluginSimpleTests diff --git a/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs b/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs index b784e61f70..30fb1ba871 100644 --- a/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs +++ b/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs @@ -17,10 +17,8 @@ import Util import Control.Lens ((^.)) import Data.Default (def) -import Data.Text (Text) import qualified Data.Text as Text import Development.IDE.Plugin.Test (blockCommandId) -import qualified Ide.Plugin.Core as Core import Language.LSP.Protocol.Types (CodeLensOptions (..), CompletionOptions (..), DefinitionOptions (DefinitionOptions), @@ -38,12 +36,7 @@ import Language.LSP.Protocol.Types (CodeLensOptions (..), WorkspaceFoldersServerCapabilities (..), WorkspaceSymbolOptions (..), type (|?) (..)) -import System.FilePath (()) -import Test.Hls (PluginTestDescriptor, - mkPluginTestDescriptor, - runSessionWithServerInTmpDir) -import qualified Test.Hls.FileSystem as FS -import Test.Hls.FileSystem (file, text) +import Test.Hls (runSessionWithServerInTmpDir) import Test.Tasty import Test.Tasty.HUnit diff --git a/plugins/hls-core-plugin/test/exe/OutlineTests.hs b/plugins/hls-core-plugin/test/exe/OutlineTests.hs index 49c91d1580..87c6111d8a 100644 --- a/plugins/hls-core-plugin/test/exe/OutlineTests.hs +++ b/plugins/hls-core-plugin/test/exe/OutlineTests.hs @@ -1,9 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module OutlineTests (tests) where @@ -11,17 +8,10 @@ module OutlineTests (tests) where import Control.Monad.IO.Class (liftIO) import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text as Text import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), SemanticTokenRelative (..), SemanticTokensEdit (..), mkRange) import Language.LSP.Test -import System.FilePath (()) -import Test.Hls (PluginTestDescriptor, - mkPluginTestDescriptor, - runSessionWithServerInTmpDir) -import qualified Test.Hls.FileSystem as FS -import Test.Hls.FileSystem (file, text) import Test.Tasty import Test.Tasty.HUnit import Util diff --git a/plugins/hls-core-plugin/test/exe/Util.hs b/plugins/hls-core-plugin/test/exe/Util.hs index 433812bc5e..572ce31d97 100644 --- a/plugins/hls-core-plugin/test/exe/Util.hs +++ b/plugins/hls-core-plugin/test/exe/Util.hs @@ -8,8 +8,8 @@ import qualified Data.Text as Text import qualified Ide.Plugin.Core as Core import Language.LSP.Test (Session) import System.FilePath (()) -import Test.Hls (Assertion, PluginTestDescriptor, TestName, - TestTree, mkPluginTestDescriptor, +import Test.Hls (PluginTestDescriptor, TestName, TestTree, + mkPluginTestDescriptor, runSessionWithServerInTmpDir, testCase) import qualified Test.Hls.FileSystem as FS import Test.Hls.FileSystem (file, text) From 9faa2069480eb7ee796b9b95e975ceccdc5e5571 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 5 Apr 2024 14:16:05 +0800 Subject: [PATCH 25/34] move completion test to haskell core --- ghcide/ghcide.cabal | 1 - ghcide/test/exe/Main.hs | 2 - haskell-language-server.cabal | 3 +- plugins/hls-core-plugin/test/CoreTest.hs | 2 + .../test/exe/CompletionTests.hs | 77 ++++++++++--------- plugins/hls-core-plugin/test/exe/Util.hs | 47 +++++++++++ 6 files changed, 91 insertions(+), 41 deletions(-) rename {ghcide => plugins/hls-core-plugin}/test/exe/CompletionTests.hs (87%) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index a64e027d14..ca8d8f89b9 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -356,7 +356,6 @@ test-suite ghcide-tests BootTests ClientSettingsTests CodeLensTests - CompletionTests CPPTests CradleTests DependentFileTest diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 9ae7a45836..3546f837e7 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -47,7 +47,6 @@ import Test.Tasty.Ingredients.Rerun import LogType () import OpenCloseTest -import CompletionTests import CPPTests import DiagnosticTests import CodeLensTests @@ -91,7 +90,6 @@ main = do -- We mess with env vars so run single-threaded. defaultMainWithRerun $ testGroup "ghcide" [ OpenCloseTest.tests - , CompletionTests.tests , CPPTests.tests , DiagnosticTests.tests , CodeLensTests.tests diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index e1ded7221d..61e56a6573 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1762,9 +1762,10 @@ test-suite hls-core-plugin-tests , plugins/hls-core-plugin/test/exe main-is: CoreTest.hs other-modules: + Util InitializeResponseTests OutlineTests - Util + CompletionTests build-depends: diff --git a/plugins/hls-core-plugin/test/CoreTest.hs b/plugins/hls-core-plugin/test/CoreTest.hs index bf08baf968..fd513e605f 100644 --- a/plugins/hls-core-plugin/test/CoreTest.hs +++ b/plugins/hls-core-plugin/test/CoreTest.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} +import qualified CompletionTests import qualified InitializeResponseTests import qualified OutlineTests import Test.Hls (defaultTestRunner, testGroup) @@ -14,4 +15,5 @@ main = "core" [ InitializeResponseTests.tests , OutlineTests.tests + , CompletionTests.tests ] diff --git a/ghcide/test/exe/CompletionTests.hs b/plugins/hls-core-plugin/test/exe/CompletionTests.hs similarity index 87% rename from ghcide/test/exe/CompletionTests.hs rename to plugins/hls-core-plugin/test/exe/CompletionTests.hs index cf3198e74d..5127901bf3 100644 --- a/ghcide/test/exe/CompletionTests.hs +++ b/plugins/hls-core-plugin/test/exe/CompletionTests.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module CompletionTests (tests) where @@ -14,7 +17,6 @@ import Data.Maybe import Data.Row import qualified Data.Text as T import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) -import Development.IDE.Test (waitForTypecheck) import Development.IDE.Types.Location import Ide.Plugin.Config import qualified Language.LSP.Protocol.Lens as L @@ -26,9 +28,12 @@ import Language.LSP.Protocol.Types hiding mkRange) import Language.LSP.Test import System.FilePath +import Test.Hls (waitForTypecheck) +import qualified Test.Hls.FileSystem as FS +import Test.Hls.FileSystem (file, text) import Test.Tasty import Test.Tasty.HUnit -import TestUtils +import Util tests :: TestTree @@ -44,9 +49,15 @@ tests , testGroup "doc" completionDocTests ] +testSessionWithCorePluginEmpty :: TestName -> Session () -> TestTree +testSessionWithCorePluginEmpty name = testCase name . runSessionWithCorePluginEmpty ["A.hs"] + +testSessionWithCorePluginEmptyWithCradle :: TestName -> T.Text -> Session () -> TestTree +testSessionWithCorePluginEmptyWithCradle name cradle = testCase name . runSessionWithCorePlugin (mkFs [file "hie.yaml" (text cradle)]) + completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe [TextEdit])] -> TestTree -completionTest name src pos expected = testSessionWait name $ do - docId <- createDoc "A.hs" "haskell" (T.unlines src) +completionTest name src pos expected = testSessionWithCorePluginSingleFile name "A.hs" (T.unlines src) $ do + docId <- openDoc "A.hs" "haskell" _ <- waitForDiagnostics compls <- getAndResolveCompletions docId pos let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] @@ -185,7 +196,7 @@ localCompletionTests = [ [("abcd", CompletionItemKind_Function, "abcd", True, False, Nothing) ,("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) ], - testSessionWait "incomplete entries" $ do + testSessionWithCorePluginEmpty "incomplete entries" $ do let src a = "data Data = " <> a doc <- createDoc "A.hs" "haskell" $ src "AAA" void $ waitForTypecheck doc @@ -283,7 +294,7 @@ otherCompletionTests = [ (Position 3 11) [("Integer", CompletionItemKind_Struct, "Integer", True, True, Nothing)], - testSession "duplicate record fields" $ do + testSessionWithCorePluginEmpty "duplicate record fields" $ do void $ createDoc "B.hs" "haskell" $ T.unlines @@ -304,22 +315,21 @@ otherCompletionTests = [ let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"] liftIO $ take 1 compls' @?= ["member"], - testSessionWait "maxCompletions" $ do + testSessionWithCorePluginEmpty "maxCompletions" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "a = Prelude." ] _ <- waitForDiagnostics - compls <- getCompletions doc (Position 3 13) + compls <- getCompletions doc (Position 3 13) liftIO $ length compls @?= maxCompletions def ] packageCompletionTests :: [TestTree] packageCompletionTests = - [ testSession' "fromList" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}" + [ testSessionWithCorePluginEmptyWithCradle "fromList" "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", @@ -339,7 +349,7 @@ packageCompletionTests = , "'GHC.Exts" ] ++ if ghcVersion >= GHC94 then [ "'GHC.IsList" ] else []) - , testSessionWait "Map" $ do + , testSessionWithCorePluginEmpty "Map" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", @@ -359,7 +369,7 @@ packageCompletionTests = , "'Data.Map.Lazy" , "'Data.Map.Strict" ] - , testSessionWait "no duplicates" $ do + , testSessionWithCorePluginEmpty "no duplicates" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", @@ -381,7 +391,7 @@ packageCompletionTests = ) compls liftIO $ length duplicate @?= 1 - , testSessionWait "non-local before global" $ do + , testSessionWithCorePluginEmpty "non-local before global" $ do -- non local completions are more specific doc <- createDoc "A.hs" "haskell" $ T.unlines [ "{-# OPTIONS_GHC -Wunused-binds #-}", @@ -402,9 +412,7 @@ packageCompletionTests = projectCompletionTests :: [TestTree] projectCompletionTests = - [ testSession' "from hiedb" $ \dir-> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" + [ testSessionWithCorePluginEmptyWithCradle "from hiedb" "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do _ <- createDoc "A.hs" "haskell" $ T.unlines [ "module A (anidentifier) where", "anidentifier = ()" @@ -423,9 +431,7 @@ projectCompletionTests = , _label == "anidentifier" ] liftIO $ compls' @?= ["Defined in 'A"], - testSession' "auto complete project imports" $ \dir-> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}" + testSessionWithCorePluginEmptyWithCradle "auto complete project imports" "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}" $ do _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines [ "module ALocalModule (anidentifier) where", "anidentifier = ()" @@ -440,9 +446,7 @@ projectCompletionTests = let item = head $ filter ((== "ALocalModule") . (^. L.label)) compls liftIO $ do item ^. L.label @?= "ALocalModule", - testSession' "auto complete functions from qualified imports without alias" $ \dir-> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" + testSessionWithCorePluginEmptyWithCradle "auto complete functions from qualified imports without alias" "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do _ <- createDoc "A.hs" "haskell" $ T.unlines [ "module A (anidentifier) where", "anidentifier = ()" @@ -457,9 +461,8 @@ projectCompletionTests = let item = head compls liftIO $ do item ^. L.label @?= "anidentifier", - testSession' "auto complete functions from qualified imports with alias" $ \dir-> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" + testSessionWithCorePluginEmptyWithCradle "auto complete functions from qualified imports with alias" + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do _ <- createDoc "A.hs" "haskell" $ T.unlines [ "module A (anidentifier) where", "anidentifier = ()" @@ -478,7 +481,7 @@ projectCompletionTests = completionDocTests :: [TestTree] completionDocTests = - [ testSession "local define" $ do + [ testSessionWithCorePluginEmpty "local define" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "foo = ()" @@ -486,14 +489,14 @@ completionDocTests = ] let expected = "*Defined at line 2, column 1 in this module*\n" test doc (Position 2 8) "foo" Nothing [expected] - , testSession "local empty doc" $ do + , testSessionWithCorePluginEmpty "local empty doc" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "foo = ()" , "bar = fo" ] test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"] - , testSession "local single line doc without newline" $ do + , testSessionWithCorePluginEmpty "local single line doc without newline" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "-- |docdoc" @@ -501,7 +504,7 @@ completionDocTests = , "bar = fo" ] test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\n\n\ndocdoc\n"] - , testSession "local multi line doc with newline" $ do + , testSessionWithCorePluginEmpty "local multi line doc with newline" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "-- | abcabc" @@ -510,7 +513,7 @@ completionDocTests = , "bar = fo" ] test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n\n\nabcabc\n"] - , testSession "local multi line doc without newline" $ do + , testSessionWithCorePluginEmpty "local multi line doc without newline" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "-- | abcabc" @@ -520,28 +523,28 @@ completionDocTests = , "bar = fo" ] test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n\n\nabcabc \n\ndef\n"] - , testSession "extern empty doc" $ do + , testSessionWithCorePluginEmpty "extern empty doc" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "foo = od" ] let expected = "*Imported from 'Prelude'*\n" test doc (Position 1 8) "odd" (Just $ T.length expected) [expected] - , brokenForMacGhc9 $ testSession "extern single line doc without '\\n'" $ do + , brokenForMacGhc9 $ testSessionWithCorePluginEmpty "extern single line doc without '\\n'" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "foo = no" ] let expected = "*Imported from 'Prelude'*\n* * *\n\n\nBoolean \"not\"\n" test doc (Position 1 8) "not" (Just $ T.length expected) [expected] - , brokenForMacGhc9 $ testSession "extern mulit line doc" $ do + , brokenForMacGhc9 $ testSessionWithCorePluginEmpty "extern mulit line doc" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "foo = i" ] let expected = "*Imported from 'Prelude'*\n* * *\n\n\nIdentity function. \n```haskell\nid x = x\n```\n" test doc (Position 1 7) "id" (Just $ T.length expected) [expected] - , testSession "extern defined doc" $ do + , testSessionWithCorePluginEmpty "extern defined doc" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines [ "module A where" , "foo = i" diff --git a/plugins/hls-core-plugin/test/exe/Util.hs b/plugins/hls-core-plugin/test/exe/Util.hs index 572ce31d97..deafb2cc54 100644 --- a/plugins/hls-core-plugin/test/exe/Util.hs +++ b/plugins/hls-core-plugin/test/exe/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Util where @@ -5,10 +6,13 @@ module Util where import Data.Default (Default (..)) import Data.Text (Text) import qualified Data.Text as Text +import Development.IDE (GhcVersion, ghcVersion) import qualified Ide.Plugin.Core as Core import Language.LSP.Test (Session) import System.FilePath (()) +import System.Info.Extra import Test.Hls (PluginTestDescriptor, TestName, TestTree, + expectFailBecause, ignoreTestBecause, mkPluginTestDescriptor, runSessionWithServerInTmpDir, testCase) import qualified Test.Hls.FileSystem as FS @@ -18,6 +22,9 @@ import Test.Hls.FileSystem (file, text) runSessionWithCorePlugin :: FS.VirtualFileTree -> Session a -> IO a runSessionWithCorePlugin = runSessionWithServerInTmpDir def corePlugin +runSessionWithCorePluginEmpty :: [Text] -> Session a -> IO a +runSessionWithCorePluginEmpty fps = runSessionWithCorePlugin (mkFs [FS.directCradle fps]) + runSessionWithCorePluginSingleFile :: FilePath -> Text -> Session a -> IO a runSessionWithCorePluginSingleFile fp content = runSessionWithCorePlugin (mkSingleFileFs fp content) @@ -41,3 +48,43 @@ mkFs = FS.mkVirtualFileTree testDataDir testDataDir :: FilePath testDataDir = "plugins" "core-plugin" "test" "testdata" + + +data BrokenOS = Linux | MacOS | Windows deriving (Show) + +data IssueSolution = Broken | Ignore deriving (Show) + +data BrokenTarget = + BrokenSpecific BrokenOS [GhcVersion] + -- ^Broken for `BrokenOS` with `GhcVersion` + | BrokenForOS BrokenOS + -- ^Broken for `BrokenOS` + | BrokenForGHC [GhcVersion] + -- ^Broken for `GhcVersion` + deriving (Show) + +ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree +ignoreFor = knownIssueFor Ignore + +-- | Known broken for specific os and ghc with reason. +knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree +knownBrokenFor = knownIssueFor Broken + +-- | Deal with `IssueSolution` for specific OS and GHC. +knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree +knownIssueFor solution = go . \case + BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers + BrokenForOS bos -> isTargetOS bos + BrokenForGHC vers -> isTargetGhc vers + where + isTargetOS = \case + Windows -> isWindows + MacOS -> isMac + Linux -> not isWindows && not isMac + + isTargetGhc = elem ghcVersion + + go True = case solution of + Broken -> expectFailBecause + Ignore -> ignoreTestBecause + go False = const id From a16acea1735476180375afc02a4a213b443c8349 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 5 Apr 2024 18:01:52 +0800 Subject: [PATCH 26/34] find definition test to core-plugin --- ghcide/ghcide.cabal | 2 - ghcide/test/exe/Main.hs | 4 - haskell-language-server.cabal | 3 + plugins/hls-core-plugin/test/CoreTest.hs | 9 +- .../test/exe/CompletionTests.hs | 10 +- .../test/exe/FindDefinitionAndHoverTests.hs | 97 ++++++---- .../test/exe/HighlightTests.hs | 23 ++- .../hls-core-plugin/test/exe/OutlineTests.hs | 2 - plugins/hls-core-plugin/test/exe/Util.hs | 182 ++++++++++++------ .../test/testdata/hover/Bar.hs | 4 + .../test/testdata/hover/Foo.hs | 6 + .../test/testdata/hover/GotoHover.hs | 70 +++++++ .../test/testdata/hover/RecordDotSyntax.hs | 18 ++ .../test/testdata/hover/hie.yaml | 1 + 14 files changed, 317 insertions(+), 114 deletions(-) rename {ghcide => plugins/hls-core-plugin}/test/exe/FindDefinitionAndHoverTests.hs (81%) rename {ghcide => plugins/hls-core-plugin}/test/exe/HighlightTests.hs (85%) create mode 100644 plugins/hls-core-plugin/test/testdata/hover/Bar.hs create mode 100644 plugins/hls-core-plugin/test/testdata/hover/Foo.hs create mode 100644 plugins/hls-core-plugin/test/testdata/hover/GotoHover.hs create mode 100644 plugins/hls-core-plugin/test/testdata/hover/RecordDotSyntax.hs create mode 100644 plugins/hls-core-plugin/test/testdata/hover/hie.yaml diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index ca8d8f89b9..d451084510 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -361,12 +361,10 @@ test-suite ghcide-tests DependentFileTest DiagnosticTests ExceptionTests - FindDefinitionAndHoverTests FuzzySearch GarbageCollectionTests HaddockTests HieDbRetry - HighlightTests IfaceTests LogType NonLspCommandLine diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 3546f837e7..82be67998a 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -50,8 +50,6 @@ import OpenCloseTest import CPPTests import DiagnosticTests import CodeLensTests -import HighlightTests -import FindDefinitionAndHoverTests import PluginSimpleTests import PreprocessorTests import THTests @@ -93,8 +91,6 @@ main = do , CPPTests.tests , DiagnosticTests.tests , CodeLensTests.tests - , HighlightTests.tests - , FindDefinitionAndHoverTests.tests , PluginSimpleTests.tests , PreprocessorTests.tests , THTests.tests diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 61e56a6573..7be5644a0f 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1763,9 +1763,11 @@ test-suite hls-core-plugin-tests main-is: CoreTest.hs other-modules: Util + FindDefinitionAndHoverTests InitializeResponseTests OutlineTests CompletionTests + HighlightTests build-depends: @@ -1790,6 +1792,7 @@ test-suite hls-core-plugin-tests , row-types , extra , hls-test-utils + , regex-tdfa ----------------------------- diff --git a/plugins/hls-core-plugin/test/CoreTest.hs b/plugins/hls-core-plugin/test/CoreTest.hs index fd513e605f..fccfaa8028 100644 --- a/plugins/hls-core-plugin/test/CoreTest.hs +++ b/plugins/hls-core-plugin/test/CoreTest.hs @@ -3,9 +3,11 @@ {-# LANGUAGE OverloadedStrings #-} import qualified CompletionTests +import qualified FindDefinitionAndHoverTests +import qualified HighlightTests import qualified InitializeResponseTests import qualified OutlineTests -import Test.Hls (defaultTestRunner, testGroup) +import Test.Hls (defaultTestRunner, testGroup) main :: IO () @@ -13,7 +15,10 @@ main = defaultTestRunner $ testGroup "core" - [ InitializeResponseTests.tests + [ + InitializeResponseTests.tests , OutlineTests.tests , CompletionTests.tests + , HighlightTests.tests + , FindDefinitionAndHoverTests.tests ] diff --git a/plugins/hls-core-plugin/test/exe/CompletionTests.hs b/plugins/hls-core-plugin/test/exe/CompletionTests.hs index 5127901bf3..39a72a0394 100644 --- a/plugins/hls-core-plugin/test/exe/CompletionTests.hs +++ b/plugins/hls-core-plugin/test/exe/CompletionTests.hs @@ -28,9 +28,13 @@ import Language.LSP.Protocol.Types hiding mkRange) import Language.LSP.Test import System.FilePath -import Test.Hls (waitForTypecheck) +import Test.Hls (knownBrokenForGhcVersions, + knownBrokenInEnv, + waitForTypecheck) import qualified Test.Hls.FileSystem as FS import Test.Hls.FileSystem (file, text) +import Test.Hls.Util (EnvSpec (..), OS (..), + knownBrokenOnWindows) import Test.Tasty import Test.Tasty.HUnit import Util @@ -272,7 +276,7 @@ nonLocalCompletionTests = [] ] where - brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC92, GHC94, GHC96, GHC98]) "Windows has strange things in scope for some reason" + brokenForWinGhc = knownBrokenOnWindows "Windows has strange things in scope for some reason" otherCompletionTests :: [TestTree] otherCompletionTests = [ @@ -554,7 +558,7 @@ completionDocTests = ] where -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903 - brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC92, GHC94, GHC96]) "Extern doc doesn't support MacOS for ghc9" + brokenForMacGhc9 = knownBrokenInEnv [] "Extern doc doesn't support MacOS for ghc9" test doc pos label mn expected = do _ <- waitForDiagnostics compls <- getCompletions doc pos diff --git a/ghcide/test/exe/FindDefinitionAndHoverTests.hs b/plugins/hls-core-plugin/test/exe/FindDefinitionAndHoverTests.hs similarity index 81% rename from ghcide/test/exe/FindDefinitionAndHoverTests.hs rename to plugins/hls-core-plugin/test/exe/FindDefinitionAndHoverTests.hs index 04ede6579b..b333ded190 100644 --- a/ghcide/test/exe/FindDefinitionAndHoverTests.hs +++ b/plugins/hls-core-plugin/test/exe/FindDefinitionAndHoverTests.hs @@ -1,56 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} module FindDefinitionAndHoverTests (tests) where import Control.Monad -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (liftIO) import Data.Foldable import Data.Maybe -import qualified Data.Text as T -import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import Development.IDE.GHC.Util -import Development.IDE.Test (expectDiagnostics, - standardizeQuotes) -import Development.IDE.Types.Location -import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Types hiding - (SemanticTokenAbsolute (..), - SemanticTokenRelative (..), - SemanticTokensEdit (..), - mkRange) +-- import Development.IDE.Test (expectDiagnostics, +-- standardizeQuotes) +import qualified Language.LSP.Protocol.Lens as L +-- import Language.LSP.Protocol.Types hiding +-- (SemanticTokenAbsolute (..), +-- SemanticTokenRelative (..), +-- SemanticTokensEdit (..), +-- mkRange) + +import Language.LSP.Protocol.Types (DiagnosticSeverity (..), + Hover (..), MarkupContent (..), + Position (..), Range, + TextDocumentIdentifier, mkRange, + type (|?) (..)) + import Language.LSP.Test import System.FilePath -import System.Info.Extra (isWindows) +import System.Info.Extra (isWindows) -import Control.Lens ((^.)) +import Control.Lens ((^.)) import Test.Tasty import Test.Tasty.HUnit -import TestUtils -import Text.Regex.TDFA ((=~)) +-- import TestUtils +import Test.Hls (knownBrokenForGhcVersions, + waitForProgressDone, + waitForTypecheck) +import Test.Hls.FileSystem (copy, directProjectMulti) +import Text.Regex.TDFA ((=~)) +import Util tests :: TestTree tests = let - tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree - tst (get, check) pos sfp targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do - + tst (get, check) pos sfp targetRange title = testSessionWithCorePlugin title (mkFs $ fmap (copy . ("hover" )) ["Bar.hs", "Foo.hs", "GotoHover.hs", "hie.yaml", "RecordDotSyntax.hs"]) $ do -- Dirty the cache to check that definitions work even in the presence of iface files - liftIO $ runInDir dir $ do - let fooPath = dir "Foo.hs" - fooSource <- liftIO $ readFileUtf8 fooPath - fooDoc <- createDoc fooPath "haskell" fooSource - _ <- getHover fooDoc $ Position 4 3 - closeDoc fooDoc - - doc <- openTestDataDoc (dir sfp) + -- let fooPath = "Foo.hs" + -- fooSource <- liftIO $ readFileUtf8 fooPath + -- fooDoc <- createDoc fooPath "haskell" fooSource + -- _ <- getHover fooDoc $ Position 4 3 + -- closeDoc fooDoc + + doc <- openDoc sfp "haskell" waitForProgressDone + x <- waitForTypecheck doc + + found <- get doc pos check found targetRange - checkHover :: Maybe Hover -> Session [Expect] -> Session () + checkHover :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session () checkHover hover expectations = traverse_ check =<< expectations where + check :: (HasCallStack) => Expect -> Session () check expected = case hover of Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" @@ -100,11 +114,11 @@ tests = let mkFindTests tests = testGroup "get" [ testGroup "definition" $ mapMaybe fst tests , testGroup "hover" $ mapMaybe snd tests - , checkFileCompiles sourceFilePath $ - expectDiagnostics - [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _")]) - , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _")]) - ] + -- , checkFileCompiles sourceFilePath $ + -- expectDiagnostics + -- [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _")]) + -- , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _")]) + -- ] , testGroup "type-definition" typeDefinitionTests , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ] @@ -117,8 +131,15 @@ tests = let , tst (getHover, checkHover) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child" ] + test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b) test runDef runHover look expect = testM runDef runHover look (return expect) + testM :: (HasCallStack) => (TestTree -> a) + -> (TestTree -> b) + -> Position + -> Session [Expect] + -> String + -> (a, b) testM runDef runHover look expect title = ( runDef $ tst def look sourceFilePath expect title , runHover $ tst hover look sourceFilePath expect title ) where @@ -228,8 +249,8 @@ tests = let no = const Nothing -- don't run this test at all --skip = const Nothing -- unreliable, don't run -checkFileCompiles :: FilePath -> Session () -> TestTree -checkFileCompiles fp diag = - testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do - void (openTestDataDoc (dir fp)) - diag +-- checkFileCompiles :: FilePath -> Session () -> TestTree +-- checkFileCompiles fp diag = +-- testSessionWithCorePluginSingleFile ("hover: Does " ++ fp ++ " compile") $ \dir -> do +-- void (openTestDataDoc fp) +-- diag diff --git a/ghcide/test/exe/HighlightTests.hs b/plugins/hls-core-plugin/test/exe/HighlightTests.hs similarity index 85% rename from ghcide/test/exe/HighlightTests.hs rename to plugins/hls-core-plugin/test/exe/HighlightTests.hs index 7fb5ca79a2..e46c10d63b 100644 --- a/ghcide/test/exe/HighlightTests.hs +++ b/plugins/hls-core-plugin/test/exe/HighlightTests.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module HighlightTests (tests) where @@ -11,14 +12,17 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test +import Test.Hls (knownBrokenForGhcVersions) import Test.Tasty import Test.Tasty.HUnit -import TestUtils +import Util + + tests :: TestTree tests = testGroup "highlight" - [ testSessionWait "value" $ do - doc <- createDoc "A.hs" "haskell" source + [ testSessionWait "value" source $ do + doc <- openDoc "A.hs" "haskell" _ <- waitForDiagnostics highlights <- getHighlights doc (Position 3 2) liftIO $ highlights @?= @@ -27,16 +31,16 @@ tests = testGroup "highlight" , DocumentHighlight (R 4 6 4 9) (Just DocumentHighlightKind_Read) , DocumentHighlight (R 5 22 5 25) (Just DocumentHighlightKind_Read) ] - , testSessionWait "type" $ do - doc <- createDoc "A.hs" "haskell" source + , testSessionWait "type" source $ do + doc <- openDoc "A.hs" "haskell" _ <- waitForDiagnostics highlights <- getHighlights doc (Position 2 8) liftIO $ highlights @?= [ DocumentHighlight (R 2 7 2 10) (Just DocumentHighlightKind_Read) , DocumentHighlight (R 3 11 3 14) (Just DocumentHighlightKind_Read) ] - , testSessionWait "local" $ do - doc <- createDoc "A.hs" "haskell" source + , testSessionWait "local" source $ do + doc <- openDoc "A.hs" "haskell" _ <- waitForDiagnostics highlights <- getHighlights doc (Position 6 5) liftIO $ highlights @?= @@ -45,8 +49,8 @@ tests = testGroup "highlight" , DocumentHighlight (R 7 12 7 15) (Just DocumentHighlightKind_Read) ] , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "Ghc9 highlights the constructor and not just this field" $ - testSessionWait "record" $ do - doc <- createDoc "A.hs" "haskell" recsource + testSessionWait "record" recsource $ do + doc <- openDoc "A.hs" "haskell" _ <- waitForDiagnostics highlights <- getHighlights doc (Position 4 15) liftIO $ highlights @?= @@ -77,3 +81,4 @@ tests = testGroup "highlight" ,"data Rec = Rec { field1 :: Int, field2 :: Char }" ,"foo Rec{..} = field2 + field1" ] + testSessionWait name ct = testSessionWithCorePluginSingleFile name "A.hs" ct diff --git a/plugins/hls-core-plugin/test/exe/OutlineTests.hs b/plugins/hls-core-plugin/test/exe/OutlineTests.hs index 87c6111d8a..6e06e6276b 100644 --- a/plugins/hls-core-plugin/test/exe/OutlineTests.hs +++ b/plugins/hls-core-plugin/test/exe/OutlineTests.hs @@ -17,8 +17,6 @@ import Test.Tasty.HUnit import Util -- import TestUtils -pattern R :: UInt -> UInt -> UInt -> UInt -> Range -pattern R x y x' y' = Range (Position x y) (Position x' y') testSymbols :: (HasCallStack) => TestName -> FilePath -> [Text] -> [DocumentSymbol] -> TestTree testSymbols testName path content expectedSymbols = diff --git a/plugins/hls-core-plugin/test/exe/Util.hs b/plugins/hls-core-plugin/test/exe/Util.hs index deafb2cc54..38b40813b2 100644 --- a/plugins/hls-core-plugin/test/exe/Util.hs +++ b/plugins/hls-core-plugin/test/exe/Util.hs @@ -1,24 +1,52 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Avoid restricted function" #-} module Util where -import Data.Default (Default (..)) -import Data.Text (Text) -import qualified Data.Text as Text -import Development.IDE (GhcVersion, ghcVersion) -import qualified Ide.Plugin.Core as Core -import Language.LSP.Test (Session) -import System.FilePath (()) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Default (Default (..)) +import Data.Foldable (traverse_) +import Data.Maybe (fromJust) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text as Text +import Development.IDE (GhcVersion, ghcVersion) +import qualified Ide.Plugin.Core as Core +import Language.LSP.Protocol.Types (Definition (..), + DefinitionLink (..), + Location (..), LocationLink (..), + Null (..), Position (..), + Range (..), UInt, Uri (..), + filePathToUri, mkRange, + type (|?) (InL, InR), + uriToFilePath) +import Language.LSP.Test (Session) +import System.Directory.Extra (canonicalizePath) +import System.FilePath (()) import System.Info.Extra -import Test.Hls (PluginTestDescriptor, TestName, TestTree, - expectFailBecause, ignoreTestBecause, - mkPluginTestDescriptor, - runSessionWithServerInTmpDir, testCase) -import qualified Test.Hls.FileSystem as FS -import Test.Hls.FileSystem (file, text) +import Test.Hls (PluginTestDescriptor, TestName, + TestTree, assertBool, + expectFailBecause, + ignoreTestBecause, + mkPluginTestDescriptor, + runSessionWithServerInTmpDir, + testCase) +import qualified Test.Hls.FileSystem as FS +import Test.Hls.FileSystem (copy, file, text) +import Test.Tasty.HUnit (Assertion, assertFailure, (@=?), + (@?=)) +pattern R :: UInt -> UInt -> UInt -> UInt -> Range +pattern R x y x' y' = Range (Position x y) (Position x' y') + +testSessionWithCorePlugin :: TestName -> FS.VirtualFileTree -> Session () -> TestTree +testSessionWithCorePlugin caseName vfs = testCase caseName . runSessionWithCorePlugin vfs + runSessionWithCorePlugin :: FS.VirtualFileTree -> Session a -> IO a runSessionWithCorePlugin = runSessionWithServerInTmpDir def corePlugin @@ -28,15 +56,27 @@ runSessionWithCorePluginEmpty fps = runSessionWithCorePlugin (mkFs [FS.directCra runSessionWithCorePluginSingleFile :: FilePath -> Text -> Session a -> IO a runSessionWithCorePluginSingleFile fp content = runSessionWithCorePlugin (mkSingleFileFs fp content) +runSessionWithCorePluginSingleDirFile :: FilePath -> FilePath -> Session a -> IO a +runSessionWithCorePluginSingleDirFile dir fp = runSessionWithCorePlugin (mkSingleDirFileFs dir fp) + testSessionWithCorePluginSingleFile :: TestName -> FilePath -> Text -> Session () -> TestTree testSessionWithCorePluginSingleFile caseName fp content = testCase caseName . runSessionWithCorePluginSingleFile fp content +testSessionWithCorePluginSingleDirFile :: TestName + -> FilePath -- ^ subDir under testDataDir + -> FilePath -- ^ fileName + -> Session () -> TestTree +testSessionWithCorePluginSingleDirFile caseName subDir fp = testCase caseName . runSessionWithCorePluginSingleDirFile subDir fp + corePlugin :: PluginTestDescriptor Core.CoreLog corePlugin = mkPluginTestDescriptor Core.descriptor "core" mkSingleFileFs :: FilePath -> Text -> FS.VirtualFileTree mkSingleFileFs fp = mkFs . directFile fp +mkSingleDirFileFs :: FilePath -> FilePath -> FS.VirtualFileTree +mkSingleDirFileFs dir fp = FS.mkVirtualFileTree (testDataDir dir) [FS.directCradle [Text.pack fp], copy fp] + directFile :: FilePath -> Text -> [FS.FileTree] directFile fp content = [ FS.directCradle [Text.pack fp] @@ -47,44 +87,78 @@ mkFs :: [FS.FileTree] -> FS.VirtualFileTree mkFs = FS.mkVirtualFileTree testDataDir testDataDir :: FilePath -testDataDir = "plugins" "core-plugin" "test" "testdata" - - -data BrokenOS = Linux | MacOS | Windows deriving (Show) - -data IssueSolution = Broken | Ignore deriving (Show) - -data BrokenTarget = - BrokenSpecific BrokenOS [GhcVersion] - -- ^Broken for `BrokenOS` with `GhcVersion` - | BrokenForOS BrokenOS - -- ^Broken for `BrokenOS` - | BrokenForGHC [GhcVersion] - -- ^Broken for `GhcVersion` - deriving (Show) - -ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree -ignoreFor = knownIssueFor Ignore - --- | Known broken for specific os and ghc with reason. -knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree -knownBrokenFor = knownIssueFor Broken - --- | Deal with `IssueSolution` for specific OS and GHC. -knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree -knownIssueFor solution = go . \case - BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers - BrokenForOS bos -> isTargetOS bos - BrokenForGHC vers -> isTargetGhc vers - where - isTargetOS = \case - Windows -> isWindows - MacOS -> isMac - Linux -> not isWindows && not isMac - - isTargetGhc = elem ghcVersion - - go True = case solution of - Broken -> expectFailBecause - Ignore -> ignoreTestBecause - go False = const id +testDataDir = "plugins" "hls-core-plugin" "test" "testdata" + + +data Expect + = ExpectRange Range -- Both gotoDef and hover should report this range + | ExpectLocation Location +-- | ExpectDefRange Range -- Only gotoDef should report this range + | ExpectHoverRange Range -- Only hover should report this range + | ExpectHoverText [T.Text] -- the hover message must contain these snippets + | ExpectHoverExcludeText [T.Text] -- the hover message must _not_ contain these snippets + | ExpectHoverTextRegex T.Text -- the hover message must match this pattern + | ExpectExternFail -- definition lookup in other file expected to fail + | ExpectNoDefinitions + | ExpectNoHover +-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples + deriving Eq + +defToLocation :: Definition |? ([DefinitionLink] |? Null) -> [Location] +defToLocation (InL (Definition (InL l))) = [l] +defToLocation (InL (Definition (InR ls))) = ls +defToLocation (InR (InL defLink)) = (\(DefinitionLink LocationLink{_targetUri,_targetRange}) -> Location _targetUri _targetRange) <$> defLink +defToLocation (InR (InR Null)) = [] + +checkDefs :: Definition |? ([DefinitionLink] |? Null) -> Session [Expect] -> Session () +checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpectations where + check (ExpectRange expectedRange) = do + def <- assertOneDefinitionFound defs + assertRangeCorrect def expectedRange + check (ExpectLocation expectedLocation) = do + def <- assertOneDefinitionFound defs + liftIO $ do + canonActualLoc <- canonicalizeLocation def + canonExpectedLoc <- canonicalizeLocation expectedLocation + canonActualLoc @?= canonExpectedLoc + check ExpectNoDefinitions = do + liftIO $ assertBool "Expecting no definitions" $ null defs + check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file" + check _ = pure () -- all other expectations not relevant to getDefinition + + assertOneDefinitionFound :: [Location] -> Session Location + assertOneDefinitionFound [def] = pure def + assertOneDefinitionFound xs = liftIO . assertFailure $ "Expecting exactly one definition, got " <> show (length xs) + + assertRangeCorrect Location{_range = foundRange} expectedRange = + liftIO $ expectedRange @=? foundRange + + + +canonicalizeLocation :: Location -> IO Location +canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range + +canonicalizeUri :: Uri -> IO Uri +canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri)) + + +mkR :: UInt -> UInt -> UInt -> UInt -> Expect +mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn + +mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect +mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn + +-- mkRange :: UInt -> UInt -> UInt -> UInt -> Range +-- mkRange a b c d = Range (Position a b) (Position c d) + +xfail :: TestTree -> String -> TestTree +xfail = flip expectFailBecause + +standardizeQuotes :: T.Text -> T.Text +standardizeQuotes msg = let + repl '‘' = '\'' + repl '’' = '\'' + repl '`' = '\'' + repl c = c + in T.map repl msg + diff --git a/plugins/hls-core-plugin/test/testdata/hover/Bar.hs b/plugins/hls-core-plugin/test/testdata/hover/Bar.hs new file mode 100644 index 0000000000..f9fde2a7cc --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/hover/Bar.hs @@ -0,0 +1,4 @@ +module Bar (Bar(..)) where + +-- | Bar Haddock +data Bar = Bar diff --git a/plugins/hls-core-plugin/test/testdata/hover/Foo.hs b/plugins/hls-core-plugin/test/testdata/hover/Foo.hs new file mode 100644 index 0000000000..489a6ccd6b --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/hover/Foo.hs @@ -0,0 +1,6 @@ +module Foo (Bar, foo) where + +import Bar + +-- | foo Haddock +foo = Bar diff --git a/plugins/hls-core-plugin/test/testdata/hover/GotoHover.hs b/plugins/hls-core-plugin/test/testdata/hover/GotoHover.hs new file mode 100644 index 0000000000..6ff3eeffed --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/hover/GotoHover.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} +{- HLINT ignore -} +module GotoHover ( module GotoHover) where +import Data.Text (Text, pack) +import Foo (Bar, foo) + + +data TypeConstructor = DataConstructor + { fff :: Text + , ggg :: Int } +aaa :: TypeConstructor +aaa = DataConstructor + { fff = "dfgy" + , ggg = 832 + } +bbb :: TypeConstructor +bbb = DataConstructor "mjgp" 2994 +ccc :: (Text, Int) +ccc = (fff bbb, ggg aaa) +ddd :: Num a => a -> a -> a +ddd vv ww = vv +! ww +a +! b = a - b +hhh (Just a) (><) = a >< a +iii a b = a `b` a +jjj s = pack $ s <> s +class MyClass a where + method :: a -> Int +instance MyClass Int where + method = succ +kkk :: MyClass a => Int -> a -> Int +kkk n c = n + method c + +doBind :: Maybe () +doBind = do unwrapped <- Just () + return unwrapped + +listCompBind :: [Char] +listCompBind = [ succ c | c <- "ptfx" ] + +multipleClause :: Bool -> Char +multipleClause True = 't' +multipleClause False = 'f' + +-- | Recognizable docs: kpqz +documented :: Monad m => Either Int (m a) +documented = Left 7518 + +listOfInt = [ 8391 :: Int, 6268 ] + +outer :: Bool +outer = undefined inner where + + inner :: Char + inner = undefined + +imported :: Bar +imported = foo + +aa2 :: Bool +aa2 = $(id [| True |]) + +hole :: Int +hole = _ + +hole2 :: a -> Maybe a +hole2 = _ + +-- A comment above a type defnition with a deriving clause +data Example = Example + deriving (Eq) diff --git a/plugins/hls-core-plugin/test/testdata/hover/RecordDotSyntax.hs b/plugins/hls-core-plugin/test/testdata/hover/RecordDotSyntax.hs new file mode 100644 index 0000000000..3680d08a3c --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/hover/RecordDotSyntax.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedRecordDot, DuplicateRecordFields, NoFieldSelectors #-} + +module RecordDotSyntax ( module RecordDotSyntax) where + +import qualified Data.Maybe as M + +data MyRecord = MyRecord + { a :: String + , b :: Integer + , c :: MyChild + } deriving (Eq, Show) + +newtype MyChild = MyChild + { z :: String + } deriving (Eq, Show) + +x = MyRecord { a = "Hello", b = 12, c = MyChild { z = "there" } } +y = x.a ++ show x.b ++ x.c.z diff --git a/plugins/hls-core-plugin/test/testdata/hover/hie.yaml b/plugins/hls-core-plugin/test/testdata/hover/hie.yaml new file mode 100644 index 0000000000..e2b3e97c5d --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/hover/hie.yaml @@ -0,0 +1 @@ +cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}} From 9d895255ce79798e45722083f983b75fd282d614 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 6 Apr 2024 00:13:52 +0800 Subject: [PATCH 27/34] do ReferenceTests --- ghcide/ghcide.cabal | 1 - ghcide/test/data/hover/Bar.hs | 4 - ghcide/test/data/hover/Foo.hs | 6 - ghcide/test/data/hover/GotoHover.hs | 70 -------- ghcide/test/data/hover/RecordDotSyntax.hs | 18 --- ghcide/test/data/hover/hie.yaml | 1 - ghcide/test/exe/Main.hs | 2 - haskell-language-server.cabal | 3 + hls-test-utils/src/Test/Hls.hs | 152 ++++++++++-------- hls-test-utils/src/Test/Hls/FileSystem.hs | 26 ++- plugins/hls-core-plugin/test/CoreTest.hs | 2 + .../test/exe/FindDefinitionAndHoverTests.hs | 32 ++-- .../test/exe/ReferenceTests.hs | 58 ++++--- plugins/hls-core-plugin/test/exe/Util.hs | 32 +++- .../test/testdata/references/Main.hs | 14 ++ .../test/testdata/references/OtherModule.hs | 9 ++ .../testdata/references/OtherOtherModule.hs | 3 + .../test/testdata/references/References.hs | 25 +++ .../test/testdata/references/hie.yaml | 1 + 19 files changed, 230 insertions(+), 229 deletions(-) delete mode 100644 ghcide/test/data/hover/Bar.hs delete mode 100644 ghcide/test/data/hover/Foo.hs delete mode 100644 ghcide/test/data/hover/GotoHover.hs delete mode 100644 ghcide/test/data/hover/RecordDotSyntax.hs delete mode 100644 ghcide/test/data/hover/hie.yaml rename {ghcide => plugins/hls-core-plugin}/test/exe/ReferenceTests.hs (82%) create mode 100644 plugins/hls-core-plugin/test/testdata/references/Main.hs create mode 100644 plugins/hls-core-plugin/test/testdata/references/OtherModule.hs create mode 100644 plugins/hls-core-plugin/test/testdata/references/OtherOtherModule.hs create mode 100644 plugins/hls-core-plugin/test/testdata/references/References.hs create mode 100644 plugins/hls-core-plugin/test/testdata/references/hie.yaml diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index d451084510..64020fef5a 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -373,7 +373,6 @@ test-suite ghcide-tests PositionMappingTests PreprocessorTests Progress - ReferenceTests RootUriTests SafeTests SymlinkTests diff --git a/ghcide/test/data/hover/Bar.hs b/ghcide/test/data/hover/Bar.hs deleted file mode 100644 index f9fde2a7cc..0000000000 --- a/ghcide/test/data/hover/Bar.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Bar (Bar(..)) where - --- | Bar Haddock -data Bar = Bar diff --git a/ghcide/test/data/hover/Foo.hs b/ghcide/test/data/hover/Foo.hs deleted file mode 100644 index 489a6ccd6b..0000000000 --- a/ghcide/test/data/hover/Foo.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Foo (Bar, foo) where - -import Bar - --- | foo Haddock -foo = Bar diff --git a/ghcide/test/data/hover/GotoHover.hs b/ghcide/test/data/hover/GotoHover.hs deleted file mode 100644 index 6ff3eeffed..0000000000 --- a/ghcide/test/data/hover/GotoHover.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} -{- HLINT ignore -} -module GotoHover ( module GotoHover) where -import Data.Text (Text, pack) -import Foo (Bar, foo) - - -data TypeConstructor = DataConstructor - { fff :: Text - , ggg :: Int } -aaa :: TypeConstructor -aaa = DataConstructor - { fff = "dfgy" - , ggg = 832 - } -bbb :: TypeConstructor -bbb = DataConstructor "mjgp" 2994 -ccc :: (Text, Int) -ccc = (fff bbb, ggg aaa) -ddd :: Num a => a -> a -> a -ddd vv ww = vv +! ww -a +! b = a - b -hhh (Just a) (><) = a >< a -iii a b = a `b` a -jjj s = pack $ s <> s -class MyClass a where - method :: a -> Int -instance MyClass Int where - method = succ -kkk :: MyClass a => Int -> a -> Int -kkk n c = n + method c - -doBind :: Maybe () -doBind = do unwrapped <- Just () - return unwrapped - -listCompBind :: [Char] -listCompBind = [ succ c | c <- "ptfx" ] - -multipleClause :: Bool -> Char -multipleClause True = 't' -multipleClause False = 'f' - --- | Recognizable docs: kpqz -documented :: Monad m => Either Int (m a) -documented = Left 7518 - -listOfInt = [ 8391 :: Int, 6268 ] - -outer :: Bool -outer = undefined inner where - - inner :: Char - inner = undefined - -imported :: Bar -imported = foo - -aa2 :: Bool -aa2 = $(id [| True |]) - -hole :: Int -hole = _ - -hole2 :: a -> Maybe a -hole2 = _ - --- A comment above a type defnition with a deriving clause -data Example = Example - deriving (Eq) diff --git a/ghcide/test/data/hover/RecordDotSyntax.hs b/ghcide/test/data/hover/RecordDotSyntax.hs deleted file mode 100644 index 3680d08a3c..0000000000 --- a/ghcide/test/data/hover/RecordDotSyntax.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot, DuplicateRecordFields, NoFieldSelectors #-} - -module RecordDotSyntax ( module RecordDotSyntax) where - -import qualified Data.Maybe as M - -data MyRecord = MyRecord - { a :: String - , b :: Integer - , c :: MyChild - } deriving (Eq, Show) - -newtype MyChild = MyChild - { z :: String - } deriving (Eq, Show) - -x = MyRecord { a = "Hello", b = 12, c = MyChild { z = "there" } } -y = x.a ++ show x.b ++ x.c.z diff --git a/ghcide/test/data/hover/hie.yaml b/ghcide/test/data/hover/hie.yaml deleted file mode 100644 index e2b3e97c5d..0000000000 --- a/ghcide/test/data/hover/hie.yaml +++ /dev/null @@ -1 +0,0 @@ -cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}} diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 82be67998a..b64213e1df 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -67,7 +67,6 @@ import BootTests import RootUriTests import AsyncTests import ClientSettingsTests -import ReferenceTests import GarbageCollectionTests import ExceptionTests @@ -108,7 +107,6 @@ main = do , RootUriTests.tests , AsyncTests.tests , ClientSettingsTests.tests - , ReferenceTests.tests , GarbageCollectionTests.tests , HieDbRetry.tests , ExceptionTests.tests recorder logger diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 7be5644a0f..4d30df27e9 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1768,6 +1768,7 @@ test-suite hls-core-plugin-tests OutlineTests CompletionTests HighlightTests + ReferenceTests build-depends: @@ -1793,6 +1794,8 @@ test-suite hls-core-plugin-tests , extra , hls-test-utils , regex-tdfa + , directory + , tasty-expected-failure ----------------------------- diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 38c4b9b7ae..02e4b0819e 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -29,6 +29,7 @@ module Test.Hls -- * Running HLS for integration tests runSessionWithServer, runSessionWithServerAndCaps, + TestRunner, runSessionWithServerInTmpDir, runSessionWithServerAndCapsInTmpDir, runSessionWithServer', @@ -368,6 +369,86 @@ initialiseTestRecorder envVars = do -- ------------------------------------------------------------ -- Run an HLS server testing a specific plugin -- ------------------------------------------------------------ +class TestRunner cont res where + runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> cont -> IO res + runSessionWithServerInTmpDir config plugin tree act = do + recorder <- pluginTestRecorder + runSessionWithServerInTmpDir' (plugin recorder) config def fullCaps tree act + runSessionWithServerAndCapsInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> cont -> IO res + runSessionWithServerAndCapsInTmpDir config plugin caps tree act = do + recorder <- pluginTestRecorder + runSessionWithServerInTmpDir' (plugin recorder) config def caps tree act + + -- | Host a server, and run a test session on it. + -- + -- Creates a temporary directory, and materializes the VirtualFileTree + -- in the temporary directory. + -- + -- To debug test cases and verify the file system is correctly set up, + -- you should set the environment variable 'HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1'. + -- Further, we log the temporary directory location on startup. To view + -- the logs, set the environment variable 'HLS_TEST_HARNESS_STDERR=1'. + -- + -- Example invocation to debug test cases: + -- + -- @ + -- HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 HLS_TEST_HARNESS_STDERR=1 cabal test + -- @ + -- + -- Don't forget to use 'TASTY_PATTERN' to debug only a subset of tests. + -- + -- For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'. + -- + -- Note: cwd will be shifted into a temporary directory in @Session a@ + runSessionWithServerInTmpDir' :: + -- | Plugins to load on the server. + -- + -- For improved logging, make sure these plugins have been initalised with + -- the recorder produced by @pluginTestRecorder@. + IdePlugins IdeState -> + -- | lsp config for the server + Config -> + -- | config for the test session + SessionConfig -> + ClientCapabilities -> + VirtualFileTree -> + cont -> IO res + runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = withLock lockForTempDirs $ do + testRoot <- setupTestEnvironment + (recorder, _) <- initialiseTestRecorder + ["LSP_TEST_LOG_STDERR", "HLS_TEST_HARNESS_STDERR", "HLS_TEST_LOG_STDERR"] + + -- Do not clean up the temporary directory if this variable is set to anything but '0'. + -- Aids debugging. + cleanupTempDir <- lookupEnv "HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP" + let runTestInDir action = case cleanupTempDir of + Just val | val /= "0" -> do + (tempDir, _) <- newTempDirWithin testRoot + a <- action tempDir + logWith recorder Debug LogNoCleanup + pure a + + _ -> do + (tempDir, cleanup) <- newTempDirWithin testRoot + a <- action tempDir `finally` cleanup + logWith recorder Debug LogCleanup + pure a + + runTestInDir $ \tmpDir -> do + logWith recorder Info $ LogTestDir tmpDir + fs <- FS.materialiseVFT tmpDir tree + runSessionWithServer' plugins conf sessConf caps tmpDir (contToSessionRes fs act) + contToSessionRes :: FileSystem -> cont -> Session res + + +instance TestRunner (Session a) a where + contToSessionRes _ act = act + + +instance TestRunner (FileSystem -> Session a) a where + contToSessionRes fs act = act fs + + runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a runSessionWithServer config plugin fp act = do @@ -379,77 +460,6 @@ runSessionWithServerAndCaps config plugin caps fp act = do recorder <- pluginTestRecorder runSessionWithServer' (plugin recorder) config def caps fp act -runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a -runSessionWithServerInTmpDir config plugin tree act = do - recorder <- pluginTestRecorder - runSessionWithServerInTmpDir' (plugin recorder) config def fullCaps tree act - -runSessionWithServerAndCapsInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> Session a -> IO a -runSessionWithServerAndCapsInTmpDir config plugin caps tree act = do - recorder <- pluginTestRecorder - runSessionWithServerInTmpDir' (plugin recorder) config def caps tree act - --- | Host a server, and run a test session on it. --- --- Creates a temporary directory, and materializes the VirtualFileTree --- in the temporary directory. --- --- To debug test cases and verify the file system is correctly set up, --- you should set the environment variable 'HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1'. --- Further, we log the temporary directory location on startup. To view --- the logs, set the environment variable 'HLS_TEST_HARNESS_STDERR=1'. --- --- Example invocation to debug test cases: --- --- @ --- HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 HLS_TEST_HARNESS_STDERR=1 cabal test --- @ --- --- Don't forget to use 'TASTY_PATTERN' to debug only a subset of tests. --- --- For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'. --- --- Note: cwd will be shifted into a temporary directory in @Session a@ -runSessionWithServerInTmpDir' :: - -- | Plugins to load on the server. - -- - -- For improved logging, make sure these plugins have been initalised with - -- the recorder produced by @pluginTestRecorder@. - IdePlugins IdeState -> - -- | lsp config for the server - Config -> - -- | config for the test session - SessionConfig -> - ClientCapabilities -> - VirtualFileTree -> - Session a -> - IO a -runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = withLock lockForTempDirs $ do - testRoot <- setupTestEnvironment - (recorder, _) <- initialiseTestRecorder - ["LSP_TEST_LOG_STDERR", "HLS_TEST_HARNESS_STDERR", "HLS_TEST_LOG_STDERR"] - - -- Do not clean up the temporary directory if this variable is set to anything but '0'. - -- Aids debugging. - cleanupTempDir <- lookupEnv "HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP" - let runTestInDir action = case cleanupTempDir of - Just val - | val /= "0" -> do - (tempDir, _) <- newTempDirWithin testRoot - a <- action tempDir - logWith recorder Debug LogNoCleanup - pure a - - _ -> do - (tempDir, cleanup) <- newTempDirWithin testRoot - a <- action tempDir `finally` cleanup - logWith recorder Debug LogCleanup - pure a - - runTestInDir $ \tmpDir -> do - logWith recorder Info $ LogTestDir tmpDir - _fs <- FS.materialiseVFT tmpDir tree - runSessionWithServer' plugins conf sessConf caps tmpDir act -- | Setup the test environment for isolated tests. -- diff --git a/hls-test-utils/src/Test/Hls/FileSystem.hs b/hls-test-utils/src/Test/Hls/FileSystem.hs index b6742c4b83..1f6541e35e 100644 --- a/hls-test-utils/src/Test/Hls/FileSystem.hs +++ b/hls-test-utils/src/Test/Hls/FileSystem.hs @@ -20,6 +20,7 @@ module Test.Hls.FileSystem , directory , text , ref + , copyDir -- * Cradle helpers , directCradle , simpleCabalCradle @@ -66,6 +67,7 @@ data VirtualFileTree = data FileTree = File FilePath Content | Directory FilePath [FileTree] + | CopiedDirectory FilePath deriving (Show, Eq, Ord) data Content @@ -99,12 +101,15 @@ materialise rootDir' fileTree testDataDir' = do rootDir = FP.normalise rootDir' persist :: FilePath -> FileTree -> IO () - persist fp (File name cts) = case cts of - Inline txt -> T.writeFile (fp name) txt - Ref path -> copyFile (testDataDir FP.normalise path) (fp takeFileName name) - persist fp (Directory name nodes) = do - createDirectory (fp name) - mapM_ (persist (fp name)) nodes + persist root (File name cts) = case cts of + Inline txt -> T.writeFile (root name) txt + Ref path -> copyFile (testDataDir FP.normalise path) (root takeFileName name) + persist root (Directory name nodes) = do + createDirectory (root name) + mapM_ (persist (root name)) nodes + persist root (CopiedDirectory name) = do + nodes <- copyDir' testDataDir' name + mapM_ (persist root) nodes traverse_ (persist rootDir) fileTree pure $ FileSystem rootDir fileTree testDataDir @@ -154,6 +159,15 @@ file fp cts = File fp cts copy :: FilePath -> FileTree copy fp = File fp (Ref fp) +copyDir :: FilePath -> FileTree +copyDir dir = CopiedDirectory dir + +-- | Copy a directory into a test project. +copyDir' :: FilePath -> FilePath -> IO [FileTree] +copyDir' root dir = do + files <- listDirectory (root dir) + traverse (\f -> pure $ copy (dir f)) files + directory :: FilePath -> [FileTree] -> FileTree directory name nodes = Directory name nodes diff --git a/plugins/hls-core-plugin/test/CoreTest.hs b/plugins/hls-core-plugin/test/CoreTest.hs index fccfaa8028..453d2e5e7c 100644 --- a/plugins/hls-core-plugin/test/CoreTest.hs +++ b/plugins/hls-core-plugin/test/CoreTest.hs @@ -7,6 +7,7 @@ import qualified FindDefinitionAndHoverTests import qualified HighlightTests import qualified InitializeResponseTests import qualified OutlineTests +import qualified ReferenceTests import Test.Hls (defaultTestRunner, testGroup) @@ -21,4 +22,5 @@ main = , CompletionTests.tests , HighlightTests.tests , FindDefinitionAndHoverTests.tests + , ReferenceTests.tests ] diff --git a/plugins/hls-core-plugin/test/exe/FindDefinitionAndHoverTests.hs b/plugins/hls-core-plugin/test/exe/FindDefinitionAndHoverTests.hs index b333ded190..498cb4ab33 100644 --- a/plugins/hls-core-plugin/test/exe/FindDefinitionAndHoverTests.hs +++ b/plugins/hls-core-plugin/test/exe/FindDefinitionAndHoverTests.hs @@ -9,7 +9,6 @@ import Data.Foldable import Data.Maybe import qualified Data.Text as T import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) -import Development.IDE.GHC.Util -- import Development.IDE.Test (expectDiagnostics, -- standardizeQuotes) import qualified Language.LSP.Protocol.Lens as L @@ -19,45 +18,34 @@ import qualified Language.LSP.Protocol.Lens as L -- SemanticTokensEdit (..), -- mkRange) -import Language.LSP.Protocol.Types (DiagnosticSeverity (..), - Hover (..), MarkupContent (..), +import Language.LSP.Protocol.Types (Hover (..), MarkupContent (..), Position (..), Range, TextDocumentIdentifier, mkRange, type (|?) (..)) import Language.LSP.Test -import System.FilePath import System.Info.Extra (isWindows) import Control.Lens ((^.)) import Test.Tasty import Test.Tasty.HUnit -- import TestUtils -import Test.Hls (knownBrokenForGhcVersions, - waitForProgressDone, +import Test.Hls (waitForProgressDone, waitForTypecheck) -import Test.Hls.FileSystem (copy, directProjectMulti) +import Test.Hls.FileSystem (copyDir) import Text.Regex.TDFA ((=~)) import Util tests :: TestTree tests = let tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree - tst (get, check) pos sfp targetRange title = testSessionWithCorePlugin title (mkFs $ fmap (copy . ("hover" )) ["Bar.hs", "Foo.hs", "GotoHover.hs", "hie.yaml", "RecordDotSyntax.hs"]) $ do - -- Dirty the cache to check that definitions work even in the presence of iface files - -- let fooPath = "Foo.hs" - -- fooSource <- liftIO $ readFileUtf8 fooPath - -- fooDoc <- createDoc fooPath "haskell" fooSource - -- _ <- getHover fooDoc $ Position 4 3 - -- closeDoc fooDoc - - doc <- openDoc sfp "haskell" - waitForProgressDone - x <- waitForTypecheck doc - - - found <- get doc pos - check found targetRange + tst (get, check) pos sfp targetRange title = + testSessionWithCorePlugin title (mkFs [copyDir "hover"]) $ do + doc <- openDoc sfp "haskell" + waitForProgressDone + x <- waitForTypecheck doc + found <- get doc pos + check found targetRange diff --git a/ghcide/test/exe/ReferenceTests.hs b/plugins/hls-core-plugin/test/exe/ReferenceTests.hs similarity index 82% rename from ghcide/test/exe/ReferenceTests.hs rename to plugins/hls-core-plugin/test/exe/ReferenceTests.hs index 5abb18bfe8..031ecdda91 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ b/plugins/hls-core-plugin/test/exe/ReferenceTests.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module ReferenceTests (tests) where @@ -7,8 +8,6 @@ import Control.Monad import Control.Monad.IO.Class (liftIO) import Data.List.Extra import qualified Data.Set as Set -import Development.IDE.Test (configureCheckProject, - referenceReady) import Development.IDE.Types.Location import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types hiding @@ -20,12 +19,18 @@ import Language.LSP.Test import System.Directory import System.FilePath -- import Test.QuickCheck.Instances () +import Control.Concurrent (threadDelay) import Control.Lens ((^.)) import Data.Tuple.Extra +import Test.Hls (waitForAllProgressDone, + waitForBuildQueue, + waitForProgressDone) +import Test.Hls.FileSystem (copy, copyDir, + directProjectMulti, toAbsFp) import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit -import TestUtils +import Util tests :: TestTree @@ -156,36 +161,43 @@ getReferences' (file, l, c) includeDeclaration = do where toBool YesIncludeDeclaration = True toBool NoExcludeDeclaration = False -referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree -referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do - -- needed to build whole project indexing - configureCheckProject True - let docs = map (dir ) $ delete thisDoc $ nubOrd docs' - -- Initial Index - docid <- openDoc thisDoc "haskell" - let - loop :: [FilePath] -> Session () - loop [] = pure () - loop docs = do - doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) - loop (delete doc docs) - loop docs - f dir - closeDoc docid +referenceTestSession :: HasCallStack => String -> FilePath -> [FilePath] -> Session () -> TestTree +referenceTestSession name thisDoc docs' f = do + testSessionWithCorePlugin name (mkFs [copyDir "references"]) $ \fs -> do + -- needed to build whole project indexing + configureCheckProject True + + -- Initial Index + docid <- openDoc thisDoc "haskell" + + -- need to get the real paths through links + docs <- mapM (liftIO . canonicalizePath . toAbsFp fs) $ delete thisDoc $ nubOrd docs' + liftIO $ putStrLn $ "docs:" <> show docs + let + -- todo wait for docs + loop :: [FilePath] -> Session () + loop [] = pure () + loop docs = do + + doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) + loop (delete doc docs) + loop docs + f + closeDoc docid -- | Given a location, lookup the symbol and all references to it. Make sure -- they are the ones we expect. -referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree +referenceTest :: (HasCallStack) => String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree referenceTest name loc includeDeclaration expected = - referenceTestSession name (fst3 loc) docs $ \dir -> do + referenceTestSession name (fst3 loc) docs $ do actual <- getReferences' loc includeDeclaration - liftIO $ actual `expectSameLocations` map (first3 (dir )) expected + liftIO $ actual `expectSameLocations` expected where docs = map fst3 expected type SymbolLocation = (FilePath, UInt, UInt) -expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion +expectSameLocations :: (HasCallStack) => [Location] -> [SymbolLocation] -> Assertion expectSameLocations actual expected = do let actual' = Set.map (\location -> (location ^. L.uri diff --git a/plugins/hls-core-plugin/test/exe/Util.hs b/plugins/hls-core-plugin/test/exe/Util.hs index 38b40813b2..b7224b1942 100644 --- a/plugins/hls-core-plugin/test/exe/Util.hs +++ b/plugins/hls-core-plugin/test/exe/Util.hs @@ -7,15 +7,20 @@ module Util where +import Control.Monad (void) import Control.Monad.IO.Class (MonadIO (..)) +import qualified Data.Aeson as A import Data.Default (Default (..)) import Data.Foldable (traverse_) import Data.Maybe (fromJust) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text as Text +import Debug.Trace (traceShow) import Development.IDE (GhcVersion, ghcVersion) +import GHC.TypeLits (symbolVal) import qualified Ide.Plugin.Core as Core +import Ide.Types (Config (..)) import Language.LSP.Protocol.Types (Definition (..), DefinitionLink (..), Location (..), LocationLink (..), @@ -28,12 +33,16 @@ import Language.LSP.Test (Session) import System.Directory.Extra (canonicalizePath) import System.FilePath (()) import System.Info.Extra -import Test.Hls (PluginTestDescriptor, TestName, - TestTree, assertBool, - expectFailBecause, +import Test.Hls (FromServerMessage' (..), + PluginTestDescriptor, + SMethod (..), TCustomMessage (..), + TNotificationMessage (..), + TestName, TestRunner, TestTree, + assertBool, expectFailBecause, ignoreTestBecause, mkPluginTestDescriptor, runSessionWithServerInTmpDir, + satisfyMaybe, setConfigSection, testCase) import qualified Test.Hls.FileSystem as FS import Test.Hls.FileSystem (copy, file, text) @@ -44,10 +53,10 @@ import Test.Tasty.HUnit (Assertion, assertFailure, (@=?), pattern R :: UInt -> UInt -> UInt -> UInt -> Range pattern R x y x' y' = Range (Position x y) (Position x' y') -testSessionWithCorePlugin :: TestName -> FS.VirtualFileTree -> Session () -> TestTree +testSessionWithCorePlugin ::(TestRunner cont ()) => TestName -> FS.VirtualFileTree -> cont -> TestTree testSessionWithCorePlugin caseName vfs = testCase caseName . runSessionWithCorePlugin vfs -runSessionWithCorePlugin :: FS.VirtualFileTree -> Session a -> IO a +runSessionWithCorePlugin :: (TestRunner cont res) => FS.VirtualFileTree -> cont -> IO res runSessionWithCorePlugin = runSessionWithServerInTmpDir def corePlugin runSessionWithCorePluginEmpty :: [Text] -> Session a -> IO a @@ -162,3 +171,16 @@ standardizeQuotes msg = let repl c = c in T.map repl msg + +configureCheckProject :: Bool -> Session () +configureCheckProject overrideCheckProject = setConfigSection "haskell" (A.toJSON $ def{checkProject = overrideCheckProject}) + + +referenceReady :: (FilePath -> Bool) -> Session FilePath +referenceReady pred = satisfyMaybe $ \case + FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params}) + | A.Success fp <- A.fromJSON _params + , pred fp + , symbolVal p == "ghcide/reference/ready" + -> traceShow ("referenceReady", fp) $ Just fp + _ -> Nothing diff --git a/plugins/hls-core-plugin/test/testdata/references/Main.hs b/plugins/hls-core-plugin/test/testdata/references/Main.hs new file mode 100644 index 0000000000..4a976f3fd0 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/references/Main.hs @@ -0,0 +1,14 @@ +module Main where + +import References + +main :: IO () +main = return () + + + +a = 2 :: Int +b = a + 1 + +acc :: Account +acc = Savings diff --git a/plugins/hls-core-plugin/test/testdata/references/OtherModule.hs b/plugins/hls-core-plugin/test/testdata/references/OtherModule.hs new file mode 100644 index 0000000000..4840f46d8e --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/references/OtherModule.hs @@ -0,0 +1,9 @@ +module OtherModule (symbolDefinedInOtherModule, symbolDefinedInOtherOtherModule) where + +import OtherOtherModule + +symbolDefinedInOtherModule = 1 + +symbolLocalToOtherModule = 2 + +someFxn x = x + symbolLocalToOtherModule diff --git a/plugins/hls-core-plugin/test/testdata/references/OtherOtherModule.hs b/plugins/hls-core-plugin/test/testdata/references/OtherOtherModule.hs new file mode 100644 index 0000000000..d567b8cb97 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/references/OtherOtherModule.hs @@ -0,0 +1,3 @@ +module OtherOtherModule where + +symbolDefinedInOtherOtherModule = "asdf" diff --git a/plugins/hls-core-plugin/test/testdata/references/References.hs b/plugins/hls-core-plugin/test/testdata/references/References.hs new file mode 100644 index 0000000000..ac76b4de40 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/references/References.hs @@ -0,0 +1,25 @@ +module References where + +import OtherModule + +foo = bar + +bar = let x = bar 42 in const "hello" + +baz = do + x <- bar 23 + return $ bar 14 + +data Account = + Checking + | Savings + +bobsAccount = Checking + +bobHasChecking = case bobsAccount of + Checking -> True + Savings -> False + +x = symbolDefinedInOtherModule + +y = symbolDefinedInOtherOtherModule diff --git a/plugins/hls-core-plugin/test/testdata/references/hie.yaml b/plugins/hls-core-plugin/test/testdata/references/hie.yaml new file mode 100644 index 0000000000..db42bad0c0 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/references/hie.yaml @@ -0,0 +1 @@ +cradle: {direct: {arguments: ["Main","OtherModule","OtherOtherModule","References"]}} From 177c26bb7a8f12da45556f3c9235852ac5772172 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 6 Apr 2024 00:14:19 +0800 Subject: [PATCH 28/34] cleanup --- plugins/hls-core-plugin/test/exe/ReferenceTests.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/plugins/hls-core-plugin/test/exe/ReferenceTests.hs b/plugins/hls-core-plugin/test/exe/ReferenceTests.hs index 031ecdda91..c5abb1c785 100644 --- a/plugins/hls-core-plugin/test/exe/ReferenceTests.hs +++ b/plugins/hls-core-plugin/test/exe/ReferenceTests.hs @@ -17,16 +17,10 @@ import Language.LSP.Protocol.Types hiding mkRange) import Language.LSP.Test import System.Directory -import System.FilePath -- import Test.QuickCheck.Instances () -import Control.Concurrent (threadDelay) import Control.Lens ((^.)) import Data.Tuple.Extra -import Test.Hls (waitForAllProgressDone, - waitForBuildQueue, - waitForProgressDone) -import Test.Hls.FileSystem (copy, copyDir, - directProjectMulti, toAbsFp) +import Test.Hls.FileSystem (copyDir, toAbsFp) import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit From f09ad67e2312a8d36f830f25dc6df6f44748a749 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 6 Apr 2024 00:14:45 +0800 Subject: [PATCH 29/34] clean up --- plugins/hls-core-plugin/test/exe/ReferenceTests.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-core-plugin/test/exe/ReferenceTests.hs b/plugins/hls-core-plugin/test/exe/ReferenceTests.hs index c5abb1c785..36379006f6 100644 --- a/plugins/hls-core-plugin/test/exe/ReferenceTests.hs +++ b/plugins/hls-core-plugin/test/exe/ReferenceTests.hs @@ -155,7 +155,7 @@ getReferences' (file, l, c) includeDeclaration = do where toBool YesIncludeDeclaration = True toBool NoExcludeDeclaration = False -referenceTestSession :: HasCallStack => String -> FilePath -> [FilePath] -> Session () -> TestTree +referenceTestSession :: String -> FilePath -> [FilePath] -> Session () -> TestTree referenceTestSession name thisDoc docs' f = do testSessionWithCorePlugin name (mkFs [copyDir "references"]) $ \fs -> do -- needed to build whole project indexing From 5affe75b8983a2f056ee231840228e410dd53de5 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 6 Apr 2024 00:44:52 +0800 Subject: [PATCH 30/34] fix semantic tokens test --- .../test/SemanticTokensTest.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index e8a21396ee..66d9da3dd5 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -37,8 +37,8 @@ import System.FilePath import Test.Hls (HasCallStack, PluginTestDescriptor, SMethod (SMethod_TextDocumentSemanticTokensFullDelta), - TestName, TestTree, - changeDoc, + TestName, TestRunner, + TestTree, changeDoc, defaultTestRunner, documentContents, fullCaps, goldenGitDiff, @@ -72,14 +72,14 @@ semanticTokensPlugin = Test.Hls.mkPluginTestDescriptor enabledSemanticDescriptor } } -goldenWithHaskellAndCapsOutPut :: Pretty b => Config -> PluginTestDescriptor b -> TestName -> FS.VirtualFileTree -> FilePath -> String -> (TextDocumentIdentifier -> Session String) -> TestTree +goldenWithHaskellAndCapsOutPut :: (Pretty b) => Config -> PluginTestDescriptor b -> TestName -> FS.VirtualFileTree -> FilePath -> String -> (TextDocumentIdentifier -> Session String) -> TestTree goldenWithHaskellAndCapsOutPut config plugin title tree path desc act = goldenGitDiff title (FS.vftOriginalRoot tree path <.> desc) $ - runSessionWithServerInTmpDir config plugin tree $ - fromString <$> do + fromString <$> (runSessionWithServerInTmpDir config plugin tree $ + do doc <- openDoc (path <.> "hs") "haskell" void waitForBuildQueue - act doc + act doc) goldenWithSemanticTokensWithDefaultConfig :: TestName -> FilePath -> TestTree goldenWithSemanticTokensWithDefaultConfig title path = From e2181d86cbaf299a9edac554a9bcc71d3909726b Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 8 Apr 2024 19:05:49 +0800 Subject: [PATCH 31/34] update --- ghcide/ghcide.cabal | 1 - .../session-loader/Development/IDE/Session.hs | 4 +- ghcide/src/Development/IDE/Core/Rules.hs | 22 ++ ghcide/src/Development/IDE/Core/Shake.hs | 2 + ghcide/test/exe/CradleTests.hs | 17 +- haskell-language-server.cabal | 1 + hls-graph/hls-graph.cabal | 2 + .../IDE/Graph/Internal/DataSize.hs | 94 ++++++ .../Development/IDE/Graph/Internal/Profile.hs | 16 +- hls-test-utils/src/Test/Hls.hs | 54 +++- hls-test-utils/src/Test/Hls/FileSystem.hs | 15 +- plugins/hls-core-plugin/test/CoreTest.hs | 2 + .../hls-core-plugin/test/exe/CradleTests.hs | 267 ++++++++++++++++++ plugins/hls-core-plugin/test/exe/Util.hs | 198 ++++++++++++- .../test/testdata/cabal-exe/a/a.cabal | 14 + .../test/testdata/cabal-exe/a/src/Main.hs | 3 + .../test/testdata/cabal-exe/cabal.project | 1 + .../test/testdata/cabal-exe/hie.yaml | 3 + .../testdata/ignore-change/IgnoreFatal.hs | 5 + .../test/testdata/ignore-change/cabal.project | 1 + .../test/testdata/ignore-change/hie.yaml | 3 + .../testdata/ignore-change/ignore-fatal.cabal | 10 + .../test/testdata/ignore-fatal/IgnoreFatal.hs | 8 + .../test/testdata/ignore-fatal/cabal.project | 1 + .../test/testdata/ignore-fatal/hie.yaml | 4 + .../testdata/ignore-fatal/ignore-fatal.cabal | 10 + .../test/testdata/multi/a/A.hs | 3 + .../test/testdata/multi/a/a.cabal | 9 + .../test/testdata/multi/b/B.hs | 3 + .../test/testdata/multi/b/b.cabal | 9 + .../test/testdata/multi/c/C.hs | 3 + .../test/testdata/multi/c/c.cabal | 9 + .../test/testdata/multi/cabal.project | 3 + .../test/testdata/multi/hie.yaml | 8 + 34 files changed, 770 insertions(+), 35 deletions(-) create mode 100644 hls-graph/src/Development/IDE/Graph/Internal/DataSize.hs create mode 100644 plugins/hls-core-plugin/test/exe/CradleTests.hs create mode 100644 plugins/hls-core-plugin/test/testdata/cabal-exe/a/a.cabal create mode 100644 plugins/hls-core-plugin/test/testdata/cabal-exe/a/src/Main.hs create mode 100644 plugins/hls-core-plugin/test/testdata/cabal-exe/cabal.project create mode 100644 plugins/hls-core-plugin/test/testdata/cabal-exe/hie.yaml create mode 100644 plugins/hls-core-plugin/test/testdata/ignore-change/IgnoreFatal.hs create mode 100644 plugins/hls-core-plugin/test/testdata/ignore-change/cabal.project create mode 100644 plugins/hls-core-plugin/test/testdata/ignore-change/hie.yaml create mode 100644 plugins/hls-core-plugin/test/testdata/ignore-change/ignore-fatal.cabal create mode 100644 plugins/hls-core-plugin/test/testdata/ignore-fatal/IgnoreFatal.hs create mode 100644 plugins/hls-core-plugin/test/testdata/ignore-fatal/cabal.project create mode 100644 plugins/hls-core-plugin/test/testdata/ignore-fatal/hie.yaml create mode 100644 plugins/hls-core-plugin/test/testdata/ignore-fatal/ignore-fatal.cabal create mode 100644 plugins/hls-core-plugin/test/testdata/multi/a/A.hs create mode 100644 plugins/hls-core-plugin/test/testdata/multi/a/a.cabal create mode 100644 plugins/hls-core-plugin/test/testdata/multi/b/B.hs create mode 100644 plugins/hls-core-plugin/test/testdata/multi/b/b.cabal create mode 100644 plugins/hls-core-plugin/test/testdata/multi/c/C.hs create mode 100644 plugins/hls-core-plugin/test/testdata/multi/c/c.cabal create mode 100644 plugins/hls-core-plugin/test/testdata/multi/cabal.project create mode 100644 plugins/hls-core-plugin/test/testdata/multi/hie.yaml diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 64020fef5a..61be7745f5 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -357,7 +357,6 @@ test-suite ghcide-tests ClientSettingsTests CodeLensTests CPPTests - CradleTests DependentFileTest DiagnosticTests ExceptionTests diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index e6d1a6696b..f614c99e44 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -647,6 +647,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- Display a user friendly progress message here: They probably don't know what a cradle is let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfp <> ")" + mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/eopts/before")) (toJSON cfp) eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfp @@ -654,8 +655,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do res <- cradleToOptsAndLibDir recorder cradle cfp old_files addTag "result" (show res) return res - + mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/eopts/after")) (toJSON cfp) logWith recorder Debug $ LogSessionLoadingResult eopts + mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/eopts/afterLog")) (toJSON (show $ pretty (LogSessionLoadingResult eopts))) case eopts of -- The cradle gave us some options so get to work turning them -- into and HscEnv. diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 6242ccff50..cde58a2d8a 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -162,6 +162,7 @@ import Language.LSP.Protocol.Types (MessageType (Mess ShowMessageParams (ShowMessageParams)) import Language.LSP.Server (LspT) import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.VFS import Prelude hiding (mod) import System.Directory (doesFileExist, @@ -170,6 +171,7 @@ import System.Info.Extra (isWindows) import GHC.Fingerprint +import qualified Development.IDE.Session as Session -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] @@ -179,12 +181,14 @@ import GHC (mgModSummaries) #if MIN_VERSION_ghc(9,3,0) import qualified Data.IntMap as IM +import Data.Row (KnownSymbol) #endif data Log = LogShake Shake.Log + | LogSession Session.Log | LogReindexingHieFile !NormalizedFilePath | LogLoadingHieFile !NormalizedFilePath | LogLoadingHieFileFail !FilePath !SomeException @@ -214,6 +218,7 @@ instance Pretty Log where <+> "the HLS version being used, the plugins enabled, and if possible the codebase and file which" <+> "triggered this warning." ] + LogSession msg -> pretty msg templateHaskellInstructions :: T.Text templateHaskellInstructions = "https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html#static-binaries" @@ -707,8 +712,24 @@ loadGhcSession recorder ghcSessionDepsConfig = do return (fingerprint, res) defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do + -- todo add signal + ShakeExtras{exportsMap, ideTesting = IdeTesting testing, lspEnv, progress} <- getShakeExtras + let + signal' :: KnownSymbol s => Proxy s -> String -> Action () + signal' msg str = when testing $ liftIO $ + mRunLspT lspEnv $ + LSP.sendNotification (LSP.SMethod_CustomMethod msg) $ + toJSON $ [str] + signal :: KnownSymbol s => Proxy s -> Action () + signal msg = signal' msg (show file) + + + + signal (Proxy @"GhcSession/start") IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO + signal (Proxy @"GhcSession/loadSessionFun/before") (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file + signal (Proxy @"GhcSession/loadSessionFun/after") -- add the deps to the Shake graph let addDependency fp = do @@ -721,6 +742,7 @@ loadGhcSession recorder ghcSessionDepsConfig = do mapM_ addDependency deps let cutoffHash = LBS.toStrict $ B.encode (hash (snd val)) + signal (Proxy @"GhcSession/done") return (Just cutoffHash, val) defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \(GhcSessionDeps_ fullModSummary) file -> do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 5d5eb511d2..9ceabb20cf 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -137,6 +137,7 @@ import Development.IDE.Graph.Database (ShakeDatabase, shakeNewDatabase, shakeProfileDatabase, shakeRunDatabaseForKeys) +import Development.IDE.Graph.Internal.Profile (collectProfileMemory) import Development.IDE.Graph.Rule import Development.IDE.Types.Action import Development.IDE.Types.Diagnostics @@ -716,6 +717,7 @@ shakeShut IdeState{..} = do -- request so we first abort that. for_ runner cancelShakeSession void $ shakeDatabaseProfile shakeDb + void $ collectProfileMemory shakeDb progressStop $ progress shakeExtras stopMonitoring diff --git a/ghcide/test/exe/CradleTests.hs b/ghcide/test/exe/CradleTests.hs index a0a6cc364b..3a318c5fdf 100644 --- a/ghcide/test/exe/CradleTests.hs +++ b/ghcide/test/exe/CradleTests.hs @@ -205,19 +205,21 @@ sessionDepsArePickedUp :: TestTree sessionDepsArePickedUp = testSession' "session-deps-are-picked-up" $ \dir -> do - liftIO $ - writeFileUTF8 - (dir "hie.yaml") - "cradle: {direct: {arguments: []}}" -- Open without OverloadedStrings and expect an error. doc <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])] - -- Update hie.yaml to enable OverloadedStrings. liftIO $ writeFileUTF8 (dir "hie.yaml") "cradle: {direct: {arguments: [-XOverloadedStrings]}}" + -- Now no errors. + -- expectDiagnostics [("Foo.hs", [])] + expectNoMoreDiagnostics 3 + + liftIO $ + writeFileUTF8 + (dir "hie.yaml") + "cradle: {direct: {arguments: []}}" sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams [FileEvent (filePathToUri $ dir "hie.yaml") FileChangeType_Changed ] -- Send change event. @@ -226,8 +228,7 @@ sessionDepsArePickedUp = testSession' .+ #rangeLength .== Nothing .+ #text .== "\n" changeDoc doc [change] - -- Now no errors. - expectDiagnostics [("Foo.hs", [])] + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])] where fooContent = T.unlines diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 4d30df27e9..a6f8a011d0 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1769,6 +1769,7 @@ test-suite hls-core-plugin-tests CompletionTests HighlightTests ReferenceTests + CradleTests build-depends: diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 33c6d44ca1..47f367a78a 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -62,6 +62,7 @@ library Development.IDE.Graph.Internal.Profile Development.IDE.Graph.Internal.Rules Development.IDE.Graph.Internal.Types + Development.IDE.Graph.Internal.DataSize Development.IDE.Graph.KeyMap Development.IDE.Graph.KeySet Development.IDE.Graph.Rule @@ -92,6 +93,7 @@ library , transformers , unliftio , unordered-containers + , ghc-heap if flag(embed-files) cpp-options: -DFILE_EMBED diff --git a/hls-graph/src/Development/IDE/Graph/Internal/DataSize.hs b/hls-graph/src/Development/IDE/Graph/Internal/DataSize.hs new file mode 100644 index 0000000000..a8ccb61adf --- /dev/null +++ b/hls-graph/src/Development/IDE/Graph/Internal/DataSize.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +{- | + Module : GHC.DataSize + Copyright : (c) Dennis Felsing + License : 3-Clause BSD-style + Maintainer : dennis@felsin9.de + -} +module Development.IDE.Graph.Internal.DataSize ( + closureSize, + recursiveSize, + recursiveSizeNF + ) + where + +import Control.DeepSeq (NFData, ($!!)) + +import GHC.Exts +import GHC.Exts.Heap hiding (size) +import GHC.Exts.Heap.Constants (wORD_SIZE) + +import Control.Monad + +import System.Mem + +-- Inspired by Simon Marlow: +-- https://ghcmutterings.wordpress.com/2009/02/12/53/ + +-- | Calculate size of GHC objects in Bytes. Note that an object may not be +-- evaluated yet and only the size of the initial closure is returned. +closureSize :: a -> IO Word +closureSize x = do + rawWds <- getClosureRawWords x + return . fromIntegral $ length rawWds * wORD_SIZE + +-- | Calculate the recursive size of GHC objects in Bytes. Note that the actual +-- size in memory is calculated, so shared values are only counted once. +-- +-- Call with +-- @ +-- recursiveSize $! 2 +-- @ +-- to force evaluation to WHNF before calculating the size. +-- +-- Call with +-- @ +-- recursiveSize $!! \"foobar\" +-- @ +-- ($!! from Control.DeepSeq) to force full evaluation before calculating the +-- size. +-- +-- A garbage collection is performed before the size is calculated, because +-- the garbage collector would make heap walks difficult. +-- +-- This function works very quickly on small data structures, but can be slow +-- on large and complex ones. If speed is an issue it's probably possible to +-- get the exact size of a small portion of the data structure and then +-- estimate the total size from that. + +recursiveSize :: a -> IO Word +recursiveSize x = do + performGC + liftM snd $ go ([], 0) $ asBox x + where go (!vs, !acc) b@(Box y) = do + isElem <- liftM or $ mapM (areBoxesEqual b) vs + if isElem + then return (vs, acc) + else do + size <- closureSize y + closure <- getClosureData y + foldM go (b : vs, acc + size) $ allClosures closure + +-- | Calculate the recursive size of GHC objects in Bytes after calling +-- Control.DeepSeq.force on the data structure to force it into Normal Form. +-- Using this function requires that the data structure has an `NFData` +-- typeclass instance. + +recursiveSizeNF :: NFData a => a -> IO Word +recursiveSizeNF x = recursiveSize $!! x + +-- | Adapted from 'GHC.Exts.Heap.getClosureRaw' which isn't exported. +-- +-- This returns the raw words of the closure on the heap. Once back in the +-- Haskell world, the raw words that hold pointers may be outdated after a +-- garbage collector run. +getClosureRawWords :: a -> IO [Word] +getClosureRawWords x = do + case unpackClosure# x of + (# _iptr, dat, _pointers #) -> do + let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE + end = fromIntegral nelems - 1 + pure [W# (indexWordArray# dat i) | I# i <- [0.. end] ] diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs index 01a6d803fc..2bf7a5607e 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs @@ -5,8 +5,9 @@ {- HLINT ignore "Redundant bracket" -} -- a result of CPP expansion -module Development.IDE.Graph.Internal.Profile (writeProfile) where +module Development.IDE.Graph.Internal.Profile (writeProfile, collectProfileMemory) where +import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.Stats (readTVarIO) import Data.Bifunctor import qualified Data.ByteString.Lazy.Char8 as LBS @@ -23,13 +24,16 @@ import Data.Maybe import Data.Time (getCurrentTime) import Data.Time.Format.ISO8601 (iso8601Show) import Development.IDE.Graph.Internal.Database (getDirtySet) +import Development.IDE.Graph.Internal.DataSize import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Paths import Development.IDE.Graph.Internal.Types import qualified Language.Javascript.DGTable as DGTable import qualified Language.Javascript.Flot as Flot import qualified Language.Javascript.JQuery as JQuery +import ListT (toList) import Numeric.Extra (showDP) +import qualified StmContainers.Map as SMap import System.FilePath import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra (Seconds) @@ -39,6 +43,16 @@ import Data.FileEmbed import Language.Haskell.TH.Syntax (runIO) #endif +data DataBaseProfileMemory = ProfileMemory + {} + +collectProfileMemory :: ShakeDatabase -> IO DataBaseProfileMemory +collectProfileMemory (ShakeDatabase _ _ Database{databaseValues}) = do + kvss <- atomically $ (fmap . fmap) (first renderKey) $ toList $ SMap.listT databaseValues + kvs <- mapM (\(k, v)-> fmap (k, ) (recursiveSize v)) $ kvss + writeFile "profile-memory.txt" $ show kvs + pure ProfileMemory + -- | Generates an report given some build system profiling data. writeProfile :: FilePath -> Database -> IO () writeProfile out db = do diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 02e4b0819e..b4d8a02687 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -38,6 +38,7 @@ module Test.Hls PluginDescriptor, IdeState, -- * Assertion helper functions + expectNoKickDiagnostic, waitForProgressDone, waitForAllProgressDone, waitForBuildQueue, @@ -48,6 +49,7 @@ module Test.Hls getLastBuildKeys, waitForKickDone, waitForKickStart, + captureKickDiagnostics, -- * Plugin descriptor helper functions for tests PluginTestDescriptor, pluginTestRecorder, @@ -65,6 +67,7 @@ import Control.Applicative.Combinators import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Extra import Control.Exception.Safe +import Control.Lens ((^.)) import Control.Lens.Extras (is) import Control.Monad (guard, unless, void) import Control.Monad.Extra (forM) @@ -76,7 +79,7 @@ import qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) import Data.Default (def) import qualified Data.Map as M -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Proxy (Proxy (Proxy)) import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -103,11 +106,13 @@ import Ide.Logger (Doc, Logger (Logger), (<+>)) import Ide.Types import Language.LSP.Protocol.Capabilities +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types hiding (Null) import Language.LSP.Test import Prelude hiding (log) -import System.Directory (createDirectoryIfMissing, +import System.Directory (canonicalizePath, + createDirectoryIfMissing, getCurrentDirectory, getTemporaryDirectory, setCurrentDirectory) @@ -421,22 +426,26 @@ class TestRunner cont res where -- Do not clean up the temporary directory if this variable is set to anything but '0'. -- Aids debugging. cleanupTempDir <- lookupEnv "HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP" - let runTestInDir action = case cleanupTempDir of - Just val | val /= "0" -> do - (tempDir, _) <- newTempDirWithin testRoot - a <- action tempDir - logWith recorder Debug LogNoCleanup - pure a - - _ -> do - (tempDir, cleanup) <- newTempDirWithin testRoot - a <- action tempDir `finally` cleanup - logWith recorder Debug LogCleanup - pure a + let runTestInDir action = do + (tempDir', cleanup) <- newTempDirWithin testRoot + tempDir <- canonicalizePath tempDir' + case cleanupTempDir of + Just val | val /= "0" -> do + a <- action tempDir + logWith recorder Debug LogNoCleanup + pure a + + _ -> do + a <- action tempDir `finally` cleanup + logWith recorder Debug LogCleanup + pure a runTestInDir $ \tmpDir -> do logWith recorder Info $ LogTestDir tmpDir + print tmpDir + print "before" fs <- FS.materialiseVFT tmpDir tree + print "after" runSessionWithServer' plugins conf sessConf caps tmpDir (contToSessionRes fs act) contToSessionRes :: FileSystem -> cont -> Session res @@ -741,3 +750,20 @@ kick proxyMsg = do case fromJSON _params of Success x -> return x other -> error $ "Failed to parse kick/done details: " <> show other + +expectNoKickDiagnostic :: Session () +expectNoKickDiagnostic = captureKickDiagnostics >>= \case + [] -> pure () + diags -> error $ "Expected no diagnostics, but got: " <> show diags + + +captureKickDiagnostics :: Session [Diagnostic] +captureKickDiagnostics = do + _ <- skipManyTill anyMessage nonTrivialKickStart + messages <- manyTill anyMessage nonTrivialKickDone + pure $ concat $ mapMaybe diagnostics messages + where + diagnostics :: FromServerMessage' a -> Maybe [Diagnostic] + diagnostics = \msg -> case msg of + FromServerMess SMethod_TextDocumentPublishDiagnostics diags -> Just (diags ^. L.params . L.diagnostics) + _ -> Nothing diff --git a/hls-test-utils/src/Test/Hls/FileSystem.hs b/hls-test-utils/src/Test/Hls/FileSystem.hs index 1f6541e35e..a5a146e50c 100644 --- a/hls-test-utils/src/Test/Hls/FileSystem.hs +++ b/hls-test-utils/src/Test/Hls/FileSystem.hs @@ -31,6 +31,7 @@ module Test.Hls.FileSystem , simpleCabalProject' ) where +import Control.Monad.Extra (partitionM) import Data.Foldable (traverse_) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -162,11 +163,19 @@ copy fp = File fp (Ref fp) copyDir :: FilePath -> FileTree copyDir dir = CopiedDirectory dir +copyDirRecursive :: FilePath -> FilePath -> FilePath -> IO [FileTree] +copyDirRecursive previousDir root dir = do + let currentDir = root previousDir dir + let relativeDir = previousDir dir + filesOrFolders <- listDirectory currentDir + (files,folders) <- partitionM (doesFileExist . (currentDir )) filesOrFolders + let copiedFiles = fmap (copy . (relativeDir )) files + copiedDirs <- traverse (\subDir -> directory subDir <$> copyDirRecursive relativeDir root subDir) folders + return $ copiedFiles <> copiedDirs + -- | Copy a directory into a test project. copyDir' :: FilePath -> FilePath -> IO [FileTree] -copyDir' root dir = do - files <- listDirectory (root dir) - traverse (\f -> pure $ copy (dir f)) files +copyDir' = copyDirRecursive "" directory :: FilePath -> [FileTree] -> FileTree directory name nodes = Directory name nodes diff --git a/plugins/hls-core-plugin/test/CoreTest.hs b/plugins/hls-core-plugin/test/CoreTest.hs index 453d2e5e7c..2c08f5d954 100644 --- a/plugins/hls-core-plugin/test/CoreTest.hs +++ b/plugins/hls-core-plugin/test/CoreTest.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} import qualified CompletionTests +import qualified CradleTests import qualified FindDefinitionAndHoverTests import qualified HighlightTests import qualified InitializeResponseTests @@ -23,4 +24,5 @@ main = , HighlightTests.tests , FindDefinitionAndHoverTests.tests , ReferenceTests.tests + , CradleTests.tests ] diff --git a/plugins/hls-core-plugin/test/exe/CradleTests.hs b/plugins/hls-core-plugin/test/exe/CradleTests.hs new file mode 100644 index 0000000000..7799cc9c34 --- /dev/null +++ b/plugins/hls-core-plugin/test/exe/CradleTests.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module CradleTests (tests) where + +import Control.Applicative.Combinators +import Control.Monad.IO.Class (liftIO) +import Data.Row +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..)) +import Development.IDE.GHC.Util +-- import Development.IDE.Test (expectDiagnostics, +-- expectDiagnosticsWithTags, +-- expectNoMoreDiagnostics, +-- isReferenceReady, +-- waitForAction) +import Development.IDE.Types.Location +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.FilePath +import System.IO.Extra hiding (withTempDir) +-- import Test.QuickCheck.Instances () +import Control.Lens ((^.)) +import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) +import GHC.TypeLits (symbolVal) +import System.Directory (getCurrentDirectory) +import Test.Hls (captureKickDiagnostics, + expectNoKickDiagnostic, + waitForAction, + waitForAllProgressDone) +import qualified Test.Hls.FileSystem as FS +import Test.Hls.FileSystem (file, text, toAbsFp) +import Test.Hls.Util (knownBrokenForGhcVersions) +import Test.Tasty +import Test.Tasty.HUnit +import Util (checkDefs, expectDiagnostics, + expectDiagnosticsWithTags, + isReferenceReady, mkFs, mkL, + runSessionWithCorePluginNoVsf, + runSessionWithServerCorePlugin, + testSessionWithCorePlugin, + testSessionWithCorePluginEmptyVsf, + testSessionWithCorePluginSubDir) + + +tests :: TestTree +tests = testGroup "cradle" + [testGroup "dependencies" [sessionDepsArePickedUp] + ,testGroup "ignore-fatal" [ignoreFatalWarning] + ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] + ,testGroup "multi" (multiTests "multi") + ,knownBrokenForGhcVersions [GHC92] "multiple units not supported on 9.2" + $ testGroup "multi-unit" (multiTests "multi-unit") + ,testGroup "sub-directory" [simpleSubDirectoryTest] + ,knownBrokenForGhcVersions [GHC92] "multiple units not supported on 9.2" + $ testGroup "multi-unit-rexport" [multiRexportTest] + ] + +loadCradleOnlyonce :: TestTree +loadCradleOnlyonce = testGroup "load cradle only once" + [ testSessionWithCorePluginEmptyVsf "implicit" test + , testSessionWithCorePlugin "direct" (mkFs [FS.directCradle ["B.hs", "A.hs"]]) test + ] + where + test = do + doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo" + msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 1 + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ "module B where\nimport Data.Maybe"] + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 0 + _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar" + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 0 + +retryFailedCradle :: TestTree +retryFailedCradle = testSessionWithCorePluginEmptyVsf "retry failed" $ \fs -> do + -- The false cradle always fails + let hieContents = "cradle: {bios: {shell: \"false\"}}" + hiePath = "hie.yaml" + liftIO $ writeFile hiePath hieContents + let aPath = "A.hs" + doc <- createDoc aPath "haskell" "main = return ()" + WaitForIdeRuleResult {..} <- handleEither (waitForAction "TypeCheck" doc) + liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess + + -- Fix the cradle and typecheck again + let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}" + liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams + [FileEvent (filePathToUri $ toAbsFp fs "hie.yaml") FileChangeType_Changed ] + + WaitForIdeRuleResult {..} <- handleEither (waitForAction "TypeCheck" doc) + liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess + +handleEither :: Session (Either ResponseError b) -> Session b +handleEither sei = do + ei <- sei + case ei of + Left e -> liftIO $ assertFailure $ show e + Right x -> pure x + +cradleLoadedMessage :: Session FromServerMessage +cradleLoadedMessage = satisfy $ \case + FromServerMess (SMethod_CustomMethod p) (NotMess _) -> symbolVal p == cradleLoadedMethod + _ -> False + +cradleLoadedMethod :: String +cradleLoadedMethod = "ghcide/cradle/loaded" + +ignoreFatalWarning :: TestTree +ignoreFatalWarning = testSessionWithCorePluginSubDir "ignore-fatal-warning" "ignore-fatal" $ do + _ <- openDoc "IgnoreFatal.hs" "haskell" + diags <- captureKickDiagnostics + liftIO $ assertBool "Expecting no warning" $ null diags + + +simpleSubDirectoryTest :: TestTree +simpleSubDirectoryTest = + testSessionWithCorePluginSubDir "simple-subdirectory" "cabal-exe" $ do + let mainPath = "a/src/Main.hs" + _mdoc <- openDoc mainPath "haskell" + waitForAllProgressDone + expectDiagnosticsWithTags + [("a/src/Main.hs", [(DiagnosticSeverity_Warning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded + ] + +multiTests :: FilePath -> [TestTree] +multiTests dir = + [simpleMultiTest dir, simpleMultiTest2 dir, simpleMultiTest3 dir, simpleMultiDefTest dir] + +multiTestName :: FilePath -> String -> String +multiTestName dir name = "simple-" ++ dir ++ "-" ++ name + +simpleMultiTest :: FilePath -> TestTree +simpleMultiTest variant = testSessionWithCorePluginSubDir (multiTestName variant "test") variant $ do + let aPath = "a/A.hs" + bPath = "b/B.hs" + adoc <- openDoc aPath "haskell" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {..} <- handleEither $ waitForAction "TypeCheck" adoc + liftIO $ assertBool "A should typecheck" ideResultSuccess + WaitForIdeRuleResult {..} <- handleEither $ waitForAction "TypeCheck" bdoc + liftIO $ assertBool "B should typecheck" ideResultSuccess + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL (adoc ^. L.uri) 2 0 2 3 + checkDefs locs (pure [fooL]) + -- diags <- captureKickDiagnostics + -- liftIO $ assertBool "Expecting no warning" $ null diags + +-- Like simpleMultiTest but open the files in the other order +simpleMultiTest2 :: FilePath -> TestTree +simpleMultiTest2 variant = testSessionWithCorePluginSubDir (multiTestName variant "test2") variant $ \fs -> do + let aPath = "a/A.hs" + bPath = "b/B.hs" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {} <- handleEither $ waitForAction "TypeCheck" bdoc + TextDocumentIdentifier auri <- openDoc aPath "haskell" + skipManyTill anyMessage $ isReferenceReady (toAbsFp fs aPath) + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL auri 2 0 2 3 + checkDefs locs (pure [fooL]) + -- diags <- captureKickDiagnostics + -- liftIO $ assertBool "Expecting no warning" $ null diags + +-- Now with 3 components +simpleMultiTest3 :: FilePath -> TestTree +simpleMultiTest3 variant = + testSessionWithCorePluginSubDir (multiTestName variant "test3") variant $ \fs -> do + let aPath = "a/A.hs" + bPath = "b/B.hs" + cPath = "c/C.hs" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {} <- handleEither $ waitForAction "TypeCheck" bdoc + TextDocumentIdentifier auri <- openDoc aPath "haskell" + skipManyTill anyMessage $ isReferenceReady (toAbsFp fs aPath) + cdoc <- openDoc cPath "haskell" + WaitForIdeRuleResult {} <- handleEither $ waitForAction "TypeCheck" cdoc + locs <- getDefinitions cdoc (Position 2 7) + let fooL = mkL auri 2 0 2 3 + checkDefs locs (pure [fooL]) + -- diags <- captureKickDiagnostics + -- liftIO $ assertBool "Expecting no warning" $ null diags + + +-- Like simpleMultiTest but open the files in component 'a' in a separate session +simpleMultiDefTest :: FilePath -> TestTree +simpleMultiDefTest variant = testSessionWithCorePluginSubDir (multiTestName variant "def-test") variant $ \fs -> do + let aPath = "a/A.hs" + bPath = "b/B.hs" + aAbsPath = toAbsFp fs aPath + rootAbs = toAbsFp fs "" + adoc <- liftIO $ runSessionWithServerCorePlugin rootAbs $ do + adoc <- openDoc aAbsPath "haskell" + -- skipManyTill anyMessage $ isReferenceReady $ aAbsPath + -- closeDoc adoc + pure adoc + bdoc <- openDoc bPath "haskell" + -- locs <- getDefinitions bdoc (Position 2 7) + -- let fooL = mkL (adoc ^. L.uri) 2 0 2 3 + -- checkDefs locs (pure [fooL]) + -- diags <- captureKickDiagnostics + -- liftIO $ assertBool "Expecting no warning" $ null diags + return () + +multiRexportTest :: TestTree +multiRexportTest = + testSessionWithCorePluginSubDir "multi-unit-reexport-test" "multi-unit-reexport" $ do + let cPath = "c/C.hs" + cdoc <- openDoc cPath "haskell" + WaitForIdeRuleResult {} <- handleEither $ waitForAction "TypeCheck" cdoc + locs <- getDefinitions cdoc (Position 3 7) + let aPath = "a/A.hs" + let fooL = mkL (filePathToUri aPath) 2 0 2 3 + checkDefs locs (pure [fooL]) + -- diags <- captureKickDiagnostics + -- liftIO $ assertBool "Expecting no warning" $ null diags + +sessionDepsArePickedUp :: TestTree +sessionDepsArePickedUp = testSessionWithCorePlugin + "session-deps-are-picked-up" (mkFs [file "Foo.hs" (text fooContent) , file "hie.yaml" (text "cradle: {direct: {arguments: [-XOverloadedStrings]}}")]) + $ \fs -> do + doc <- openDoc "Foo.hs" "haskell" + expectNoKickDiagnostic + cwd <- liftIO getCurrentDirectory + liftIO $ + writeFileUTF8 + "hie.yaml" + "cradle: {direct: {arguments: []}}" + liftIO $ (filePathToUri $ cwd "hie.yaml") @?= (filePathToUri $ toAbsFp fs "hie.yaml") + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams [FileEvent (filePathToUri $ cwd "hie.yaml") FileChangeType_Changed] + -- Send change event. + let change = + TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 4 0) (Position 4 0) + .+ #rangeLength .== Nothing + .+ #text .== "\n" + changeDoc doc [change] + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])] + return () + + where + fooContent2 = + unlines + [ "module Foo where", + "import Data.Text", + "foo :: Text", + "", + "foo = \"hello\"", + "x=1" + ] + + fooContent = + T.unlines + [ "module Foo where", + "import Data.Text", + "foo :: Text", + "foo = \"hello\"" + ] diff --git a/plugins/hls-core-plugin/test/exe/Util.hs b/plugins/hls-core-plugin/test/exe/Util.hs index b7224b1942..2407df834f 100644 --- a/plugins/hls-core-plugin/test/exe/Util.hs +++ b/plugins/hls-core-plugin/test/exe/Util.hs @@ -4,46 +4,65 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Avoid restricted function" #-} +{-# LANGUAGE DataKinds #-} module Util where -import Control.Monad (void) +import Control.Applicative ((<|>)) +import Control.Arrow (Arrow (..)) +import Control.Lens (_1, traverseOf, (^.)) +import Control.Monad (unless, void, (>=>)) import Control.Monad.IO.Class (MonadIO (..)) import qualified Data.Aeson as A +import Data.Data (Proxy (..)) import Data.Default (Default (..)) import Data.Foldable (traverse_) +import qualified Data.Map as Map import Data.Maybe (fromJust) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text as Text import Debug.Trace (traceShow) import Development.IDE (GhcVersion, ghcVersion) +import Development.IDE.Plugin.Test (TestRequest (..)) +import GHC.Stack (HasCallStack) import GHC.TypeLits (symbolVal) import qualified Ide.Plugin.Core as Core import Ide.Types (Config (..)) +import Language.LSP.Protocol.Lens (HasRange (..), HasStart (..), + HasTags (..)) +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types (Definition (..), - DefinitionLink (..), + DefinitionLink (..), Diagnostic, + DiagnosticSeverity, DiagnosticTag, Location (..), LocationLink (..), Null (..), Position (..), Range (..), UInt, Uri (..), filePathToUri, mkRange, + toNormalizedUri, type (|?) (InL, InR), uriToFilePath) -import Language.LSP.Test (Session) +import Language.LSP.Test (Session, sendRequest) +import qualified Language.LSP.Test as LspTest import System.Directory.Extra (canonicalizePath) -import System.FilePath (()) +import System.FilePath (equalFilePath, ()) import System.Info.Extra +import System.Time.Extra (Seconds, sleep) import Test.Hls (FromServerMessage' (..), + Method (Method_TextDocumentPublishDiagnostics), + NormalizedUri, PluginTestDescriptor, SMethod (..), TCustomMessage (..), TNotificationMessage (..), - TestName, TestRunner, TestTree, - assertBool, expectFailBecause, + TServerMessage, TestName, + TestRunner, TestTree, assertBool, + expectFailBecause, getDocUri, ignoreTestBecause, mkPluginTestDescriptor, + runSessionWithServer, runSessionWithServerInTmpDir, satisfyMaybe, setConfigSection, - testCase) + skipManyTill, testCase) import qualified Test.Hls.FileSystem as FS import Test.Hls.FileSystem (copy, file, text) import Test.Tasty.HUnit (Assertion, assertFailure, (@=?), @@ -56,9 +75,21 @@ pattern R x y x' y' = Range (Position x y) (Position x' y') testSessionWithCorePlugin ::(TestRunner cont ()) => TestName -> FS.VirtualFileTree -> cont -> TestTree testSessionWithCorePlugin caseName vfs = testCase caseName . runSessionWithCorePlugin vfs +testSessionWithCorePluginEmptyVsf ::(TestRunner cont ()) => TestName -> cont -> TestTree +testSessionWithCorePluginEmptyVsf caseName = testSessionWithCorePlugin caseName (mkFs []) + +runSessionWithCorePluginNoVsf :: Session a -> IO a +runSessionWithCorePluginNoVsf = runSessionWithCorePlugin (mkFs []) + +testSessionWithCorePluginSubDir ::(TestRunner cont ()) => TestName -> FilePath -> cont -> TestTree +testSessionWithCorePluginSubDir caseName dir = testSessionWithCorePlugin caseName (mkFs [FS.copyDir dir]) + runSessionWithCorePlugin :: (TestRunner cont res) => FS.VirtualFileTree -> cont -> IO res runSessionWithCorePlugin = runSessionWithServerInTmpDir def corePlugin +runSessionWithServerCorePlugin :: FilePath -> Session a -> IO a +runSessionWithServerCorePlugin = runSessionWithServer def corePlugin + runSessionWithCorePluginEmpty :: [Text] -> Session a -> IO a runSessionWithCorePluginEmpty fps = runSessionWithCorePlugin (mkFs [FS.directCradle fps]) @@ -184,3 +215,156 @@ referenceReady pred = satisfyMaybe $ \case , symbolVal p == "ghcide/reference/ready" -> traceShow ("referenceReady", fp) $ Just fp _ -> Nothing + +-- | Pattern match a message from ghcide indicating that a file has been indexed +isReferenceReady :: FilePath -> Session () +isReferenceReady p = void $ referenceReady (equalFilePath p) + +-- |wait for @timeout@ seconds and report an assertion failure +-- if any diagnostic messages arrive in that period +-- expectNoMoreDiagnostics :: (HasCallStack) => Seconds -> Session () +-- expectNoMoreDiagnostics timeout = +-- expectMessages SMethod_TextDocumentPublishDiagnostics timeout $ \diagsNot -> do +-- let fileUri = diagsNot ^. L.params . L.uri +-- actual = diagsNot ^. L.params . L.diagnostics +-- unless (actual == []) $ liftIO $ +-- assertFailure $ +-- "Got unexpected diagnostics for " <> show fileUri +-- <> " got " +-- <> show actual + +expectMessages :: SMethod m -> Seconds -> (TServerMessage m -> Session ()) -> Session () +expectMessages m timeout handle = do + -- Give any further diagnostic messages time to arrive. + liftIO $ sleep timeout + -- Send a dummy message to provoke a response from the server. + -- This guarantees that we have at least one message to + -- process, so message won't block or timeout. + let cm = SMethod_CustomMethod (Proxy @"test") + i <- sendRequest cm $ A.toJSON GetShakeSessionQueueCount + go cm i + where + go cm i = handleMessages + where + handleMessages = (LspTest.message m >>= handle) <|> (void $ LspTest.responseForId cm i) <|> ignoreOthers + ignoreOthers = void LspTest.anyMessage >> handleMessages + +type Cursor = (UInt, UInt) +-- | It is not possible to use 'expectDiagnostics []' to assert the absence of diagnostics, +-- only that existing diagnostics have been cleared. +-- +-- Rather than trying to assert the absence of diagnostics, introduce an +-- expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic. +expectDiagnostics :: (HasCallStack) => [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session () +expectDiagnostics = expectDiagnosticsWithTags . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) + +unwrapDiagnostic :: TServerMessage Method_TextDocumentPublishDiagnostics -> (Uri, [Diagnostic]) +unwrapDiagnostic diagsNot = (diagsNot^. L.params . L.uri, diagsNot^. L.params . L.diagnostics) +expectDiagnosticsWithTags :: HasCallStack => [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () +expectDiagnosticsWithTags expected = do + let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri + next = unwrapDiagnostic <$> skipManyTill LspTest.anyMessage diagnostic + expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) f expected + expectDiagnosticsWithTags' next expected' + +diagnostic :: Session (TNotificationMessage Method_TextDocumentPublishDiagnostics) +diagnostic = LspTest.message SMethod_TextDocumentPublishDiagnostics + +expectDiagnosticsWithTags' :: + (HasCallStack, MonadIO m) => + m (Uri, [Diagnostic]) -> + Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] -> + m () +expectDiagnosticsWithTags' next m | null m = do + (_,actual) <- next + case actual of + [] -> + return () + _ -> + liftIO $ assertFailure $ "Got unexpected diagnostics:" <> show actual + +expectDiagnosticsWithTags' next expected = go expected + where + go m + | Map.null m = pure () + | otherwise = do + (fileUri, actual) <- next + canonUri <- liftIO $ toNormalizedUri <$> canonicalizeUri fileUri + case Map.lookup canonUri m of + Nothing -> do + liftIO $ + assertFailure $ + "Got diagnostics for " <> show fileUri + <> " but only expected diagnostics for " + <> show (Map.keys m) + <> " got " + <> show actual + Just expected -> do + liftIO $ mapM_ (requireDiagnosticM actual) expected + liftIO $ + unless (length expected == length actual) $ + assertFailure $ + "Incorrect number of diagnostics for " <> show fileUri + <> ", expected " + <> show expected + <> " but got " + <> show actual + go $ Map.delete canonUri m + +-- expectCurrentDiagnostics :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session () +-- expectCurrentDiagnostics doc expected = do +-- diags <- getCurrentDiagnostics doc +-- checkDiagnosticsForDoc doc expected diags + +-- checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session () +-- checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do +-- let expected' = Map.singleton nuri (map (\(ds, c, t) -> (ds, c, t, Nothing)) expected) +-- nuri = toNormalizedUri _uri +-- expectDiagnosticsWithTags' (return (_uri, obtained)) expected' + + +-- diagnostic :: Session (TNotificationMessage Method_TextDocumentPublishDiagnostics) +-- diagnostic = LspTest.message SMethod_TextDocumentPublishDiagnostics + + +requireDiagnosticM + :: (Foldable f, Show (f Diagnostic), HasCallStack) + => f Diagnostic + -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) + -> Assertion +requireDiagnosticM actuals expected = case requireDiagnostic actuals expected of + Nothing -> pure () + Just err -> assertFailure err + +type ErrorMsg = String + +cursorPosition :: Cursor -> Position +cursorPosition (line, col) = Position line col + +requireDiagnostic + :: (Foldable f, Show (f Diagnostic), HasCallStack) + => f Diagnostic + -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) + -> Maybe ErrorMsg +requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) + | any match actuals = Nothing + | otherwise = Just $ + "Could not find " <> show expected <> + " in " <> show actuals + where + match :: Diagnostic -> Bool + match d = + Just severity == d ^. L.severity + && cursorPosition cursor == d ^. range . start + && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf` + standardizeQuotes (T.toLower $ d ^. L.message) + && hasTag expectedTag (d ^. tags) + + hasTag :: Maybe DiagnosticTag -> Maybe [DiagnosticTag] -> Bool + hasTag Nothing _ = True + hasTag (Just _) Nothing = False + hasTag (Just actualTag) (Just tags) = actualTag `elem` tags + + + + diff --git a/plugins/hls-core-plugin/test/testdata/cabal-exe/a/a.cabal b/plugins/hls-core-plugin/test/testdata/cabal-exe/a/a.cabal new file mode 100644 index 0000000000..093890733b --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/cabal-exe/a/a.cabal @@ -0,0 +1,14 @@ +cabal-version: 2.2 + +name: a +version: 0.1.0.0 +author: Fendor +maintainer: power.walross@gmail.com +build-type: Simple + +executable a + main-is: Main.hs + hs-source-dirs: src + ghc-options: -Wall + build-depends: base + default-language: Haskell2010 diff --git a/plugins/hls-core-plugin/test/testdata/cabal-exe/a/src/Main.hs b/plugins/hls-core-plugin/test/testdata/cabal-exe/a/src/Main.hs new file mode 100644 index 0000000000..81d0cfb17a --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/cabal-exe/a/src/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "Hello, Haskell!" diff --git a/plugins/hls-core-plugin/test/testdata/cabal-exe/cabal.project b/plugins/hls-core-plugin/test/testdata/cabal-exe/cabal.project new file mode 100644 index 0000000000..edcac420d9 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/cabal-exe/cabal.project @@ -0,0 +1 @@ +packages: ./a \ No newline at end of file diff --git a/plugins/hls-core-plugin/test/testdata/cabal-exe/hie.yaml b/plugins/hls-core-plugin/test/testdata/cabal-exe/hie.yaml new file mode 100644 index 0000000000..5c7ab11641 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/cabal-exe/hie.yaml @@ -0,0 +1,3 @@ +cradle: + cabal: + component: "exe:a" \ No newline at end of file diff --git a/plugins/hls-core-plugin/test/testdata/ignore-change/IgnoreFatal.hs b/plugins/hls-core-plugin/test/testdata/ignore-change/IgnoreFatal.hs new file mode 100644 index 0000000000..bf468edcb1 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/ignore-change/IgnoreFatal.hs @@ -0,0 +1,5 @@ +module IgnoreFatal where +import Data.Text + +x :: Text +x = "123" diff --git a/plugins/hls-core-plugin/test/testdata/ignore-change/cabal.project b/plugins/hls-core-plugin/test/testdata/ignore-change/cabal.project new file mode 100644 index 0000000000..c6bb6fb152 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/ignore-change/cabal.project @@ -0,0 +1 @@ +packages: ignore-fatal.cabal diff --git a/plugins/hls-core-plugin/test/testdata/ignore-change/hie.yaml b/plugins/hls-core-plugin/test/testdata/ignore-change/hie.yaml new file mode 100644 index 0000000000..4dc1a80b72 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/ignore-change/hie.yaml @@ -0,0 +1,3 @@ +cradle: + direct: {arguments: [-XOverloadedStrings]} + diff --git a/plugins/hls-core-plugin/test/testdata/ignore-change/ignore-fatal.cabal b/plugins/hls-core-plugin/test/testdata/ignore-change/ignore-fatal.cabal new file mode 100644 index 0000000000..6e831e0395 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/ignore-change/ignore-fatal.cabal @@ -0,0 +1,10 @@ +name: ignore-fatal +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base + exposed-modules: IgnoreFatal + hs-source-dirs: . + ghc-options: -Werror=missing-signatures diff --git a/plugins/hls-core-plugin/test/testdata/ignore-fatal/IgnoreFatal.hs b/plugins/hls-core-plugin/test/testdata/ignore-fatal/IgnoreFatal.hs new file mode 100644 index 0000000000..77b11c5bb3 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/ignore-fatal/IgnoreFatal.hs @@ -0,0 +1,8 @@ +-- "missing signature" is declared a fatal warning in the cabal file, +-- but is ignored in this module. + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module IgnoreFatal where + +a = 'a' diff --git a/plugins/hls-core-plugin/test/testdata/ignore-fatal/cabal.project b/plugins/hls-core-plugin/test/testdata/ignore-fatal/cabal.project new file mode 100644 index 0000000000..c6bb6fb152 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/ignore-fatal/cabal.project @@ -0,0 +1 @@ +packages: ignore-fatal.cabal diff --git a/plugins/hls-core-plugin/test/testdata/ignore-fatal/hie.yaml b/plugins/hls-core-plugin/test/testdata/ignore-fatal/hie.yaml new file mode 100644 index 0000000000..6ea3cebd0d --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/ignore-fatal/hie.yaml @@ -0,0 +1,4 @@ +cradle: + cabal: + - path: "." + component: "lib:ignore-fatal" diff --git a/plugins/hls-core-plugin/test/testdata/ignore-fatal/ignore-fatal.cabal b/plugins/hls-core-plugin/test/testdata/ignore-fatal/ignore-fatal.cabal new file mode 100644 index 0000000000..6e831e0395 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/ignore-fatal/ignore-fatal.cabal @@ -0,0 +1,10 @@ +name: ignore-fatal +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base + exposed-modules: IgnoreFatal + hs-source-dirs: . + ghc-options: -Werror=missing-signatures diff --git a/plugins/hls-core-plugin/test/testdata/multi/a/A.hs b/plugins/hls-core-plugin/test/testdata/multi/a/A.hs new file mode 100644 index 0000000000..faf037ca84 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi/a/A.hs @@ -0,0 +1,3 @@ +module A(foo) where +import Control.Concurrent.Async +foo = () diff --git a/plugins/hls-core-plugin/test/testdata/multi/a/a.cabal b/plugins/hls-core-plugin/test/testdata/multi/a/a.cabal new file mode 100644 index 0000000000..d95697264d --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi/a/a.cabal @@ -0,0 +1,9 @@ +name: a +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base, async >= 2.0 + exposed-modules: A + hs-source-dirs: . diff --git a/plugins/hls-core-plugin/test/testdata/multi/b/B.hs b/plugins/hls-core-plugin/test/testdata/multi/b/B.hs new file mode 100644 index 0000000000..2c6d4b28a2 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi/b/B.hs @@ -0,0 +1,3 @@ +module B(module B) where +import A +qux = foo diff --git a/plugins/hls-core-plugin/test/testdata/multi/b/b.cabal b/plugins/hls-core-plugin/test/testdata/multi/b/b.cabal new file mode 100644 index 0000000000..e23f5177d8 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi/b/b.cabal @@ -0,0 +1,9 @@ +name: b +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base, a + exposed-modules: B + hs-source-dirs: . diff --git a/plugins/hls-core-plugin/test/testdata/multi/c/C.hs b/plugins/hls-core-plugin/test/testdata/multi/c/C.hs new file mode 100644 index 0000000000..b75a7fc3c7 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi/c/C.hs @@ -0,0 +1,3 @@ +module C(module C) where +import A +cux = foo diff --git a/plugins/hls-core-plugin/test/testdata/multi/c/c.cabal b/plugins/hls-core-plugin/test/testdata/multi/c/c.cabal new file mode 100644 index 0000000000..93ee004d94 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi/c/c.cabal @@ -0,0 +1,9 @@ +name: c +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base, a + exposed-modules: C + hs-source-dirs: . diff --git a/plugins/hls-core-plugin/test/testdata/multi/cabal.project b/plugins/hls-core-plugin/test/testdata/multi/cabal.project new file mode 100644 index 0000000000..317a89138e --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi/cabal.project @@ -0,0 +1,3 @@ +packages: a b c + +allow-newer: base diff --git a/plugins/hls-core-plugin/test/testdata/multi/hie.yaml b/plugins/hls-core-plugin/test/testdata/multi/hie.yaml new file mode 100644 index 0000000000..c6b36d012c --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi/hie.yaml @@ -0,0 +1,8 @@ +cradle: + cabal: + - path: "./a" + component: "lib:a" + - path: "./b" + component: "lib:b" + - path: "./c" + component: "lib:c" From ed8ac1330ce07db99511186922daa2fd714939c5 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 13 Apr 2024 17:15:52 +0800 Subject: [PATCH 32/34] revert ghcide --- ghcide/ghcide.cabal | 9 + .../session-loader/Development/IDE/Session.hs | 40 +- ghcide/src/Development/IDE/Core/Actions.hs | 14 + ghcide/src/Development/IDE/Core/Rules.hs | 38 +- ghcide/src/Development/IDE/Core/Shake.hs | 9 +- .../Development/IDE/LSP/HoverDefinition.hs | 76 +++ .../src/Development/IDE/LSP/LanguageServer.hs | 6 +- ghcide/src/Development/IDE/LSP/Outline.hs | 286 +++++++++ ghcide/src/Development/IDE/Main.hs | 30 +- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 27 +- ghcide/test/data/hover/Bar.hs | 4 + ghcide/test/data/hover/Foo.hs | 6 + ghcide/test/data/hover/GotoHover.hs | 70 +++ ghcide/test/data/hover/RecordDotSyntax.hs | 18 + ghcide/test/data/hover/hie.yaml | 1 + ghcide/test/exe/CompletionTests.hs | 574 ++++++++++++++++++ ghcide/test/exe/CradleTests.hs | 17 +- .../test/exe/FindDefinitionAndHoverTests.hs | 235 +++++++ ghcide/test/exe/HighlightTests.hs | 79 +++ ghcide/test/exe/InitializeResponseTests.hs | 97 +++ ghcide/test/exe/Main.hs | 12 + ghcide/test/exe/OutlineTests.hs | 189 ++++++ ghcide/test/exe/ReferenceTests.hs | 199 ++++++ 23 files changed, 1946 insertions(+), 90 deletions(-) create mode 100644 ghcide/src/Development/IDE/LSP/HoverDefinition.hs create mode 100644 ghcide/src/Development/IDE/LSP/Outline.hs create mode 100644 ghcide/test/data/hover/Bar.hs create mode 100644 ghcide/test/data/hover/Foo.hs create mode 100644 ghcide/test/data/hover/GotoHover.hs create mode 100644 ghcide/test/data/hover/RecordDotSyntax.hs create mode 100644 ghcide/test/data/hover/hie.yaml create mode 100644 ghcide/test/exe/CompletionTests.hs create mode 100644 ghcide/test/exe/FindDefinitionAndHoverTests.hs create mode 100644 ghcide/test/exe/HighlightTests.hs create mode 100644 ghcide/test/exe/InitializeResponseTests.hs create mode 100644 ghcide/test/exe/OutlineTests.hs create mode 100644 ghcide/test/exe/ReferenceTests.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 61be7745f5..16aeaa06de 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -164,8 +164,10 @@ library Development.IDE.GHC.Util Development.IDE.Import.DependencyInformation Development.IDE.Import.FindImports + Development.IDE.LSP.HoverDefinition Development.IDE.LSP.LanguageServer Development.IDE.LSP.Notifications + Development.IDE.LSP.Outline Development.IDE.LSP.Server Development.IDE.Main Development.IDE.Main.HeapStats @@ -356,22 +358,29 @@ test-suite ghcide-tests BootTests ClientSettingsTests CodeLensTests + CompletionTests CPPTests + CradleTests DependentFileTest DiagnosticTests ExceptionTests + FindDefinitionAndHoverTests FuzzySearch GarbageCollectionTests HaddockTests HieDbRetry + HighlightTests IfaceTests + InitializeResponseTests LogType NonLspCommandLine OpenCloseTest + OutlineTests PluginSimpleTests PositionMappingTests PreprocessorTests Progress + ReferenceTests RootUriTests SafeTests SymlinkTests diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index f614c99e44..48af221f9b 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -585,21 +585,9 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv all_target_details <- new_cache old_deps new_deps - this_dep_info <- getDependencyInfo $ maybeToList hieYaml - let (all_targets, this_flags_map, this_options) - = case HM.lookup _cfp flags_map' of - Just this -> (all_targets', flags_map', this) - Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags) - where all_targets' = concat all_target_details - flags_map' = HM.fromList (concatMap toFlagsMap all_targets') - this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp] - this_flags = (this_error_env, this_dep_info) - this_error_env = ([this_error], Nothing) - this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp - $ T.unlines - [ "No cradle target found. Is this file listed in the targets of your cradle?" - , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" - ] + let all_targets = concatMap fst all_target_details + + let this_flags_map = HM.fromList (concatMap toFlagsMap all_targets) void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map @@ -627,7 +615,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) - return $ second Map.keys this_options + return $ second Map.keys $ this_flags_map HM.! _cfp let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do @@ -647,7 +635,6 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- Display a user friendly progress message here: They probably don't know what a cradle is let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfp <> ")" - mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/eopts/before")) (toJSON cfp) eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do addTag "file" lfp @@ -655,9 +642,8 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do res <- cradleToOptsAndLibDir recorder cradle cfp old_files addTag "result" (show res) return res - mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/eopts/after")) (toJSON cfp) + logWith recorder Debug $ LogSessionLoadingResult eopts - mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/eopts/afterLog")) (toJSON (show $ pretty (LogSessionLoadingResult eopts))) case eopts of -- The cradle gave us some options so get to work turning them -- into and HscEnv. @@ -824,7 +810,7 @@ newComponentCache -> HscEnv -- ^ An empty HscEnv -> [ComponentInfo] -- ^ New components to be loaded -> [ComponentInfo] -- ^ old, already existing components - -> IO [ [TargetDetails] ] + -> IO [ ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))] newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis) -- When we have multiple components with the same uid, @@ -896,13 +882,14 @@ newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do henv <- createHscEnvEq thisEnv (zip uids dfs) let targetEnv = (if isBad ci then multi_errs else [], Just henv) targetDepends = componentDependencyInfo ci - logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends) + res = ( targetEnv, targetDepends) + logWith recorder Debug $ LogNewComponentCache res evaluate $ liftRnf rwhnf $ componentTargets ci let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends ctargets <- concatMapM mk (componentTargets ci) - return (L.nubOrdOn targetTarget ctargets) + return (L.nubOrdOn targetTarget ctargets, res) {- Note [Avoiding bad interface files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1094,10 +1081,8 @@ setOptions cfp (ComponentOptions theOpts compRoot _) dflags = do -- A special target for the file which caused this wonderful -- component to be created. In case the cradle doesn't list all the targets for -- the component, in which case things will be horribly broken anyway. - -- - -- When we have a single component that is caused to be loaded due to a - -- file, we assume the file is part of that component. This is useful - -- for bare GHC sessions, such as many of the ones used in the testsuite + -- Otherwise, we will immediately attempt to reload this module which + -- causes an infinite loop and high CPU usage. -- -- We don't do this when we have multiple components, because each -- component better list all targets or there will be anarchy. @@ -1105,9 +1090,6 @@ setOptions cfp (ComponentOptions theOpts compRoot _) dflags = do -- that case. -- Multi unit arguments are likely to come from cabal, which -- does list all targets. - -- - -- If we don't end up with a target for the current file in the end, then - -- we will report it as an error for that file abs_fp <- liftIO $ makeAbsolute (fromNormalizedFilePath cfp) let special_target = Compat.mkSimpleTarget df abs_fp pure $ (df, special_target : targets) :| [] diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index a3045301b9..4c808f21d9 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -4,6 +4,8 @@ module Development.IDE.Core.Actions , getDefinition , getTypeDefinition , highlightAtPoint +, refsAtPoint +, workspaceSymbols , lookupMod ) where @@ -122,4 +124,16 @@ highlightAtPoint file pos = runMaybeT $ do let toCurrentHighlight (DocumentHighlight range t) = flip DocumentHighlight t <$> toCurrentRange mapping range mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos' +-- Refs are not an IDE action, so it is OK to be slow and (more) accurate +refsAtPoint :: NormalizedFilePath -> Position -> Action [Location] +refsAtPoint file pos = do + ShakeExtras{withHieDb} <- getShakeExtras + fs <- HM.keys <$> getFilesOfInterestUntracked + asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst fs + AtPoint.referencesAtPoint withHieDb file pos (AtPoint.FOIReferences asts) +workspaceSymbols :: T.Text -> IdeAction (Maybe [SymbolInformation]) +workspaceSymbols query = runMaybeT $ do + ShakeExtras{withHieDb} <- ask + res <- liftIO $ withHieDb (\hieDb -> HieDb.searchDef hieDb $ T.unpack query) + pure $ mapMaybe AtPoint.defRowToSymbolInfo res diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index cde58a2d8a..0f4430e6af 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -11,8 +11,11 @@ module Development.IDE.Core.Rules( -- * Types IdeState, GetParsedModule(..), TransitiveDependencies(..), - GhcSessionIO(..), GetClientSettings(..), + Priority(..), GhcSessionIO(..), GetClientSettings(..), -- * Functions + priorityTypeCheck, + priorityGenerateCore, + priorityFilesOfInterest, runAction, toIdeResult, defineNoFile, @@ -162,7 +165,6 @@ import Language.LSP.Protocol.Types (MessageType (Mess ShowMessageParams (ShowMessageParams)) import Language.LSP.Server (LspT) import qualified Language.LSP.Server as LSP -import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.VFS import Prelude hiding (mod) import System.Directory (doesFileExist, @@ -171,7 +173,6 @@ import System.Info.Extra (isWindows) import GHC.Fingerprint -import qualified Development.IDE.Session as Session -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] @@ -181,14 +182,12 @@ import GHC (mgModSummaries) #if MIN_VERSION_ghc(9,3,0) import qualified Data.IntMap as IM -import Data.Row (KnownSymbol) #endif data Log = LogShake Shake.Log - | LogSession Session.Log | LogReindexingHieFile !NormalizedFilePath | LogLoadingHieFile !NormalizedFilePath | LogLoadingHieFileFail !FilePath !SomeException @@ -218,7 +217,6 @@ instance Pretty Log where <+> "the HLS version being used, the plugins enabled, and if possible the codebase and file which" <+> "triggered this warning." ] - LogSession msg -> pretty msg templateHaskellInstructions :: T.Text templateHaskellInstructions = "https://haskell-language-server.readthedocs.io/en/latest/troubleshooting.html#static-binaries" @@ -252,6 +250,15 @@ getParsedModuleWithComments = use GetParsedModuleWithComments -- Rules -- These typically go from key to value and are oracles. +priorityTypeCheck :: Priority +priorityTypeCheck = Priority 0 + +priorityGenerateCore :: Priority +priorityGenerateCore = Priority (-1) + +priorityFilesOfInterest :: Priority +priorityFilesOfInterest = Priority (-2) + -- | WARNING: -- We currently parse the module both with and without Opt_Haddock, and -- return the one with Haddocks if it -- succeeds. However, this may not work @@ -675,6 +682,7 @@ typeCheckRuleDefinition -> ParsedModule -> Action (IdeResult TcModuleResult) typeCheckRuleDefinition hsc pm = do + setPriority priorityTypeCheck IdeOptions { optDefer = defer } <- getIdeOptions unlift <- askUnliftIO @@ -712,24 +720,8 @@ loadGhcSession recorder ghcSessionDepsConfig = do return (fingerprint, res) defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do - -- todo add signal - ShakeExtras{exportsMap, ideTesting = IdeTesting testing, lspEnv, progress} <- getShakeExtras - let - signal' :: KnownSymbol s => Proxy s -> String -> Action () - signal' msg str = when testing $ liftIO $ - mRunLspT lspEnv $ - LSP.sendNotification (LSP.SMethod_CustomMethod msg) $ - toJSON $ [str] - signal :: KnownSymbol s => Proxy s -> Action () - signal msg = signal' msg (show file) - - - - signal (Proxy @"GhcSession/start") IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO - signal (Proxy @"GhcSession/loadSessionFun/before") (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file - signal (Proxy @"GhcSession/loadSessionFun/after") -- add the deps to the Shake graph let addDependency fp = do @@ -742,7 +734,6 @@ loadGhcSession recorder ghcSessionDepsConfig = do mapM_ addDependency deps let cutoffHash = LBS.toStrict $ B.encode (hash (snd val)) - signal (Proxy @"GhcSession/done") return (Just cutoffHash, val) defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \(GhcSessionDeps_ fullModSummary) file -> do @@ -945,6 +936,7 @@ generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts generateCore runSimplifier file = do packageState <- hscEnv <$> use_ GhcSessionDeps file tm <- use_ TypeCheck file + setPriority priorityGenerateCore liftIO $ compileModule runSimplifier packageState (tmrModSummary tm) (tmrTypechecked tm) generateCoreRule :: Recorder (WithPriority Log) -> Rules () diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 9ceabb20cf..2791dcfc2d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -51,10 +51,12 @@ module Development.IDE.Core.Shake( HLS.getClientConfig, getPluginConfigAction, knownTargets, + setPriority, ideLogger, actionLogger, getVirtualFile, FileVersion(..), + Priority(..), updatePositionMapping, updatePositionMappingHelper, deleteValue, recordDirtyKeys, @@ -137,7 +139,6 @@ import Development.IDE.Graph.Database (ShakeDatabase, shakeNewDatabase, shakeProfileDatabase, shakeRunDatabaseForKeys) -import Development.IDE.Graph.Internal.Profile (collectProfileMemory) import Development.IDE.Graph.Rule import Development.IDE.Types.Action import Development.IDE.Types.Diagnostics @@ -717,7 +718,6 @@ shakeShut IdeState{..} = do -- request so we first abort that. for_ runner cancelShakeSession void $ shakeDatabaseProfile shakeDb - void $ collectProfileMemory shakeDb progressStop $ progress shakeExtras stopMonitoring @@ -1307,6 +1307,11 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti | otherwise = c +newtype Priority = Priority Double + +setPriority :: Priority -> Action () +setPriority (Priority p) = reschedule p + ideLogger :: IdeState -> Logger ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs new file mode 100644 index 0000000000..1aa531293e --- /dev/null +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -0,0 +1,76 @@ +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE GADTs #-} + +-- | Display information on hover. +module Development.IDE.LSP.HoverDefinition + ( + -- * For haskell-language-server + hover + , gotoDefinition + , gotoTypeDefinition + , documentHighlight + , references + -- , wsSymbols + ) where + +import Control.Monad.Except (ExceptT) +import Control.Monad.IO.Class +import Data.Maybe (fromMaybe) +import Development.IDE.Core.Actions +import Development.IDE.Core.Rules +import Development.IDE.Core.Shake +import Development.IDE.Types.Location +import Ide.Logger +import Ide.Plugin.Error +import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import qualified Language.LSP.Server as LSP + +import qualified Data.Text as T + +gotoDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentDefinition) +hover :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (Hover |? Null) +gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentTypeDefinition) +documentHighlight :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) ([DocumentHighlight] |? Null) +gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR) +gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR) +hover = request "Hover" getAtPoint (InR Null) foundHover +documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL + +references :: PluginMethodHandler IdeState Method_TextDocumentReferences +references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do + nfp <- getNormalizedFilePathE uri + liftIO $ logDebug (ideLogger ide) $ + "References request at position " <> T.pack (showPosition pos) <> + " in file: " <> T.pack (show nfp) + InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos) + + +foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null +foundHover (mbRange, contents) = + InL $ Hover (InL $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator contents) mbRange + +-- | Respond to and log a hover or go-to-definition request +request + :: T.Text + -> (NormalizedFilePath -> Position -> IdeAction (Maybe a)) + -> b + -> (a -> b) + -> IdeState + -> TextDocumentPositionParams + -> ExceptT PluginError (LSP.LspM c) b +request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do + mbResult <- case uriToFilePath' uri of + Just path -> logAndRunRequest label getResults ide pos path + Nothing -> pure Nothing + pure $ maybe notFound found mbResult + +logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b +logAndRunRequest label getResults ide pos path = do + let filePath = toNormalizedFilePath' path + logDebug (ideLogger ide) $ + label <> " request at position " <> T.pack (showPosition pos) <> + " in file: " <> T.pack path + runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index c45b1ef23e..5663165f02 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -128,12 +128,14 @@ setupLSP :: -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> LSP.Handlers (ServerM config) -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) - -> Chan ReactorMessage -> MVar () -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), LSP.Handlers (ServerM config), (LanguageContextEnv config, IdeState) -> ServerM config <~> IO) -setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgChan clientMsgVar = do +setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do + -- Send everything over a channel, since you need to wait until after initialise before + -- LspFuncs is available + clientMsgChan :: Chan ReactorMessage <- newChan -- An MVar to control the lifetime of the reactor loop. -- The loop will be stopped and resources freed when it's full diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs new file mode 100644 index 0000000000..4f350b52d0 --- /dev/null +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE CPP #-} + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} + +module Development.IDE.LSP.Outline + ( moduleOutline + ) +where + +import Control.Monad.IO.Class +import Data.Functor +import Data.Generics hiding (Prefix) +import Data.Maybe +import Development.IDE.Core.Rules +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Error (rangeToRealSrcSpan, + realSrcSpanToRange) +import Development.IDE.Types.Location +import Development.IDE.GHC.Util (printOutputable) +import Ide.Types +import Language.LSP.Protocol.Types (DocumentSymbol (..), + DocumentSymbolParams (DocumentSymbolParams, _textDocument), + SymbolKind (..), + TextDocumentIdentifier (TextDocumentIdentifier), + type (|?) (InL, InR), uriToFilePath) +import Language.LSP.Protocol.Message + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +import Data.List.NonEmpty (nonEmpty) +import Data.Foldable (toList) + +#if !MIN_VERSION_ghc(9,3,0) +import qualified Data.Text as T +#endif + +moduleOutline + :: PluginMethodHandler IdeState Method_TextDocumentDocumentSymbol +moduleOutline ideState _ DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } + = liftIO $ case uriToFilePath uri of + Just (toNormalizedFilePath' -> fp) -> do + mb_decls <- fmap fst <$> runAction "Outline" ideState (useWithStale GetParsedModule fp) + pure $ case mb_decls of + Nothing -> InL [] + Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } } + -> let + declSymbols = mapMaybe documentSymbolForDecl hsmodDecls + moduleSymbol = hsmodName >>= \case + (L (locA -> (RealSrcSpan l _)) m) -> Just $ + (defDocumentSymbol l :: DocumentSymbol) + { _name = printOutputable m + , _kind = SymbolKind_File + , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0 + } + _ -> Nothing + importSymbols = maybe [] pure $ + documentSymbolForImportSummary + (mapMaybe documentSymbolForImport hsmodImports) + allSymbols = case moduleSymbol of + Nothing -> importSymbols <> declSymbols + Just x -> + [ x { _children = Just (importSymbols <> declSymbols) + } + ] + in + InR (InL allSymbols) + + + Nothing -> pure $ InL [] + +documentSymbolForDecl :: LHsDecl GhcPs -> Maybe DocumentSymbol +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) + = Just (defDocumentSymbol l :: DocumentSymbol) + { _name = printOutputable n + <> (case printOutputable fdTyVars of + "" -> "" + t -> " " <> t + ) + , _detail = Just $ printOutputable fdInfo + , _kind = SymbolKind_Function + } +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) + = Just (defDocumentSymbol l :: DocumentSymbol) + { _name = printOutputable name + <> (case printOutputable tcdTyVars of + "" -> "" + t -> " " <> t + ) + , _kind = SymbolKind_Interface + , _detail = Just "class" + , _children = + Just $ + [ (defDocumentSymbol l' :: DocumentSymbol) + { _name = printOutputable n + , _kind = SymbolKind_Method + , _selectionRange = realSrcSpanToRange l'' + } + | L (locA -> (RealSrcSpan l' _)) (ClassOpSig _ False names _) <- tcdSigs + , L (locA -> (RealSrcSpan l'' _)) n <- names + ] + } +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) + = Just (defDocumentSymbol l :: DocumentSymbol) + { _name = printOutputable name + , _kind = SymbolKind_Struct + , _children = + Just $ + [ (defDocumentSymbol l'' :: DocumentSymbol) + { _name = printOutputable n + , _kind = SymbolKind_Constructor + , _selectionRange = realSrcSpanToRange l' + , _children = toList <$> nonEmpty childs + } + | con <- extract_cons dd_cons + , let (cs, flds) = hsConDeclsBinders con + , let childs = mapMaybe cvtFld flds + , L (locA -> RealSrcSpan l' _) n <- cs + , let l'' = case con of + L (locA -> RealSrcSpan l''' _) _ -> l''' + _ -> l' + ] + } + where + cvtFld :: LFieldOcc GhcPs -> Maybe DocumentSymbol +#if MIN_VERSION_ghc(9,3,0) + cvtFld (L (locA -> RealSrcSpan l' _) n) = Just $ (defDocumentSymbol l' :: DocumentSymbol) +#else + cvtFld (L (RealSrcSpan l' _) n) = Just $ (defDocumentSymbol l' :: DocumentSymbol) +#endif +#if MIN_VERSION_ghc(9,3,0) + { _name = printOutputable (unLoc (foLabel n)) +#else + { _name = printOutputable (unLoc (rdrNameFieldOcc n)) +#endif + , _kind = SymbolKind_Field + } + cvtFld _ = Nothing +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ SynDecl { tcdLName = L (locA -> (RealSrcSpan l' _)) n })) = Just + (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable n + , _kind = SymbolKind_TypeParameter + , _selectionRange = realSrcSpanToRange l' + } +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) + = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable cid_poly_ty + , _kind = SymbolKind_Interface + } +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl FamEqn { feqn_tycon, feqn_pats } })) + = Just (defDocumentSymbol l :: DocumentSymbol) + { _name = +#if MIN_VERSION_ghc(9,3,0) + printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats) +#else + printOutputable (unLoc feqn_tycon) <> " " <> T.unwords + (map printOutputable feqn_pats) +#endif + , _kind = SymbolKind_Interface + } +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl _ FamEqn { feqn_tycon, feqn_pats } })) + = Just (defDocumentSymbol l :: DocumentSymbol) + { _name = +#if MIN_VERSION_ghc(9,3,0) + printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats) +#else + printOutputable (unLoc feqn_tycon) <> " " <> T.unwords + (map printOutputable feqn_pats) +#endif + , _kind = SymbolKind_Interface + } +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (DerivD _ DerivDecl { deriv_type })) = + gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) -> + (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable @(HsType GhcPs) + name + , _kind = SymbolKind_Interface + } +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ FunBind{fun_id = L _ name})) = Just + (defDocumentSymbol l :: DocumentSymbol) + { _name = printOutputable name + , _kind = SymbolKind_Function + } +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ PatBind{pat_lhs})) = Just + (defDocumentSymbol l :: DocumentSymbol) + { _name = printOutputable pat_lhs + , _kind = SymbolKind_Function + } + +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ForD _ x)) = Just + (defDocumentSymbol l :: DocumentSymbol) + { _name = case x of + ForeignImport{} -> name + ForeignExport{} -> name + , _kind = SymbolKind_Object + , _detail = case x of + ForeignImport{} -> Just "import" + ForeignExport{} -> Just "export" + } + where name = printOutputable $ unLoc $ fd_name x + +documentSymbolForDecl _ = Nothing + +-- | Wrap the Document imports into a hierarchical outline for +-- a better overview of symbols in scope. +-- If there are no imports, then no hierarchy will be created. +documentSymbolForImportSummary :: [DocumentSymbol] -> Maybe DocumentSymbol +documentSymbolForImportSummary [] = Nothing +documentSymbolForImportSummary importSymbols = + let + -- safe because if we have no ranges then we don't take this branch + mergeRanges xs = Range (minimum $ map _start xs) (maximum $ map _end xs) + importRange = mergeRanges $ map (\DocumentSymbol{_range} -> _range) importSymbols + in + Just (defDocumentSymbol (rangeToRealSrcSpan "" importRange)) + { _name = "imports" + , _kind = SymbolKind_Module + , _children = Just importSymbols + } + +documentSymbolForImport :: LImportDecl GhcPs -> Maybe DocumentSymbol +documentSymbolForImport (L (locA -> (RealSrcSpan l _)) ImportDecl { ideclName, ideclQualified }) = Just + (defDocumentSymbol l :: DocumentSymbol) + { _name = "import " <> printOutputable ideclName + , _kind = SymbolKind_Module + , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" } + } +documentSymbolForImport _ = Nothing + +defDocumentSymbol :: RealSrcSpan -> DocumentSymbol +defDocumentSymbol l = DocumentSymbol { .. } where + _detail = Nothing + _deprecated = Nothing + _name = "" + -- This used to be SkUnknown 0, which is invalid, as SymbolKinds start at 1, + -- therefore, I am replacing it with SymbolKind_File, which is the type for 1 + _kind = SymbolKind_File + _range = realSrcSpanToRange l + _selectionRange = realSrcSpanToRange l + _children = Nothing + _tags = Nothing + +-- the version of getConNames for ghc9 is restricted to only the renaming phase +hsConDeclsBinders :: LConDecl GhcPs + -> ([LIdP GhcPs], [LFieldOcc GhcPs]) + -- See hsLTyClDeclBinders for what this does + -- The function is boringly complicated because of the records + -- And since we only have equality, we have to be a little careful +hsConDeclsBinders cons + = go cons + where + go :: LConDecl GhcPs + -> ([LIdP GhcPs], [LFieldOcc GhcPs]) + go r + -- Don't re-mangle the location of field names, because we don't + -- have a record of the full location of the field declaration anyway + = case unLoc r of + -- remove only the first occurrence of any seen field in order to + -- avoid circumventing detection of duplicate fields (#9156) + ConDeclGADT { con_names = names, con_g_args = args } + -> (toList names, flds) + where + flds = get_flds_gadt args + + ConDeclH98 { con_name = name, con_args = args } + -> ([name], flds) + where + flds = get_flds_h98 args + + get_flds_h98 :: HsConDeclH98Details GhcPs + -> [LFieldOcc GhcPs] + get_flds_h98 (RecCon flds) = get_flds (reLoc flds) + get_flds_h98 _ = [] + + get_flds_gadt :: HsConDeclGADTDetails GhcPs + -> [LFieldOcc GhcPs] +#if MIN_VERSION_ghc(9,3,0) + get_flds_gadt (RecConGADT flds _) = get_flds (reLoc flds) +#else + get_flds_gadt (RecConGADT flds) = get_flds (reLoc flds) +#endif + get_flds_gadt _ = [] + + get_flds :: Located [LConDeclField GhcPs] + -> [LFieldOcc GhcPs] + get_flds flds = concatMap (cd_fld_names . unLoc) (unLoc flds) + + diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 2052ae05b9..a05ab88e2a 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -11,9 +11,7 @@ module Development.IDE.Main ,Log(..) ) where -import Control.Concurrent.Extra (Chan, newChan, - withNumCapabilities, - writeChan) +import Control.Concurrent.Extra (withNumCapabilities) import Control.Concurrent.MVar (newEmptyMVar, putMVar, tryReadMVar) import Control.Concurrent.STM.Stats (dumpSTMStats) @@ -65,7 +63,6 @@ import Development.IDE.Graph (action) import Development.IDE.LSP.LanguageServer (runLanguageServer, setupLSP) import qualified Development.IDE.LSP.LanguageServer as LanguageServer -import Development.IDE.LSP.Server import Development.IDE.Main.HeapStats (withHeapStats) import qualified Development.IDE.Main.HeapStats as HeapStats import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry @@ -358,26 +355,19 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re putMVar ideStateVar ide pure ide - -- Send everything over a channel, since you need to wait until after initialise before - -- LspFuncs is available - clientMsgChan :: Chan ReactorMessage <- newChan - - let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState clientMsgChan + let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState -- See Note [Client configuration in Rules] onConfigChange cfg = do -- TODO: this is nuts, we're converting back to JSON just to get a fingerprint let cfgObj = J.toJSON cfg - let configChangeIO = do - mide <- liftIO $ tryReadMVar ideStateVar - case mide of - Nothing -> pure () - Just ide -> liftIO $ do - let msg = T.pack $ show cfg - logDebug (Shake.ideLogger ide) $ "Configuration changed: " <> msg - modifyClientSettings ide (const $ Just cfgObj) - setSomethingModified Shake.VFSUnmodified ide [toKey Rules.GetClientSettings emptyFilePath] "config change" - liftIO $ writeChan clientMsgChan $ ReactorNotification configChangeIO - + mide <- liftIO $ tryReadMVar ideStateVar + case mide of + Nothing -> pure () + Just ide -> liftIO $ do + let msg = T.pack $ show cfg + logDebug (Shake.ideLogger ide) $ "Configuration changed: " <> msg + modifyClientSettings ide (const $ Just cfgObj) + setSomethingModified Shake.VFSUnmodified ide [toKey Rules.GetClientSettings emptyFilePath] "config change" runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup dumpSTMStats diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index 831747737b..bdd3ab222d 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -9,13 +9,15 @@ module Development.IDE.Plugin.HLS.GhcIde ) where import Control.Monad.IO.Class import Development.IDE -import qualified Development.IDE.LSP.Notifications as Notifications -import qualified Development.IDE.Plugin.Completions as Completions -import qualified Development.IDE.Plugin.TypeLenses as TypeLenses +import Development.IDE.LSP.HoverDefinition +import qualified Development.IDE.LSP.Notifications as Notifications +import Development.IDE.LSP.Outline +import qualified Development.IDE.Plugin.Completions as Completions +import qualified Development.IDE.Plugin.TypeLenses as TypeLenses import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import Text.Regex.TDFA.Text () +import Text.Regex.TDFA.Text () data Log = LogNotifications Notifications.Log @@ -41,9 +43,24 @@ descriptors recorder = descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId desc) - { pluginConfigDescriptor = defaultConfigDescriptor } + { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover hover' + <> mkPluginHandler SMethod_TextDocumentDocumentSymbol moduleOutline + <> mkPluginHandler SMethod_TextDocumentDefinition (\ide _ DefinitionParams{..} -> + gotoDefinition ide TextDocumentPositionParams{..}) + <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} -> + gotoTypeDefinition ide TextDocumentPositionParams{..}) + <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> + documentHighlight ide TextDocumentPositionParams{..}) + <> mkPluginHandler SMethod_TextDocumentReferences references, + + pluginConfigDescriptor = defaultConfigDescriptor + } where desc = "Provides core IDE features for Haskell" -- --------------------------------------------------------------------- +hover' :: PluginMethodHandler IdeState Method_TextDocumentHover +hover' ideState _ HoverParams{..} = do + liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ + hover ideState TextDocumentPositionParams{..} diff --git a/ghcide/test/data/hover/Bar.hs b/ghcide/test/data/hover/Bar.hs new file mode 100644 index 0000000000..f9fde2a7cc --- /dev/null +++ b/ghcide/test/data/hover/Bar.hs @@ -0,0 +1,4 @@ +module Bar (Bar(..)) where + +-- | Bar Haddock +data Bar = Bar diff --git a/ghcide/test/data/hover/Foo.hs b/ghcide/test/data/hover/Foo.hs new file mode 100644 index 0000000000..489a6ccd6b --- /dev/null +++ b/ghcide/test/data/hover/Foo.hs @@ -0,0 +1,6 @@ +module Foo (Bar, foo) where + +import Bar + +-- | foo Haddock +foo = Bar diff --git a/ghcide/test/data/hover/GotoHover.hs b/ghcide/test/data/hover/GotoHover.hs new file mode 100644 index 0000000000..6ff3eeffed --- /dev/null +++ b/ghcide/test/data/hover/GotoHover.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} +{- HLINT ignore -} +module GotoHover ( module GotoHover) where +import Data.Text (Text, pack) +import Foo (Bar, foo) + + +data TypeConstructor = DataConstructor + { fff :: Text + , ggg :: Int } +aaa :: TypeConstructor +aaa = DataConstructor + { fff = "dfgy" + , ggg = 832 + } +bbb :: TypeConstructor +bbb = DataConstructor "mjgp" 2994 +ccc :: (Text, Int) +ccc = (fff bbb, ggg aaa) +ddd :: Num a => a -> a -> a +ddd vv ww = vv +! ww +a +! b = a - b +hhh (Just a) (><) = a >< a +iii a b = a `b` a +jjj s = pack $ s <> s +class MyClass a where + method :: a -> Int +instance MyClass Int where + method = succ +kkk :: MyClass a => Int -> a -> Int +kkk n c = n + method c + +doBind :: Maybe () +doBind = do unwrapped <- Just () + return unwrapped + +listCompBind :: [Char] +listCompBind = [ succ c | c <- "ptfx" ] + +multipleClause :: Bool -> Char +multipleClause True = 't' +multipleClause False = 'f' + +-- | Recognizable docs: kpqz +documented :: Monad m => Either Int (m a) +documented = Left 7518 + +listOfInt = [ 8391 :: Int, 6268 ] + +outer :: Bool +outer = undefined inner where + + inner :: Char + inner = undefined + +imported :: Bar +imported = foo + +aa2 :: Bool +aa2 = $(id [| True |]) + +hole :: Int +hole = _ + +hole2 :: a -> Maybe a +hole2 = _ + +-- A comment above a type defnition with a deriving clause +data Example = Example + deriving (Eq) diff --git a/ghcide/test/data/hover/RecordDotSyntax.hs b/ghcide/test/data/hover/RecordDotSyntax.hs new file mode 100644 index 0000000000..3680d08a3c --- /dev/null +++ b/ghcide/test/data/hover/RecordDotSyntax.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedRecordDot, DuplicateRecordFields, NoFieldSelectors #-} + +module RecordDotSyntax ( module RecordDotSyntax) where + +import qualified Data.Maybe as M + +data MyRecord = MyRecord + { a :: String + , b :: Integer + , c :: MyChild + } deriving (Eq, Show) + +newtype MyChild = MyChild + { z :: String + } deriving (Eq, Show) + +x = MyRecord { a = "Hello", b = 12, c = MyChild { z = "there" } } +y = x.a ++ show x.b ++ x.c.z diff --git a/ghcide/test/data/hover/hie.yaml b/ghcide/test/data/hover/hie.yaml new file mode 100644 index 0000000000..e2b3e97c5d --- /dev/null +++ b/ghcide/test/data/hover/hie.yaml @@ -0,0 +1 @@ +cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}} diff --git a/ghcide/test/exe/CompletionTests.hs b/ghcide/test/exe/CompletionTests.hs new file mode 100644 index 0000000000..cf3198e74d --- /dev/null +++ b/ghcide/test/exe/CompletionTests.hs @@ -0,0 +1,574 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} + +module CompletionTests (tests) where + +import Control.Lens ((^.)) +import qualified Control.Lens as Lens +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Default +import Data.List.Extra +import Data.Maybe +import Data.Row +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.Test (waitForTypecheck) +import Development.IDE.Types.Location +import Ide.Plugin.Config +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.FilePath +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + + +tests :: TestTree +tests + = testGroup "completion" + [ + testGroup "non local" nonLocalCompletionTests + , testGroup "topLevel" topLevelCompletionTests + , testGroup "local" localCompletionTests + , testGroup "package" packageCompletionTests + , testGroup "project" projectCompletionTests + , testGroup "other" otherCompletionTests + , testGroup "doc" completionDocTests + ] + +completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe [TextEdit])] -> TestTree +completionTest name src pos expected = testSessionWait name $ do + docId <- createDoc "A.hs" "haskell" (T.unlines src) + _ <- waitForDiagnostics + compls <- getAndResolveCompletions docId pos + let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] + let emptyToMaybe x = if T.null x then Nothing else Just x + liftIO $ sortOn (Lens.view Lens._1) (take (length expected) compls') @?= + sortOn (Lens.view Lens._1) + [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] + forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do + when expectedSig $ + liftIO $ assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) + when expectedDocs $ + liftIO $ assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) + + +topLevelCompletionTests :: [TestTree] +topLevelCompletionTests = [ + completionTest + "variable" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing) + ], + completionTest + "constructor" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing) + ], + completionTest + "class method" + ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"] + (Position 0 8) + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing)], + completionTest + "type" + ["bar :: Xz", "zzz = ()", "-- | haddock", "data Xzz = XzzCon"] + (Position 0 9) + [("Xzz", CompletionItemKind_Struct, "Xzz", False, True, Nothing)], + completionTest + "class" + ["bar :: Xz", "zzz = ()", "-- | haddock", "class Xzz a"] + (Position 0 9) + [("Xzz", CompletionItemKind_Interface, "Xzz", False, True, Nothing)], + completionTest + "records" + ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ] + (Position 1 19) + [("_personName", CompletionItemKind_Function, "_personName", False, True, Nothing), + ("_personAge", CompletionItemKind_Function, "_personAge", False, True, Nothing)], + completionTest + "recordsConstructor" + ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ] + (Position 1 19) + [("XyRecord", CompletionItemKind_Constructor, "XyRecord", False, True, Nothing), + ("XyRecord", CompletionItemKind_Snippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)] + ] + +localCompletionTests :: [TestTree] +localCompletionTests = [ + completionTest + "argument" + ["bar (Just abcdef) abcdefg = abcd"] + (Position 0 32) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) + ], + completionTest + "let" + ["bar = let (Just abcdef) = undefined" + ," abcdefg = let abcd = undefined in undefined" + ," in abcd" + ] + (Position 2 15) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) + ], + completionTest + "where" + ["bar = abcd" + ," where (Just abcdef) = undefined" + ," abcdefg = let abcd = undefined in undefined" + ] + (Position 0 10) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) + ], + completionTest + "do/1" + ["bar = do" + ," Just abcdef <- undefined" + ," abcd" + ," abcdefg <- undefined" + ," pure ()" + ] + (Position 2 6) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing) + ], + completionTest + "do/2" + ["bar abcde = do" + ," Just [(abcdef,_)] <- undefined" + ," abcdefg <- undefined" + ," let abcdefgh = undefined" + ," (Just [abcdefghi]) = undefined" + ," abcd" + ," where" + ," abcdefghij = undefined" + ] + (Position 5 8) + [("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) + ,("abcdefghij", CompletionItemKind_Function, "abcdefghij", True, False, Nothing) + ,("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing) + ,("abcdefg", CompletionItemKind_Function, "abcdefg", True, False, Nothing) + ,("abcdefgh", CompletionItemKind_Function, "abcdefgh", True, False, Nothing) + ,("abcdefghi", CompletionItemKind_Function, "abcdefghi", True, False, Nothing) + ], + completionTest + "type family" + ["{-# LANGUAGE DataKinds, TypeFamilies #-}" + ,"type family Bar a" + ,"a :: Ba" + ] + (Position 2 7) + [("Bar", CompletionItemKind_Struct, "Bar", True, False, Nothing) + ], + completionTest + "class method" + [ + "class Test a where" + , " abcd :: a -> ()" + , " abcde :: a -> Int" + , "instance Test Int where" + , " abcd = abc" + ] + (Position 4 14) + [("abcd", CompletionItemKind_Function, "abcd", True, False, Nothing) + ,("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) + ], + testSessionWait "incomplete entries" $ do + let src a = "data Data = " <> a + doc <- createDoc "A.hs" "haskell" $ src "AAA" + void $ waitForTypecheck doc + let editA rhs = + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ src rhs] + editA "AAAA" + void $ waitForTypecheck doc + editA "AAAAA" + void $ waitForTypecheck doc + + compls <- getCompletions doc (Position 0 15) + liftIO $ filter ("AAA" `T.isPrefixOf`) (mapMaybe _insertText compls) @?= ["AAAAA"] + pure () + ] + +nonLocalCompletionTests :: [TestTree] +nonLocalCompletionTests = + [ brokenForWinGhc $ completionTest + "variable" + ["module A where", "f = hea"] + (Position 1 7) + [("head", CompletionItemKind_Function, "head", True, True, Nothing)], + completionTest + "constructor" + ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"] + (Position 2 8) + [ ("True", CompletionItemKind_Constructor, "True", True, True, Nothing) + ], + brokenForWinGhc $ completionTest + "type" + ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"] + (Position 2 8) + [ ("Bool", CompletionItemKind_Struct, "Bool", True, True, Nothing) + ], + completionTest + "qualified" + ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] + (Position 2 15) + [ ("head", CompletionItemKind_Function, "head", True, True, Nothing) + ], + completionTest + "duplicate import" + ["module A where", "import Data.List", "import Data.List", "f = permu"] + (Position 3 9) + [ ("permutations", CompletionItemKind_Function, "permutations", False, False, Nothing) + ], + completionTest + "dont show hidden items" + [ "{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", + "import Control.Monad hiding (join)", + "f = joi" + ] + (Position 3 6) + [], + testGroup "ordering" + [completionTest "qualified has priority" + ["module A where" + ,"import qualified Data.ByteString as BS" + ,"f = BS.read" + ] + (Position 2 10) + [("readFile", CompletionItemKind_Function, "readFile", True, True, Nothing)] + ], + -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls + completionTest + "do not show pragma completions" + [ "{-# LANGUAGE ", + "{module A where}", + "main = return ()" + ] + (Position 0 13) + [] + ] + where + brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC92, GHC94, GHC96, GHC98]) "Windows has strange things in scope for some reason" + +otherCompletionTests :: [TestTree] +otherCompletionTests = [ + completionTest + "keyword" + ["module A where", "f = newty"] + (Position 1 9) + [("newtype", CompletionItemKind_Keyword, "", False, False, Nothing)], + completionTest + "type context" + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "f = f", + "g :: Intege" + ] + -- At this point the module parses but does not typecheck. + -- This should be sufficient to detect that we are in a + -- type context and only show the completion to the type. + (Position 3 11) + [("Integer", CompletionItemKind_Struct, "Integer", True, True, Nothing)], + + testSession "duplicate record fields" $ do + void $ + createDoc "B.hs" "haskell" $ + T.unlines + [ "{-# LANGUAGE DuplicateRecordFields #-}", + "module B where", + "newtype Foo = Foo { member :: () }", + "newtype Bar = Bar { member :: () }" + ] + docA <- + createDoc "A.hs" "haskell" $ + T.unlines + [ "module A where", + "import B", + "memb" + ] + _ <- waitForDiagnostics + compls <- getCompletions docA $ Position 2 4 + let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"] + liftIO $ take 1 compls' @?= ["member"], + + testSessionWait "maxCompletions" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a = Prelude." + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + liftIO $ length compls @?= maxCompletions def + ] + +packageCompletionTests :: [TestTree] +packageCompletionTests = + [ testSession' "fromList" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}" + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 2 12) + let compls' = + [T.drop 1 $ T.dropEnd 3 d + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} + <- compls + , _label == "fromList" + ] + liftIO $ take 3 (sort compls') @?= + map ("Defined in "<>) ( + [ "'Data.List.NonEmpty" + , "'GHC.Exts" + ] ++ if ghcVersion >= GHC94 then [ "'GHC.IsList" ] else []) + + , testSessionWait "Map" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a :: Map" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 2 7) + let compls' = + [T.drop 1 $ T.dropEnd 3 d + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} + <- compls + , _label == "Map" + ] + liftIO $ take 3 (sort compls') @?= + map ("Defined in "<>) + [ "'Data.Map" + , "'Data.Map.Lazy" + , "'Data.Map.Strict" + ] + , testSessionWait "no duplicates" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "import GHC.Exts(fromList)", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + let duplicate = + filter + (\case + CompletionItem + { _insertText = Just "fromList" + , _documentation = + Just (InR (MarkupContent MarkupKind_Markdown d)) + } -> + "GHC.Exts" `T.isInfixOf` d + _ -> False + ) compls + liftIO $ length duplicate @?= 1 + + , testSessionWait "non-local before global" $ do + -- non local completions are more specific + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "import GHC.Exts(fromList)", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + let compls' = + [_insertText + | CompletionItem {_label, _insertText} <- compls + , _label == "fromList" + ] + liftIO $ take 3 compls' @?= + map Just ["fromList"] + ] + +projectCompletionTests :: [TestTree] +projectCompletionTests = + [ testSession' "from hiedb" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" + _ <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + -- Note that B does not import A + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "b = anidenti" + ] + compls <- getCompletions doc (Position 1 10) + let compls' = + [T.drop 1 $ T.dropEnd 3 d + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} + <- compls + , _label == "anidentifier" + ] + liftIO $ compls' @?= ["Defined in 'A"], + testSession' "auto complete project imports" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}" + _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines + [ "module ALocalModule (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + -- Note that B does not import A + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import ALocal" + ] + compls <- getCompletions doc (Position 1 13) + let item = head $ filter ((== "ALocalModule") . (^. L.label)) compls + liftIO $ do + item ^. L.label @?= "ALocalModule", + testSession' "auto complete functions from qualified imports without alias" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" + _ <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import qualified A", + "A." + ] + compls <- getCompletions doc (Position 2 2) + let item = head compls + liftIO $ do + item ^. L.label @?= "anidentifier", + testSession' "auto complete functions from qualified imports with alias" $ \dir-> do + liftIO $ writeFile (dir "hie.yaml") + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" + _ <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import qualified A as Alias", + "foo = Alias." + ] + compls <- getCompletions doc (Position 2 12) + let item = head compls + liftIO $ do + item ^. L.label @?= "anidentifier" + ] + +completionDocTests :: [TestTree] +completionDocTests = + [ testSession "local define" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = ()" + , "bar = fo" + ] + let expected = "*Defined at line 2, column 1 in this module*\n" + test doc (Position 2 8) "foo" Nothing [expected] + , testSession "local empty doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"] + , testSession "local single line doc without newline" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- |docdoc" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\n\n\ndocdoc\n"] + , testSession "local multi line doc with newline" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- | abcabc" + , "--" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n\n\nabcabc\n"] + , testSession "local multi line doc without newline" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- | abcabc" + , "--" + , "--def" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n\n\nabcabc \n\ndef\n"] + , testSession "extern empty doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = od" + ] + let expected = "*Imported from 'Prelude'*\n" + test doc (Position 1 8) "odd" (Just $ T.length expected) [expected] + , brokenForMacGhc9 $ testSession "extern single line doc without '\\n'" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = no" + ] + let expected = "*Imported from 'Prelude'*\n* * *\n\n\nBoolean \"not\"\n" + test doc (Position 1 8) "not" (Just $ T.length expected) [expected] + , brokenForMacGhc9 $ testSession "extern mulit line doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = i" + ] + let expected = "*Imported from 'Prelude'*\n* * *\n\n\nIdentity function. \n```haskell\nid x = x\n```\n" + test doc (Position 1 7) "id" (Just $ T.length expected) [expected] + , testSession "extern defined doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = i" + ] + let expected = "*Imported from 'Prelude'*\n" + test doc (Position 1 7) "id" (Just $ T.length expected) [expected] + ] + where + -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903 + brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC92, GHC94, GHC96]) "Extern doc doesn't support MacOS for ghc9" + test doc pos label mn expected = do + _ <- waitForDiagnostics + compls <- getCompletions doc pos + rcompls <- forM compls $ \item -> do + if isJust (item ^. L.data_) + then do + rsp <- request SMethod_CompletionItemResolve item + case rsp ^. L.result of + Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) + Right x -> pure x + else pure item + let compls' = [ + -- We ignore doc uris since it points to the local path which determined by specific machines + case mn of + Nothing -> txt + Just n -> T.take n txt + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown txt)), ..} <- rcompls + , _label == label + ] + liftIO $ compls' @?= expected diff --git a/ghcide/test/exe/CradleTests.hs b/ghcide/test/exe/CradleTests.hs index 3a318c5fdf..a0a6cc364b 100644 --- a/ghcide/test/exe/CradleTests.hs +++ b/ghcide/test/exe/CradleTests.hs @@ -205,21 +205,19 @@ sessionDepsArePickedUp :: TestTree sessionDepsArePickedUp = testSession' "session-deps-are-picked-up" $ \dir -> do - -- Open without OverloadedStrings and expect an error. - doc <- createDoc "Foo.hs" "haskell" fooContent - -- Update hie.yaml to enable OverloadedStrings. liftIO $ writeFileUTF8 (dir "hie.yaml") - "cradle: {direct: {arguments: [-XOverloadedStrings]}}" - -- Now no errors. - -- expectDiagnostics [("Foo.hs", [])] - expectNoMoreDiagnostics 3 + "cradle: {direct: {arguments: []}}" + -- Open without OverloadedStrings and expect an error. + doc <- createDoc "Foo.hs" "haskell" fooContent + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])] + -- Update hie.yaml to enable OverloadedStrings. liftIO $ writeFileUTF8 (dir "hie.yaml") - "cradle: {direct: {arguments: []}}" + "cradle: {direct: {arguments: [-XOverloadedStrings]}}" sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams [FileEvent (filePathToUri $ dir "hie.yaml") FileChangeType_Changed ] -- Send change event. @@ -228,7 +226,8 @@ sessionDepsArePickedUp = testSession' .+ #rangeLength .== Nothing .+ #text .== "\n" changeDoc doc [change] - expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])] + -- Now no errors. + expectDiagnostics [("Foo.hs", [])] where fooContent = T.unlines diff --git a/ghcide/test/exe/FindDefinitionAndHoverTests.hs b/ghcide/test/exe/FindDefinitionAndHoverTests.hs new file mode 100644 index 0000000000..04ede6579b --- /dev/null +++ b/ghcide/test/exe/FindDefinitionAndHoverTests.hs @@ -0,0 +1,235 @@ + +module FindDefinitionAndHoverTests (tests) where + +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Foldable +import Data.Maybe +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.GHC.Util +import Development.IDE.Test (expectDiagnostics, + standardizeQuotes) +import Development.IDE.Types.Location +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.FilePath +import System.Info.Extra (isWindows) + +import Control.Lens ((^.)) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils +import Text.Regex.TDFA ((=~)) + +tests :: TestTree +tests = let + + tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree + tst (get, check) pos sfp targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do + + -- Dirty the cache to check that definitions work even in the presence of iface files + liftIO $ runInDir dir $ do + let fooPath = dir "Foo.hs" + fooSource <- liftIO $ readFileUtf8 fooPath + fooDoc <- createDoc fooPath "haskell" fooSource + _ <- getHover fooDoc $ Position 4 3 + closeDoc fooDoc + + doc <- openTestDataDoc (dir sfp) + waitForProgressDone + found <- get doc pos + check found targetRange + + + + checkHover :: Maybe Hover -> Session [Expect] -> Session () + checkHover hover expectations = traverse_ check =<< expectations where + + check expected = + case hover of + Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" + Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg}) + ,_range = rangeInHover } -> + case expected of + ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets + ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets + ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool) + ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover + _ -> pure () -- all other expectations not relevant to hover + _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover + + extractLineColFromHoverMsg :: T.Text -> [T.Text] + extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":") + + checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () + checkHoverRange expectedRange rangeInHover msg = + let + lineCol = extractLineColFromHoverMsg msg + -- looks like hovers use 1-based numbering while definitions use 0-based + -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. + adjust Position{_line = l, _character = c} = + Position{_line = l + 1, _character = c + 1} + in + case map (read . T.unpack) lineCol of + [l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c + _ -> liftIO $ assertFailure $ + "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> + "\n but got: " <> show (msg, rangeInHover) + + assertFoundIn :: T.Text -> T.Text -> Assertion + assertFoundIn part whole = assertBool + (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) + (part `T.isInfixOf` whole) + + assertNotFoundIn :: T.Text -> T.Text -> Assertion + assertNotFoundIn part whole = assertBool + (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole) + (not . T.isInfixOf part $ whole) + + sourceFilePath = T.unpack sourceFileName + sourceFileName = "GotoHover.hs" + + mkFindTests tests = testGroup "get" + [ testGroup "definition" $ mapMaybe fst tests + , testGroup "hover" $ mapMaybe snd tests + , checkFileCompiles sourceFilePath $ + expectDiagnostics + [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _")]) + , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _")]) + ] + , testGroup "type-definition" typeDefinitionTests + , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ] + + typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 sourceFilePath (pure tcData) "Saturated data con" + , tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"] + + recordDotSyntaxTests = + [ tst (getHover, checkHover) (Position 17 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent" + , tst (getHover, checkHover) (Position 17 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child" + , tst (getHover, checkHover) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child" + ] + + test runDef runHover look expect = testM runDef runHover look (return expect) + + testM runDef runHover look expect title = + ( runDef $ tst def look sourceFilePath expect title + , runHover $ tst hover look sourceFilePath expect title ) where + def = (getDefinitions, checkDefs) + hover = (getHover , checkHover) + + -- search locations expectations on results + fffL4 = fffR ^. L.start; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR] + fffL8 = Position 12 4 ; + fffL14 = Position 18 7 ; + aL20 = Position 19 15 + aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] + dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] + dcL12 = Position 16 11 ; + xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]] + tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]] + vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6] + opL16 = Position 20 15 ; op = [mkR 21 2 21 4] + opL18 = Position 22 22 ; opp = [mkR 22 13 22 17] + aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11] + b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7] + xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["pack", ":: String -> Text", "Data.Text", "text"]] + clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]] + clL25 = Position 29 9 + eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num", "base"]] + dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21] + dnbL30 = Position 34 23 + lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27] + lclL33 = Position 37 22 + mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14] + mclL37 = Position 41 1 + spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]] + docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]] + ; constr = [ExpectHoverText ["Monad m"]] + eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: Type -> Type -> Type\n"]] + intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: Type\n"]] + tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]] + intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]] + chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]] + txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]] + lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]] + outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 50 0 50 5] + innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] + holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]] + holeL65 = Position 65 8 ; hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]] + cccL17 = Position 17 16 ; docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"] + imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3] + reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)] + thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]] + cmtL68 = Position 67 0 ; lackOfdEq = [ExpectHoverExcludeText ["$dEq"]] + import310 = Position 3 10; pkgTxt = [ExpectHoverText ["Data.Text\n\ntext-"]] + in + mkFindTests + -- def hover look expect + [ -- It suggests either going to the constructor or to the field + test broken yes fffL4 fff "field in record definition" + , test yes yes fffL8 fff "field in record construction #1102" + , test yes yes fffL14 fff "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs + , test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes dcL7 tcDC "data constructor record #1029" + , test yes yes dcL12 tcDC "data constructor plain" -- https://github.com/haskell/ghcide/pull/121 + , test yes yes tcL6 tcData "type constructor #1028" -- https://github.com/haskell/ghcide/pull/147 + , test broken yes xtcL5 xtc "type constructor external #717,1028" + , test broken yes xvL20 xvMsg "value external package #717" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes vvL16 vv "plain parameter" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes aL18 apmp "pattern match name" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes opL16 op "top-level operator #713" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes opL18 opp "parameter operator" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes b'L19 bp "name in backticks" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes clL23 cls "class in instance declaration #1027" + , test yes yes clL25 cls "class in signature #1027" -- https://github.com/haskell/ghcide/pull/147 + , test broken yes eclL15 ecls "external class in signature #717,1027" + , test yes yes dnbL29 dnb "do-notation bind #1073" + , test yes yes dnbL30 dnb "do-notation lookup" + , test yes yes lcbL33 lcb "listcomp bind #1073" + , test yes yes lclL33 lcb "listcomp lookup" + , test yes yes mclL36 mcl "top-level fn 1st clause" + , test yes yes mclL37 mcl "top-level fn 2nd clause #1030" + , test yes yes spaceL37 space "top-level fn on space #1002" + , test no yes docL41 doc "documentation #1129" + , test no yes eitL40 kindE "kind of Either #1017" + , test no yes intL40 kindI "kind of Int #1017" + , test no broken tvrL40 kindV "kind of (* -> *) type variable #1017" + , test no broken intL41 litI "literal Int in hover info #1016" + , test no broken chrL36 litC "literal Char in hover info #1016" + , test no broken txtL8 litT "literal Text in hover info #1016" + , test no broken lstL43 litL "literal List in hover info #1016" + , test yes yes cmtL68 lackOfdEq "no Core symbols #3280" + , test no yes docL41 constr "type constraint in hover info #1012" + , test no yes outL45 outSig "top-level signature #767" + , test broken broken innL48 innSig "inner signature #767" + , test no yes holeL60 hleInfo "hole without internal name #831" + , test no yes holeL65 hleInfo2 "hole with variable" + , test no yes cccL17 docLink "Haddock html links" + , testM yes yes imported importedSig "Imported symbol" + , if isWindows then + -- Flaky on Windows: https://github.com/haskell/haskell-language-server/issues/2997 + testM no yes reexported reexportedSig "Imported symbol (reexported)" + else + testM yes yes reexported reexportedSig "Imported symbol (reexported)" + , test no yes thLocL57 thLoc "TH Splice Hover" + , test yes yes import310 pkgTxt "show package name and its version" + ] + where yes, broken :: (TestTree -> Maybe TestTree) + yes = Just -- test should run and pass + broken = Just . (`xfail` "known broken") + no = const Nothing -- don't run this test at all + --skip = const Nothing -- unreliable, don't run + +checkFileCompiles :: FilePath -> Session () -> TestTree +checkFileCompiles fp diag = + testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do + void (openTestDataDoc (dir fp)) + diag diff --git a/ghcide/test/exe/HighlightTests.hs b/ghcide/test/exe/HighlightTests.hs new file mode 100644 index 0000000000..7fb5ca79a2 --- /dev/null +++ b/ghcide/test/exe/HighlightTests.hs @@ -0,0 +1,79 @@ + +module HighlightTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..)) +import Development.IDE.Types.Location +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup "highlight" + [ testSessionWait "value" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 3 2) + liftIO $ highlights @?= + [ DocumentHighlight (R 2 0 2 3) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 3 0 3 3) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 4 6 4 9) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 5 22 5 25) (Just DocumentHighlightKind_Read) + ] + , testSessionWait "type" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 2 8) + liftIO $ highlights @?= + [ DocumentHighlight (R 2 7 2 10) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 3 11 3 14) (Just DocumentHighlightKind_Read) + ] + , testSessionWait "local" $ do + doc <- createDoc "A.hs" "haskell" source + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 6 5) + liftIO $ highlights @?= + [ DocumentHighlight (R 6 4 6 7) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 6 10 6 13) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 7 12 7 15) (Just DocumentHighlightKind_Read) + ] + , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "Ghc9 highlights the constructor and not just this field" $ + testSessionWait "record" $ do + doc <- createDoc "A.hs" "haskell" recsource + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 4 15) + liftIO $ highlights @?= + [ DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 4 14 4 20) (Just DocumentHighlightKind_Read) + ] + highlights <- getHighlights doc (Position 3 17) + liftIO $ highlights @?= + [ DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Read) + ] + ] + where + source = T.unlines + ["{-# OPTIONS_GHC -Wunused-binds #-}" + ,"module Highlight () where" + ,"foo :: Int" + ,"foo = 3 :: Int" + ,"bar = foo" + ," where baz = let x = foo in x" + ,"baz arg = arg + x" + ," where x = arg" + ] + recsource = T.unlines + ["{-# LANGUAGE RecordWildCards #-}" + ,"{-# OPTIONS_GHC -Wunused-binds #-}" + ,"module Highlight () where" + ,"data Rec = Rec { field1 :: Int, field2 :: Char }" + ,"foo Rec{..} = field2 + field1" + ] diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs new file mode 100644 index 0000000000..e4a47838aa --- /dev/null +++ b/ghcide/test/exe/InitializeResponseTests.hs @@ -0,0 +1,97 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} + +module InitializeResponseTests (tests) where + +import Control.Monad +import Data.List.Extra +import Data.Row +import qualified Data.Text as T +import Development.IDE.Plugin.TypeLenses (typeLensCommandId) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test + +import Control.Lens ((^.)) +import Development.IDE.Plugin.Test (blockCommandId) +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = withResource acquire release tests where + + -- these tests document and monitor the evolution of the + -- capabilities announced by the server in the initialize + -- response. Currently the server advertises almost no capabilities + -- at all, in some cases failing to announce capabilities that it + -- actually does provide! Hopefully this will change ... + tests :: IO (TResponseMessage Method_Initialize) -> TestTree + tests getInitializeResponse = + testGroup "initialize response capabilities" + [ chk " text doc sync" _textDocumentSync tds + , chk " hover" _hoverProvider (Just $ InR (HoverOptions (Just False))) + , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing (Just True) Nothing) + , chk "NO signature help" _signatureHelpProvider Nothing + , chk " goto definition" _definitionProvider (Just $ InR (DefinitionOptions (Just False))) + , chk " goto type definition" _typeDefinitionProvider (Just $ InR (InL (TypeDefinitionOptions (Just False)))) + -- BUG in lsp-test, this test fails, just change the accepted response + -- for now + , chk "NO goto implementation" _implementationProvider Nothing + , chk " find references" _referencesProvider (Just $ InR (ReferenceOptions (Just False))) + , chk " doc highlight" _documentHighlightProvider (Just $ InR (DocumentHighlightOptions (Just False))) + , chk " doc symbol" _documentSymbolProvider (Just $ InR (DocumentSymbolOptions (Just False) Nothing)) + -- , chk " workspace symbol" _workspaceSymbolProvider (Just $ InR (WorkspaceSymbolOptions (Just False) (Just False))) + , chk "NO code action" _codeActionProvider Nothing + , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just True)) + , chk "NO doc formatting" _documentFormattingProvider Nothing + , chk "NO doc range formatting" + _documentRangeFormattingProvider Nothing + , chk "NO doc formatting on typing" + _documentOnTypeFormattingProvider Nothing + , chk "NO renaming" _renameProvider Nothing + , chk "NO doc link" _documentLinkProvider Nothing + , chk "NO color" (^. L.colorProvider) Nothing + , chk "NO folding range" _foldingRangeProvider Nothing + , che " execute command" _executeCommandProvider [typeLensCommandId, blockCommandId] + , chk " workspace" (^. L.workspace) (Just $ #workspaceFolders .== Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )} + .+ #fileOperations .== Nothing) + , chk "NO experimental" (^. L.experimental) Nothing + ] where + + tds = Just (InL (TextDocumentSyncOptions + { _openClose = Just True + , _change = Just TextDocumentSyncKind_Incremental + , _willSave = Nothing + , _willSaveWaitUntil = Nothing + , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) + + chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree + chk title getActual expected = + testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir + + che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree + che title getActual expected = testCase title $ do + ir <- getInitializeResponse + ExecuteCommandOptions {_commands = commands} <- case getActual $ innerCaps ir of + Just eco -> pure eco + Nothing -> assertFailure "Was expecting Just ExecuteCommandOptions, got Nothing" + let commandNames = (!! 2) . T.splitOn ":" <$> commands + zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames) + + innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities + innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c + innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error" + + acquire :: IO (TResponseMessage Method_Initialize) + acquire = run initializeResponse + + release :: TResponseMessage Method_Initialize -> IO () + release = mempty + diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index b64213e1df..412a6969fe 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -47,9 +47,14 @@ import Test.Tasty.Ingredients.Rerun import LogType () import OpenCloseTest +import InitializeResponseTests +import CompletionTests import CPPTests import DiagnosticTests import CodeLensTests +import OutlineTests +import HighlightTests +import FindDefinitionAndHoverTests import PluginSimpleTests import PreprocessorTests import THTests @@ -67,6 +72,7 @@ import BootTests import RootUriTests import AsyncTests import ClientSettingsTests +import ReferenceTests import GarbageCollectionTests import ExceptionTests @@ -87,9 +93,14 @@ main = do -- We mess with env vars so run single-threaded. defaultMainWithRerun $ testGroup "ghcide" [ OpenCloseTest.tests + , InitializeResponseTests.tests + , CompletionTests.tests , CPPTests.tests , DiagnosticTests.tests , CodeLensTests.tests + , OutlineTests.tests + , HighlightTests.tests + , FindDefinitionAndHoverTests.tests , PluginSimpleTests.tests , PreprocessorTests.tests , THTests.tests @@ -107,6 +118,7 @@ main = do , RootUriTests.tests , AsyncTests.tests , ClientSettingsTests.tests + , ReferenceTests.tests , GarbageCollectionTests.tests , HieDbRetry.tests , ExceptionTests.tests recorder logger diff --git a/ghcide/test/exe/OutlineTests.hs b/ghcide/test/exe/OutlineTests.hs new file mode 100644 index 0000000000..6459e1deca --- /dev/null +++ b/ghcide/test/exe/OutlineTests.hs @@ -0,0 +1,189 @@ + +module OutlineTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import Test.Tasty +import Test.Tasty.HUnit +import TestUtils + +tests :: TestTree +tests = testGroup + "outline" + [ testSessionWait "type class" $ do + let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ moduleSymbol + "A" + (R 0 7 0 8) + [ classSymbol "A a" + (R 1 0 1 30) + [docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)] + ] + ] + , testSessionWait "type class instance " $ do + let source = T.unlines ["class A a where", "instance A () where"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ classSymbol "A a" (R 0 0 0 15) [] + , docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19) + ] + , testSessionWait "type family" $ do + let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)] + , testSessionWait "type family instance " $ do + let source = T.unlines + [ "{-# language TypeFamilies #-}" + , "type family A a" + , "type instance A () = ()" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15) + , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23) + ] + , testSessionWait "data family" $ do + let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)] + , testSessionWait "data family instance " $ do + let source = T.unlines + [ "{-# language TypeFamilies #-}" + , "data family A a" + , "data instance A () = A ()" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 11) + , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25) + ] + , testSessionWait "constant" $ do + let source = T.unlines ["a = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbol "a" SymbolKind_Function (R 0 0 0 6)] + , testSessionWait "pattern" $ do + let source = T.unlines ["Just foo = Just 21"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)] + , testSessionWait "pattern with type signature" $ do + let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)] + , testSessionWait "function" $ do + let source = T.unlines ["a _x = ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbol "a" SymbolKind_Function (R 0 0 0 9)] + , testSessionWait "type synonym" $ do + let source = T.unlines ["type A = Bool"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)] + , testSessionWait "datatype" $ do + let source = T.unlines ["data A = C"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ docSymbolWithChildren "A" + SymbolKind_Struct + (R 0 0 0 10) + [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)] + ] + , testSessionWait "record fields" $ do + let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 2 13) + [ docSymbolWithChildren' "B" SymbolKind_Constructor (R 0 9 2 13) (R 0 9 0 10) + [ docSymbol "x" SymbolKind_Field (R 1 2 1 3) + , docSymbol "y" SymbolKind_Field (R 2 4 2 5) + ] + ] + ] + , testSessionWait "import" $ do + let source = T.unlines ["import Data.Maybe ()"] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbolWithChildren "imports" + SymbolKind_Module + (R 0 0 0 20) + [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20) + ] + ] + , testSessionWait "multiple import" $ do + let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right + [docSymbolWithChildren "imports" + SymbolKind_Module + (R 1 0 3 27) + [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20) + , docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27) + ] + ] + , testSessionWait "foreign import" $ do + let source = T.unlines + [ "{-# language ForeignFunctionInterface #-}" + , "foreign import ccall \"a\" a :: Int" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)] + , testSessionWait "foreign export" $ do + let source = T.unlines + [ "{-# language ForeignFunctionInterface #-}" + , "foreign export ccall odd :: Int -> Bool" + ] + docId <- createDoc "A.hs" "haskell" source + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)] + ] + where + docSymbol name kind loc = + DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing + docSymbol' name kind loc selectionLoc = + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing + docSymbolD name detail kind loc = + DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing + docSymbolWithChildren name kind loc cc = + DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc) + docSymbolWithChildren' name kind loc selectionLoc cc = + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc) + moduleSymbol name loc cc = DocumentSymbol name + Nothing + SymbolKind_File + Nothing + Nothing + (R 0 0 maxBound 0) + loc + (Just cc) + classSymbol name loc cc = DocumentSymbol name + (Just "class") + SymbolKind_Interface + Nothing + Nothing + loc + loc + (Just cc) diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs new file mode 100644 index 0000000000..5abb18bfe8 --- /dev/null +++ b/ghcide/test/exe/ReferenceTests.hs @@ -0,0 +1,199 @@ + +module ReferenceTests (tests) where + +import Control.Applicative.Combinators +import qualified Control.Lens as Lens +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.List.Extra +import qualified Data.Set as Set +import Development.IDE.Test (configureCheckProject, + referenceReady) +import Development.IDE.Types.Location +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.Directory +import System.FilePath +-- import Test.QuickCheck.Instances () +import Control.Lens ((^.)) +import Data.Tuple.Extra +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import TestUtils + + +tests :: TestTree +tests = testGroup "references" + [ testGroup "can get references to FOIs" + [ referenceTest "can get references to symbols" + ("References.hs", 4, 7) + YesIncludeDeclaration + [ ("References.hs", 4, 6) + , ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + + , referenceTest "can get references to data constructor" + ("References.hs", 13, 2) + YesIncludeDeclaration + [ ("References.hs", 13, 2) + , ("References.hs", 16, 14) + , ("References.hs", 19, 21) + ] + + , referenceTest "getting references works in the other module" + ("OtherModule.hs", 6, 0) + YesIncludeDeclaration + [ ("OtherModule.hs", 6, 0) + , ("OtherModule.hs", 8, 16) + ] + + , referenceTest "getting references works in the Main module" + ("Main.hs", 9, 0) + YesIncludeDeclaration + [ ("Main.hs", 9, 0) + , ("Main.hs", 10, 4) + ] + + , referenceTest "getting references to main works" + ("Main.hs", 5, 0) + YesIncludeDeclaration + [ ("Main.hs", 4, 0) + , ("Main.hs", 5, 0) + ] + + , referenceTest "can get type references" + ("Main.hs", 9, 9) + YesIncludeDeclaration + [ ("Main.hs", 9, 0) + , ("Main.hs", 9, 9) + , ("Main.hs", 10, 0) + ] + + , expectFailBecause "references provider does not respect includeDeclaration parameter" $ + referenceTest "works when we ask to exclude declarations" + ("References.hs", 4, 7) + NoExcludeDeclaration + [ ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + + , referenceTest "INCORRECTLY returns declarations when we ask to exclude them" + ("References.hs", 4, 7) + NoExcludeDeclaration + [ ("References.hs", 4, 6) + , ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + ] + + , testGroup "can get references to non FOIs" + [ referenceTest "can get references to symbol defined in a module we import" + ("References.hs", 22, 4) + YesIncludeDeclaration + [ ("References.hs", 22, 4) + , ("OtherModule.hs", 0, 20) + , ("OtherModule.hs", 4, 0) + ] + + , referenceTest "can get references in modules that import us to symbols we define" + ("OtherModule.hs", 4, 0) + YesIncludeDeclaration + [ ("References.hs", 22, 4) + , ("OtherModule.hs", 0, 20) + , ("OtherModule.hs", 4, 0) + ] + + , referenceTest "can get references to symbol defined in a module we import transitively" + ("References.hs", 24, 4) + YesIncludeDeclaration + [ ("References.hs", 24, 4) + , ("OtherModule.hs", 0, 48) + , ("OtherOtherModule.hs", 2, 0) + ] + + , referenceTest "can get references in modules that import us transitively to symbols we define" + ("OtherOtherModule.hs", 2, 0) + YesIncludeDeclaration + [ ("References.hs", 24, 4) + , ("OtherModule.hs", 0, 48) + , ("OtherOtherModule.hs", 2, 0) + ] + + , referenceTest "can get type references to other modules" + ("Main.hs", 12, 10) + YesIncludeDeclaration + [ ("Main.hs", 12, 7) + , ("Main.hs", 13, 0) + , ("References.hs", 12, 5) + , ("References.hs", 16, 0) + ] + ] + ] + +-- | When we ask for all references to symbol "foo", should the declaration "foo +-- = 2" be among the references returned? +data IncludeDeclaration = + YesIncludeDeclaration + | NoExcludeDeclaration + +getReferences' :: SymbolLocation -> IncludeDeclaration -> Session ([Location]) +getReferences' (file, l, c) includeDeclaration = do + doc <- openDoc file "haskell" + getReferences doc (Position l c) $ toBool includeDeclaration + where toBool YesIncludeDeclaration = True + toBool NoExcludeDeclaration = False + +referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree +referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do + -- needed to build whole project indexing + configureCheckProject True + let docs = map (dir ) $ delete thisDoc $ nubOrd docs' + -- Initial Index + docid <- openDoc thisDoc "haskell" + let + loop :: [FilePath] -> Session () + loop [] = pure () + loop docs = do + doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) + loop (delete doc docs) + loop docs + f dir + closeDoc docid + +-- | Given a location, lookup the symbol and all references to it. Make sure +-- they are the ones we expect. +referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree +referenceTest name loc includeDeclaration expected = + referenceTestSession name (fst3 loc) docs $ \dir -> do + actual <- getReferences' loc includeDeclaration + liftIO $ actual `expectSameLocations` map (first3 (dir )) expected + where + docs = map fst3 expected + +type SymbolLocation = (FilePath, UInt, UInt) + +expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion +expectSameLocations actual expected = do + let actual' = + Set.map (\location -> (location ^. L.uri + , location ^. L.range . L.start . L.line . Lens.to fromIntegral + , location ^. L.range . L.start . L.character . Lens.to fromIntegral)) + $ Set.fromList actual + expected' <- Set.fromList <$> + (forM expected $ \(file, l, c) -> do + fp <- canonicalizePath file + return (filePathToUri fp, l, c)) + actual' @?= expected' From c3d2674bc03b15e019eb926614f05e1c3a409bfb Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 13 Apr 2024 17:27:10 +0800 Subject: [PATCH 33/34] upgrade ghcide --- .../session-loader/Development/IDE/Session.hs | 36 +++++++++++++------ ghcide/src/Development/IDE/Core/Rules.hs | 16 +-------- ghcide/src/Development/IDE/Core/Shake.hs | 7 ---- .../Development/IDE/LSP/HoverDefinition.hs | 6 +++- .../src/Development/IDE/LSP/LanguageServer.hs | 17 ++++----- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 3 +- ghcide/test/exe/InitializeResponseTests.hs | 2 +- 7 files changed, 41 insertions(+), 46 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 48af221f9b..e6d1a6696b 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -585,9 +585,21 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv all_target_details <- new_cache old_deps new_deps - let all_targets = concatMap fst all_target_details - - let this_flags_map = HM.fromList (concatMap toFlagsMap all_targets) + this_dep_info <- getDependencyInfo $ maybeToList hieYaml + let (all_targets, this_flags_map, this_options) + = case HM.lookup _cfp flags_map' of + Just this -> (all_targets', flags_map', this) + Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags) + where all_targets' = concat all_target_details + flags_map' = HM.fromList (concatMap toFlagsMap all_targets') + this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp] + this_flags = (this_error_env, this_dep_info) + this_error_env = ([this_error], Nothing) + this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp + $ T.unlines + [ "No cradle target found. Is this file listed in the targets of your cradle?" + , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" + ] void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map @@ -615,7 +627,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) - return $ second Map.keys $ this_flags_map HM.! _cfp + return $ second Map.keys this_options let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) consultCradle hieYaml cfp = do @@ -810,7 +822,7 @@ newComponentCache -> HscEnv -- ^ An empty HscEnv -> [ComponentInfo] -- ^ New components to be loaded -> [ComponentInfo] -- ^ old, already existing components - -> IO [ ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))] + -> IO [ [TargetDetails] ] newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis) -- When we have multiple components with the same uid, @@ -882,14 +894,13 @@ newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do henv <- createHscEnvEq thisEnv (zip uids dfs) let targetEnv = (if isBad ci then multi_errs else [], Just henv) targetDepends = componentDependencyInfo ci - res = ( targetEnv, targetDepends) - logWith recorder Debug $ LogNewComponentCache res + logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends) evaluate $ liftRnf rwhnf $ componentTargets ci let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends ctargets <- concatMapM mk (componentTargets ci) - return (L.nubOrdOn targetTarget ctargets, res) + return (L.nubOrdOn targetTarget ctargets) {- Note [Avoiding bad interface files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1081,8 +1092,10 @@ setOptions cfp (ComponentOptions theOpts compRoot _) dflags = do -- A special target for the file which caused this wonderful -- component to be created. In case the cradle doesn't list all the targets for -- the component, in which case things will be horribly broken anyway. - -- Otherwise, we will immediately attempt to reload this module which - -- causes an infinite loop and high CPU usage. + -- + -- When we have a single component that is caused to be loaded due to a + -- file, we assume the file is part of that component. This is useful + -- for bare GHC sessions, such as many of the ones used in the testsuite -- -- We don't do this when we have multiple components, because each -- component better list all targets or there will be anarchy. @@ -1090,6 +1103,9 @@ setOptions cfp (ComponentOptions theOpts compRoot _) dflags = do -- that case. -- Multi unit arguments are likely to come from cabal, which -- does list all targets. + -- + -- If we don't end up with a target for the current file in the end, then + -- we will report it as an error for that file abs_fp <- liftIO $ makeAbsolute (fromNormalizedFilePath cfp) let special_target = Compat.mkSimpleTarget df abs_fp pure $ (df, special_target : targets) :| [] diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 0f4430e6af..6242ccff50 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -11,11 +11,8 @@ module Development.IDE.Core.Rules( -- * Types IdeState, GetParsedModule(..), TransitiveDependencies(..), - Priority(..), GhcSessionIO(..), GetClientSettings(..), + GhcSessionIO(..), GetClientSettings(..), -- * Functions - priorityTypeCheck, - priorityGenerateCore, - priorityFilesOfInterest, runAction, toIdeResult, defineNoFile, @@ -250,15 +247,6 @@ getParsedModuleWithComments = use GetParsedModuleWithComments -- Rules -- These typically go from key to value and are oracles. -priorityTypeCheck :: Priority -priorityTypeCheck = Priority 0 - -priorityGenerateCore :: Priority -priorityGenerateCore = Priority (-1) - -priorityFilesOfInterest :: Priority -priorityFilesOfInterest = Priority (-2) - -- | WARNING: -- We currently parse the module both with and without Opt_Haddock, and -- return the one with Haddocks if it -- succeeds. However, this may not work @@ -682,7 +670,6 @@ typeCheckRuleDefinition -> ParsedModule -> Action (IdeResult TcModuleResult) typeCheckRuleDefinition hsc pm = do - setPriority priorityTypeCheck IdeOptions { optDefer = defer } <- getIdeOptions unlift <- askUnliftIO @@ -936,7 +923,6 @@ generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts generateCore runSimplifier file = do packageState <- hscEnv <$> use_ GhcSessionDeps file tm <- use_ TypeCheck file - setPriority priorityGenerateCore liftIO $ compileModule runSimplifier packageState (tmrModSummary tm) (tmrTypechecked tm) generateCoreRule :: Recorder (WithPriority Log) -> Rules () diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 2791dcfc2d..5d5eb511d2 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -51,12 +51,10 @@ module Development.IDE.Core.Shake( HLS.getClientConfig, getPluginConfigAction, knownTargets, - setPriority, ideLogger, actionLogger, getVirtualFile, FileVersion(..), - Priority(..), updatePositionMapping, updatePositionMappingHelper, deleteValue, recordDirtyKeys, @@ -1307,11 +1305,6 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti | otherwise = c -newtype Priority = Priority Double - -setPriority :: Priority -> Action () -setPriority (Priority p) = reschedule p - ideLogger :: IdeState -> Logger ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index 1aa531293e..c561243bf7 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -11,7 +11,7 @@ module Development.IDE.LSP.HoverDefinition , gotoTypeDefinition , documentHighlight , references - -- , wsSymbols + , wsSymbols ) where import Control.Monad.Except (ExceptT) @@ -47,6 +47,10 @@ references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do " in file: " <> T.pack (show nfp) InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos) +wsSymbols :: PluginMethodHandler IdeState Method_WorkspaceSymbol +wsSymbols ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do + logDebug (ideLogger ide) $ "Workspace symbols request: " <> query + runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ InL . fromMaybe [] <$> workspaceSymbols query foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null foundHover (mbRange, contents) = diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 5663165f02..3a3ddd7d87 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -42,7 +42,6 @@ import Ide.Logger import Language.LSP.Server (LanguageContextEnv, LspServerLog, type (<~>)) -import System.IO.Unsafe (unsafeInterleaveIO) data Log = LogRegisteringIdeConfig !IdeConfiguration | LogReactorThreadException !SomeException @@ -197,18 +196,10 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa let root = LSP.resRootPath env dir <- maybe getCurrentDirectory return root dbLoc <- getHieDbLoc dir - - -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference - -- to 'getIdeState', so we use this dirty trick - dbMVar <- newEmptyMVar - ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar - - ide <- getIdeState env root withHieDb hieChan - let initConfig = parseConfiguration params - logWith recorder Info $ LogRegisteringIdeConfig initConfig - registerIdeConfiguration (shakeExtras ide) initConfig + dbMVar <- newEmptyMVar + let handleServerException (Left e) = do logWith recorder Error $ LogReactorThreadException e @@ -245,6 +236,10 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa ReactorNotification act -> handle exceptionInHandler act ReactorRequest _id act k -> void $ async $ checkCancelled _id act k logWith recorder Info LogReactorThreadStopped + + (WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar + ide <- getIdeState env root withHieDb hieChan + registerIdeConfiguration (shakeExtras ide) initConfig pure $ Right (env,ide) diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index bdd3ab222d..b3c7457275 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -51,7 +51,8 @@ descriptor plId = (defaultPluginDescriptor plId desc) gotoTypeDefinition ide TextDocumentPositionParams{..}) <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> documentHighlight ide TextDocumentPositionParams{..}) - <> mkPluginHandler SMethod_TextDocumentReferences references, + <> mkPluginHandler SMethod_TextDocumentReferences references + <> mkPluginHandler SMethod_WorkspaceSymbol wsSymbols, pluginConfigDescriptor = defaultConfigDescriptor } diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs index e4a47838aa..a980efc12d 100644 --- a/ghcide/test/exe/InitializeResponseTests.hs +++ b/ghcide/test/exe/InitializeResponseTests.hs @@ -47,7 +47,7 @@ tests = withResource acquire release tests where , chk " find references" _referencesProvider (Just $ InR (ReferenceOptions (Just False))) , chk " doc highlight" _documentHighlightProvider (Just $ InR (DocumentHighlightOptions (Just False))) , chk " doc symbol" _documentSymbolProvider (Just $ InR (DocumentSymbolOptions (Just False) Nothing)) - -- , chk " workspace symbol" _workspaceSymbolProvider (Just $ InR (WorkspaceSymbolOptions (Just False) (Just False))) + , chk " workspace symbol" _workspaceSymbolProvider (Just $ InR (WorkspaceSymbolOptions (Just False) (Just False))) , chk "NO code action" _codeActionProvider Nothing , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just True)) , chk "NO doc formatting" _documentFormattingProvider Nothing From e4b746dd4b8f20fc9ad597e77f91f79aba2df94f Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 14 Apr 2024 00:14:30 +0800 Subject: [PATCH 34/34] fix up cradle test --- haskell-language-server.cabal | 1 + hls-test-utils/src/Test/Hls.hs | 8 +- .../hls-core-plugin/src/Ide/Plugin/Core.hs | 30 +++---- .../hls-core-plugin/test/exe/CradleTests.hs | 82 ++++++++----------- plugins/hls-core-plugin/test/exe/Util.hs | 11 ++- .../multi-unit-reexport/a-1.0.0-inplace | 18 ++++ .../test/testdata/multi-unit-reexport/a/A.hs | 3 + .../multi-unit-reexport/b-1.0.0-inplace | 21 +++++ .../test/testdata/multi-unit-reexport/b/B.hs | 3 + .../multi-unit-reexport/c-1.0.0-inplace | 19 +++++ .../test/testdata/multi-unit-reexport/c/C.hs | 4 + .../multi-unit-reexport/cabal.project | 2 + .../testdata/multi-unit-reexport/hie.yaml | 6 ++ .../test/testdata/multi-unit/a-1.0.0-inplace | 18 ++++ .../test/testdata/multi-unit/a/A.hs | 3 + .../test/testdata/multi-unit/b-1.0.0-inplace | 19 +++++ .../test/testdata/multi-unit/b/B.hs | 3 + .../test/testdata/multi-unit/c-1.0.0-inplace | 19 +++++ .../test/testdata/multi-unit/c/C.hs | 3 + .../test/testdata/multi-unit/cabal.project | 2 + .../test/testdata/multi-unit/hie.yaml | 6 ++ 21 files changed, 207 insertions(+), 74 deletions(-) create mode 100644 plugins/hls-core-plugin/test/testdata/multi-unit-reexport/a-1.0.0-inplace create mode 100644 plugins/hls-core-plugin/test/testdata/multi-unit-reexport/a/A.hs create mode 100644 plugins/hls-core-plugin/test/testdata/multi-unit-reexport/b-1.0.0-inplace create mode 100644 plugins/hls-core-plugin/test/testdata/multi-unit-reexport/b/B.hs create mode 100644 plugins/hls-core-plugin/test/testdata/multi-unit-reexport/c-1.0.0-inplace create mode 100644 plugins/hls-core-plugin/test/testdata/multi-unit-reexport/c/C.hs create mode 100644 plugins/hls-core-plugin/test/testdata/multi-unit-reexport/cabal.project create mode 100644 plugins/hls-core-plugin/test/testdata/multi-unit-reexport/hie.yaml create mode 100644 plugins/hls-core-plugin/test/testdata/multi-unit/a-1.0.0-inplace create mode 100644 plugins/hls-core-plugin/test/testdata/multi-unit/a/A.hs create mode 100644 plugins/hls-core-plugin/test/testdata/multi-unit/b-1.0.0-inplace create mode 100644 plugins/hls-core-plugin/test/testdata/multi-unit/b/B.hs create mode 100644 plugins/hls-core-plugin/test/testdata/multi-unit/c-1.0.0-inplace create mode 100644 plugins/hls-core-plugin/test/testdata/multi-unit/c/C.hs create mode 100644 plugins/hls-core-plugin/test/testdata/multi-unit/cabal.project create mode 100644 plugins/hls-core-plugin/test/testdata/multi-unit/hie.yaml diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index a6f8a011d0..dd9dcb61fd 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1775,6 +1775,7 @@ test-suite hls-core-plugin-tests build-depends: , aeson , base + , async , containers , filepath , haskell-language-server:hls-core-plugin diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index b4d8a02687..bdef34367f 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -426,7 +426,7 @@ class TestRunner cont res where -- Do not clean up the temporary directory if this variable is set to anything but '0'. -- Aids debugging. cleanupTempDir <- lookupEnv "HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP" - let runTestInDir action = do + let runSessionInDir action = do (tempDir', cleanup) <- newTempDirWithin testRoot tempDir <- canonicalizePath tempDir' case cleanupTempDir of @@ -440,12 +440,9 @@ class TestRunner cont res where logWith recorder Debug LogCleanup pure a - runTestInDir $ \tmpDir -> do + runSessionInDir $ \tmpDir -> do logWith recorder Info $ LogTestDir tmpDir - print tmpDir - print "before" fs <- FS.materialiseVFT tmpDir tree - print "after" runSessionWithServer' plugins conf sessConf caps tmpDir (contToSessionRes fs act) contToSessionRes :: FileSystem -> cont -> Session res @@ -668,6 +665,7 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurr putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" pure x + -- | Wait for the next progress end step waitForProgressDone :: Session () waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case diff --git a/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs b/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs index 7ad26a2859..08830864de 100644 --- a/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs +++ b/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs @@ -38,21 +38,21 @@ instance Pretty CoreLog where descriptor :: Recorder (WithPriority CoreLog) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = - (defaultPluginDescriptor plId "Provides core IDE features for Haskell") - { - Ide.Types.pluginHandlers = - mkPluginHandler SMethod_TextDocumentDocumentSymbol moduleOutline - <> mkPluginHandler SMethod_TextDocumentDefinition (\ide _ DefinitionParams{..} -> - gotoDefinition ide TextDocumentPositionParams{..}) - <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} -> - gotoTypeDefinition ide TextDocumentPositionParams{..}) - <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> - documentHighlight ide TextDocumentPositionParams{..}) - <> mkPluginHandler SMethod_TextDocumentHover hover' - <> mkPluginHandler SMethod_WorkspaceSymbol (wsSymbols recorder) - <> mkPluginHandler SMethod_TextDocumentReferences references - } +descriptor _recorder plId = + defaultPluginDescriptor plId "Provides core IDE features for Haskell" + -- { + -- Ide.Types.pluginHandlers = + -- mkPluginHandler SMethod_TextDocumentDocumentSymbol moduleOutline + -- <> mkPluginHandler SMethod_TextDocumentDefinition (\ide _ DefinitionParams{..} -> + -- gotoDefinition ide TextDocumentPositionParams{..}) + -- <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} -> + -- gotoTypeDefinition ide TextDocumentPositionParams{..}) + -- <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> + -- documentHighlight ide TextDocumentPositionParams{..}) + -- <> mkPluginHandler SMethod_TextDocumentHover hover' + -- <> mkPluginHandler SMethod_WorkspaceSymbol (wsSymbols recorder) + -- <> mkPluginHandler SMethod_TextDocumentReferences references + -- } wsSymbols :: Recorder (WithPriority CoreLog) -> PluginMethodHandler IdeState Method_WorkspaceSymbol diff --git a/plugins/hls-core-plugin/test/exe/CradleTests.hs b/plugins/hls-core-plugin/test/exe/CradleTests.hs index 7799cc9c34..a632329c91 100644 --- a/plugins/hls-core-plugin/test/exe/CradleTests.hs +++ b/plugins/hls-core-plugin/test/exe/CradleTests.hs @@ -11,12 +11,6 @@ import Control.Monad.IO.Class (liftIO) import Data.Row import qualified Data.Text as T import Development.IDE.GHC.Compat (GhcVersion (..)) -import Development.IDE.GHC.Util --- import Development.IDE.Test (expectDiagnostics, --- expectDiagnosticsWithTags, --- expectNoMoreDiagnostics, --- isReferenceReady, --- waitForAction) import Development.IDE.Types.Location import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -29,6 +23,7 @@ import Language.LSP.Test import System.FilePath import System.IO.Extra hiding (withTempDir) -- import Test.QuickCheck.Instances () +import Control.Concurrent.Async (wait, withAsync) import Control.Lens ((^.)) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) import GHC.TypeLits (symbolVal) @@ -44,8 +39,8 @@ import Test.Tasty import Test.Tasty.HUnit import Util (checkDefs, expectDiagnostics, expectDiagnosticsWithTags, + expectNoDiagnostic, isReferenceReady, mkFs, mkL, - runSessionWithCorePluginNoVsf, runSessionWithServerCorePlugin, testSessionWithCorePlugin, testSessionWithCorePluginEmptyVsf, @@ -136,7 +131,9 @@ simpleSubDirectoryTest = multiTests :: FilePath -> [TestTree] multiTests dir = - [simpleMultiTest dir, simpleMultiTest2 dir, simpleMultiTest3 dir, simpleMultiDefTest dir] + [simpleMultiTest dir, simpleMultiTest2 dir, simpleMultiTest3 dir +-- simpleMultiDefTest dir + ] multiTestName :: FilePath -> String -> String multiTestName dir name = "simple-" ++ dir ++ "-" ++ name @@ -154,8 +151,6 @@ simpleMultiTest variant = testSessionWithCorePluginSubDir (multiTestName variant locs <- getDefinitions bdoc (Position 2 7) let fooL = mkL (adoc ^. L.uri) 2 0 2 3 checkDefs locs (pure [fooL]) - -- diags <- captureKickDiagnostics - -- liftIO $ assertBool "Expecting no warning" $ null diags -- Like simpleMultiTest but open the files in the other order simpleMultiTest2 :: FilePath -> TestTree @@ -164,13 +159,12 @@ simpleMultiTest2 variant = testSessionWithCorePluginSubDir (multiTestName varian bPath = "b/B.hs" bdoc <- openDoc bPath "haskell" WaitForIdeRuleResult {} <- handleEither $ waitForAction "TypeCheck" bdoc - TextDocumentIdentifier auri <- openDoc aPath "haskell" + adoc@(TextDocumentIdentifier auri) <- openDoc aPath "haskell" skipManyTill anyMessage $ isReferenceReady (toAbsFp fs aPath) locs <- getDefinitions bdoc (Position 2 7) let fooL = mkL auri 2 0 2 3 checkDefs locs (pure [fooL]) - -- diags <- captureKickDiagnostics - -- liftIO $ assertBool "Expecting no warning" $ null diags + expectNoDiagnostic [adoc, bdoc] -- Now with 3 components simpleMultiTest3 :: FilePath -> TestTree @@ -181,36 +175,36 @@ simpleMultiTest3 variant = cPath = "c/C.hs" bdoc <- openDoc bPath "haskell" WaitForIdeRuleResult {} <- handleEither $ waitForAction "TypeCheck" bdoc - TextDocumentIdentifier auri <- openDoc aPath "haskell" + adoc@(TextDocumentIdentifier auri) <- openDoc aPath "haskell" skipManyTill anyMessage $ isReferenceReady (toAbsFp fs aPath) cdoc <- openDoc cPath "haskell" WaitForIdeRuleResult {} <- handleEither $ waitForAction "TypeCheck" cdoc locs <- getDefinitions cdoc (Position 2 7) let fooL = mkL auri 2 0 2 3 checkDefs locs (pure [fooL]) - -- diags <- captureKickDiagnostics - -- liftIO $ assertBool "Expecting no warning" $ null diags - - --- Like simpleMultiTest but open the files in component 'a' in a separate session -simpleMultiDefTest :: FilePath -> TestTree -simpleMultiDefTest variant = testSessionWithCorePluginSubDir (multiTestName variant "def-test") variant $ \fs -> do - let aPath = "a/A.hs" - bPath = "b/B.hs" - aAbsPath = toAbsFp fs aPath - rootAbs = toAbsFp fs "" - adoc <- liftIO $ runSessionWithServerCorePlugin rootAbs $ do - adoc <- openDoc aAbsPath "haskell" - -- skipManyTill anyMessage $ isReferenceReady $ aAbsPath - -- closeDoc adoc - pure adoc - bdoc <- openDoc bPath "haskell" - -- locs <- getDefinitions bdoc (Position 2 7) - -- let fooL = mkL (adoc ^. L.uri) 2 0 2 3 - -- checkDefs locs (pure [fooL]) - -- diags <- captureKickDiagnostics - -- liftIO $ assertBool "Expecting no warning" $ null diags - return () + expectNoDiagnostic [adoc, cdoc, bdoc] + + +-- todo add back this when we have a way to open a file in a separate session in the same test +-- -- Like simpleMultiTest but open the files in component 'a' in a separate session +-- simpleMultiDefTest :: FilePath -> TestTree +-- simpleMultiDefTest variant = do +-- testSessionWithCorePluginSubDir (multiTestName variant "def-test") variant $ \fs -> do +-- let aPath = "a/A.hs" +-- bPath = "b/B.hs" +-- aAbsPath = toAbsFp fs aPath +-- rootAbs = toAbsFp fs "" +-- -- should share the same session +-- -- adoc <- liftIO $ withAsync (runSessionWithServerCorePlugin rootAbs $ do +-- -- doc <- openDoc aAbsPath "haskell" +-- -- skipManyTill anyMessage $ isReferenceReady $ aAbsPath +-- -- return doc) (\t1 -> wait t1) +-- let adoc = TextDocumentIdentifier $ filePathToUri aAbsPath +-- bdoc <- openDoc bPath "haskell" +-- locs <- getDefinitions bdoc (Position 2 7) +-- let fooL = mkL (adoc ^. L.uri) 2 0 2 3 +-- checkDefs locs (pure [fooL]) +-- expectNoDiagnostic [adoc, bdoc] multiRexportTest :: TestTree multiRexportTest = @@ -222,8 +216,7 @@ multiRexportTest = let aPath = "a/A.hs" let fooL = mkL (filePathToUri aPath) 2 0 2 3 checkDefs locs (pure [fooL]) - -- diags <- captureKickDiagnostics - -- liftIO $ assertBool "Expecting no warning" $ null diags + expectNoDiagnostic [cdoc] sessionDepsArePickedUp :: TestTree sessionDepsArePickedUp = testSessionWithCorePlugin @@ -245,19 +238,8 @@ sessionDepsArePickedUp = testSessionWithCorePlugin .+ #text .== "\n" changeDoc doc [change] expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])] - return () where - fooContent2 = - unlines - [ "module Foo where", - "import Data.Text", - "foo :: Text", - "", - "foo = \"hello\"", - "x=1" - ] - fooContent = T.unlines [ "module Foo where", diff --git a/plugins/hls-core-plugin/test/exe/Util.hs b/plugins/hls-core-plugin/test/exe/Util.hs index 2407df834f..55b2c3be14 100644 --- a/plugins/hls-core-plugin/test/exe/Util.hs +++ b/plugins/hls-core-plugin/test/exe/Util.hs @@ -42,11 +42,12 @@ import Language.LSP.Protocol.Types (Definition (..), toNormalizedUri, type (|?) (InL, InR), uriToFilePath) -import Language.LSP.Test (Session, sendRequest) +import qualified Language.LSP.Protocol.Types as L +import Language.LSP.Test (Session, getCurrentDiagnostics, + sendRequest) import qualified Language.LSP.Test as LspTest import System.Directory.Extra (canonicalizePath) import System.FilePath (equalFilePath, ()) -import System.Info.Extra import System.Time.Extra (Seconds, sleep) import Test.Hls (FromServerMessage' (..), Method (Method_TextDocumentPublishDiagnostics), @@ -57,7 +58,6 @@ import Test.Hls (FromServerMessage' (..), TServerMessage, TestName, TestRunner, TestTree, assertBool, expectFailBecause, getDocUri, - ignoreTestBecause, mkPluginTestDescriptor, runSessionWithServer, runSessionWithServerInTmpDir, @@ -367,4 +367,7 @@ requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) - +expectNoDiagnostic :: HasCallStack => [L.TextDocumentIdentifier] -> Session () +expectNoDiagnostic xs = do + diags <- fmap concat $ traverse getCurrentDiagnostics xs + liftIO $ assertBool "Expecting no diags" $ null diags diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/a-1.0.0-inplace b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/a-1.0.0-inplace new file mode 100644 index 0000000000..a54ea9bc4b --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/a-1.0.0-inplace @@ -0,0 +1,18 @@ +-this-package-name +a +-working-dir +a +-fbuilding-cabal-package +-O0 +-i. +-this-unit-id +a-1.0.0-inplace +-hide-all-packages +-Wmissing-home-modules +-no-user-package-db +-package +base +-package +text +-XHaskell98 +A diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/a/A.hs b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/a/A.hs new file mode 100644 index 0000000000..9a7d7e33c9 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/a/A.hs @@ -0,0 +1,3 @@ +module A(foo) where +import Data.Text +foo = () diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/b-1.0.0-inplace b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/b-1.0.0-inplace new file mode 100644 index 0000000000..d656a2539b --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/b-1.0.0-inplace @@ -0,0 +1,21 @@ +-this-package-name +b +-working-dir +b +-fbuilding-cabal-package +-O0 +-i +-i. +-this-unit-id +b-1.0.0-inplace +-hide-all-packages +-Wmissing-home-modules +-no-user-package-db +-package-id +a-1.0.0-inplace +-reexported-module +A +-package +base +-XHaskell98 +B diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/b/B.hs b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/b/B.hs new file mode 100644 index 0000000000..2c6d4b28a2 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/b/B.hs @@ -0,0 +1,3 @@ +module B(module B) where +import A +qux = foo diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/c-1.0.0-inplace b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/c-1.0.0-inplace new file mode 100644 index 0000000000..e60a95eda0 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/c-1.0.0-inplace @@ -0,0 +1,19 @@ +-this-package-name +c +-working-dir +c +-fbuilding-cabal-package +-O0 +-i +-i. +-this-unit-id +c-1.0.0-inplace +-hide-all-packages +-Wmissing-home-modules +-no-user-package-db +-package-id +b-1.0.0-inplace +-package +base +-XHaskell98 +C diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/c/C.hs b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/c/C.hs new file mode 100644 index 0000000000..1b2d305296 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/c/C.hs @@ -0,0 +1,4 @@ +module C(module C) where +import A +import B +cux = foo `seq` qux diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/cabal.project b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/cabal.project new file mode 100644 index 0000000000..96f52330c9 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/cabal.project @@ -0,0 +1,2 @@ +packages: a b c +multi-repl: True diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/hie.yaml b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/hie.yaml new file mode 100644 index 0000000000..34858b5f64 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/hie.yaml @@ -0,0 +1,6 @@ +cradle: + direct: + arguments: ["-unit" ,"@a-1.0.0-inplace" + ,"-unit" ,"@b-1.0.0-inplace" + ,"-unit" ,"@c-1.0.0-inplace" + ] diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit/a-1.0.0-inplace b/plugins/hls-core-plugin/test/testdata/multi-unit/a-1.0.0-inplace new file mode 100644 index 0000000000..a54ea9bc4b --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit/a-1.0.0-inplace @@ -0,0 +1,18 @@ +-this-package-name +a +-working-dir +a +-fbuilding-cabal-package +-O0 +-i. +-this-unit-id +a-1.0.0-inplace +-hide-all-packages +-Wmissing-home-modules +-no-user-package-db +-package +base +-package +text +-XHaskell98 +A diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit/a/A.hs b/plugins/hls-core-plugin/test/testdata/multi-unit/a/A.hs new file mode 100644 index 0000000000..9a7d7e33c9 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit/a/A.hs @@ -0,0 +1,3 @@ +module A(foo) where +import Data.Text +foo = () diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit/b-1.0.0-inplace b/plugins/hls-core-plugin/test/testdata/multi-unit/b-1.0.0-inplace new file mode 100644 index 0000000000..b08c50c1ce --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit/b-1.0.0-inplace @@ -0,0 +1,19 @@ +-this-package-name +b +-working-dir +b +-fbuilding-cabal-package +-O0 +-i +-i. +-this-unit-id +b-1.0.0-inplace +-hide-all-packages +-Wmissing-home-modules +-no-user-package-db +-package-id +a-1.0.0-inplace +-package +base +-XHaskell98 +B diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit/b/B.hs b/plugins/hls-core-plugin/test/testdata/multi-unit/b/B.hs new file mode 100644 index 0000000000..2c6d4b28a2 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit/b/B.hs @@ -0,0 +1,3 @@ +module B(module B) where +import A +qux = foo diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit/c-1.0.0-inplace b/plugins/hls-core-plugin/test/testdata/multi-unit/c-1.0.0-inplace new file mode 100644 index 0000000000..7201a40de4 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit/c-1.0.0-inplace @@ -0,0 +1,19 @@ +-this-package-name +c +-working-dir +c +-fbuilding-cabal-package +-O0 +-i +-i. +-this-unit-id +c-1.0.0-inplace +-hide-all-packages +-Wmissing-home-modules +-no-user-package-db +-package-id +a-1.0.0-inplace +-package +base +-XHaskell98 +C diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit/c/C.hs b/plugins/hls-core-plugin/test/testdata/multi-unit/c/C.hs new file mode 100644 index 0000000000..b75a7fc3c7 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit/c/C.hs @@ -0,0 +1,3 @@ +module C(module C) where +import A +cux = foo diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit/cabal.project b/plugins/hls-core-plugin/test/testdata/multi-unit/cabal.project new file mode 100644 index 0000000000..96f52330c9 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit/cabal.project @@ -0,0 +1,2 @@ +packages: a b c +multi-repl: True diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit/hie.yaml b/plugins/hls-core-plugin/test/testdata/multi-unit/hie.yaml new file mode 100644 index 0000000000..34858b5f64 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit/hie.yaml @@ -0,0 +1,6 @@ +cradle: + direct: + arguments: ["-unit" ,"@a-1.0.0-inplace" + ,"-unit" ,"@b-1.0.0-inplace" + ,"-unit" ,"@c-1.0.0-inplace" + ]