diff --git a/.github/workflows/hackage.yml b/.github/workflows/hackage.yml index d7d26b9cef..09785cce48 100644 --- a/.github/workflows/hackage.yml +++ b/.github/workflows/hackage.yml @@ -21,7 +21,7 @@ jobs: "hls-splice-plugin", "hls-tactics-plugin", "hls-call-hierarchy-plugin", "haskell-language-server"] - ghc: ["8.10.7", "8.8.4", "8.6.5"] + ghc: ["9.0.1", "8.10.7", "8.8.4", "8.6.5"] steps: @@ -119,6 +119,7 @@ jobs: path: ${{ steps.generate-dist-tarball.outputs.path }} upload-candidate: + if: ${{ !contains(github.head_ref, 'check') }} needs: check-and-upload-tarballs runs-on: ubuntu-latest steps: diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 70145d7851..ce5f809305 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -4,6 +4,11 @@ defaults: run: shell: bash +# See: https://docs.github.com/en/actions/reference/workflow-syntax-for-github-actions#concurrency. +concurrency: + group: ${{ github.head_ref }}-${{ github.workflow }} + cancel-in-progress: true + on: pull_request: branches: @@ -19,19 +24,14 @@ jobs: - id: skip_check uses: fkirc/skip-duplicate-actions@v3.4.0 with: - cancel_others: true - paths_ignore: '["**/docs/**", "**.md", "**/LICENSE", "install/**", "**.nix", "flake.lock", "**/README.md", "FUNDING.yml"]' + cancel_others: false + paths_ignore: '["**/docs/**", "**.md", "**/LICENSE", "install/**", "**.nix", "flake.lock", "**/README.md", "FUNDING.yml", ".circleci/**"]' # If we only change ghcide downstream packages we have not test ghcide itself - id: skip_ghcide_check uses: fkirc/skip-duplicate-actions@v3.4.0 with: + cancel_others: false paths_ignore: '["hls-test-utils/**", "plugins/**", "src/**", "exe/**", "test/**", "shake-bench/**"]' - - if: steps.skip_check.outputs.should_skip == 'true' - name: Skip circleci - uses: marocchino/sticky-pull-request-comment@v2 - with: - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - message: We are gonna [skip circleci] test: if: needs.pre_job.outputs.should_skip != 'true' @@ -148,7 +148,7 @@ jobs: # run the tests without parallelism to avoid running out of memory run: cabal test ghcide --test-options="-j1 --rerun-update" || cabal test ghcide --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test ghcide --test-options="-j1 --rerun" - - if: matrix.test && !(matrix.os == 'windows-latest' && matrix.ghc == '9.0.1') + - if: matrix.test name: Test func-test suite env: HLS_TEST_EXE: hls diff --git a/cabal-ghc901.project b/cabal-ghc901.project index f8c6e9caa0..ebd06a33a5 100644 --- a/cabal-ghc901.project +++ b/cabal-ghc901.project @@ -58,8 +58,8 @@ write-ghc-environment-files: never index-state: 2021-10-04T02:41:06Z constraints: - -- These plugins don't work on GHC9 yet - haskell-language-server -brittany -class -stylishhaskell -tactic + -- These plugins don't work on GHC9 yet + haskell-language-server +ignore-plugins-ghc-bounds -brittany -class -stylishhaskell -tactic allow-newer: floskell:base, diff --git a/cabal-ghc921.project b/cabal-ghc921.project index dc6f41ec17..9006511319 100644 --- a/cabal-ghc921.project +++ b/cabal-ghc921.project @@ -54,9 +54,8 @@ write-ghc-environment-files: never index-state: 2021-09-29T21:38:47Z constraints: - -- These plugins doesn't work on GHC9 yet - haskell-language-server -brittany -class -fourmolu -splice -stylishhaskell -tactic -refineImports -callhierarchy -retrie - + -- These plugins doesn't work on GHC92 yet + haskell-language-server +ignore-plugins-ghc-bounds -brittany -class -fourmolu -splice -stylishhaskell -tactic -refineImports -callhierarchy -retrie allow-newer: Cabal, diff --git a/docs/configuration.md b/docs/configuration.md index f59a66bbcf..3e1d719a76 100644 --- a/docs/configuration.md +++ b/docs/configuration.md @@ -21,14 +21,14 @@ For example, there are protocol methods for highlighting matching identifiers th This is a capability which any server can implement, so the client can decide generically whether to ask the server to do it or not. So your editor can provide a setting to turn this on or off globally, for any language server you might use. -Settings like this are typically provided by the generic LSP client support for your editor, for example in Emacs by [`lsp-mode`](https://github.com/emacs-lsp/lsp-mode). +Settings like this are typically provided by the generic LSP client support for your editor, for example in Emacs by [lsp-mode](https://github.com/emacs-lsp/lsp-mode). ### Generic editor options Your editor may provide some settings that affect how the information from the language server is used. For example, whether popups are shown, or whether code lenses appear by default. -Settings like this are typically provided by the generic LSP client support for your editor, for example in Emacs by [`lsp-mode`](https://github.com/emacs-lsp/lsp-mode). +Settings like this are typically provided by the generic LSP client support for your editor, for example in Emacs by [lsp-mode](https://github.com/emacs-lsp/lsp-mode). ### Language-specific server options @@ -48,7 +48,7 @@ Here is a list of the additional settings currently supported by `haskell-langua - Hlint (`haskell.hlintOn`, default true): whether to enable Hlint support. *Deprecated* as it is equivalen to `haskell.plugin.hlint.globalOn` - Max completions (`haskell.maxCompletions`, default 40): maximum number of completions sent to the LSP client. - Check project (`haskell.checkProject`, default true): whether to typecheck the entire project on load. As it is activated by default could drive to bad perfomance in large projects. -- Check parents (`haskell.checkParents`, default `CheckOnSaveAndClose`): when to typecheck reverse dependencies of a file; one of `NeverCheck`, `CheckOnClose`, `CheckOnSaveAndClose`, or `AlwaysCheck`. +- Check parents (`haskell.checkParents`, default `CheckOnSaveAndClose`): when to typecheck reverse dependencies of a file; one of `NeverCheck`, `CheckOnClose`, `CheckOnSaveAndClose`, or `AlwaysCheck`. #### Generic plugin configuration @@ -57,7 +57,7 @@ Plugins have a generic config to control their behaviour. The schema of such con - `haskell.plugin.${pluginName}.globalOn`: usually with default true. Whether the plugin is enabled at runtime or it is not. That is the option you might use if you want to disable completely a plugin. - Actual plugin names are: `ghcide-code-actions-fill-holes`, `ghcide-completions`, `ghcide-hover-and-symbols`, `ghcide-type-lenses`, `ghcide-code-actions-type-signatures`, `ghcide-code-actions-bindings`, `ghcide-code-actions-imports-exports`, `eval`, `moduleName`, `pragmas`, `refineImports`, `importLens`, `class`, `tactics` (aka wingman), `hlint`, `haddockComments`, `retrie`, `splice`. - So to disable the import lens with an explicit list of module definitions you could set `haskell.plugin.importLens.globalOn: false` -- `haskell.plugin.${pluginName}.${lspCapability}On`: usually with default true. Whether a concrete plugin capability is enabled. +- `haskell.plugin.${pluginName}.${lspCapability}On`: usually with default true. Whether a concrete plugin capability is enabled. - Capabilities are the different ways a lsp server can interact with the editor. The current available capabilities of the server are: `callHierarchy`, `codeActions`, `codeLens`, `diagnostics`, `hover`, `symbols`, `completion`, `rename`. - Note that usually plugins don't provide all capabilities but some of them or even only one. - So to disable code changes suggestions from the `hlint` plugin (but no diagnostics) you could set `haskell.plugin.hlint.codeActionsOn: false` @@ -78,7 +78,7 @@ Plugins have a generic config to control their behaviour. The schema of such con This reference of configuration can be outdated at any time but we can query the `haskell-server-executable` about what configuration is effectively used: - `haskell-language-server generate-default-config`: will print the json configuration with all default values. It can be used as template to modify it. - `haskell-language-server vscode-extension-schema`: will print a json schema used to setup the haskell vscode extension. But it is useful to see what range of values can an option take and a description about it. - + Settings like this are typically provided by the language-specific LSP client support for your editor, for example in Emacs by `lsp-haskell`. ### Client options @@ -90,11 +90,11 @@ Settings like this are typically be provided by the language-specific LSP client ## Configuring your project build `haskell-language-server` has to compile your project in order to give you diagnostics, which means that it needs to know how to do so. -This is handled by the [`hie-bios`](https://github.com/mpickering/hie-bios) project. +This is handled by the [hie-bios](https://github.com/mpickering/hie-bios) project. -**For a full explanation of how `hie-bios` determines the project build configuration, and how to configure it manually, refer to the [`hie-bios` README](https://github.com/mpickering/hie-bios/blob/master/README.md).** +**For a full explanation of how `hie-bios` determines the project build configuration, and how to configure it manually, refer to the [hie-bios README](https://github.com/mpickering/hie-bios/blob/master/README.md).** -At the moment, `haskell-language-server` has support to automatically detect your project build configuration to handle most use cases. +At the moment, `haskell-language-server` has support to automatically detect your project build configuration to handle most use cases. *So using a explicit `hie.yaml` file will not likely fix your ide setup*. It will do it almost only if you see an error like `Multi Cradle: No prefixes matched` @@ -104,7 +104,7 @@ For that you need to know what *components* your project has, and the path assoc So you will need some knowledge about [stack](https://docs.haskellstack.org/en/stable/build_command/#components) or [cabal](https://cabal.readthedocs.io/en/latest/cabal-commands.html?#cabal-v2-build) components. -You also can use [this utility](https://github.com/Avi-D-coder/implicit-hie) to automatically generate `hie.yaml` files for +You also can use [implicit-hie](https://github.com/Avi-D-coder/implicit-hie) to automatically generate `hie.yaml` files for the most common stack and cabal configurations For example, to state that you want to use `stack` then the configuration file @@ -351,7 +351,7 @@ it may also be helpful to also specify root markers: let g:LanguageClient_rootMarkers = ['*.cabal', 'stack.yaml'] ``` -Further configuration can be done by pointing the [`g:LanguageClient_settingsPath`](https://github.com/autozimu/LanguageClient-neovim/blob/0e5c9546bfddbaa2b01e5056389c25aefc8bf989/doc/LanguageClient.txt#L221) +Further configuration can be done by pointing the `g:LanguageClient_settingsPath` [option](https://github.com/autozimu/LanguageClient-neovim/blob/0e5c9546bfddbaa2b01e5056389c25aefc8bf989/doc/LanguageClient.txt#L221) variable to the file in which you want to keep your LSP settings. ### Atom diff --git a/docs/contributing/contributing.md b/docs/contributing/contributing.md index 486eff39b7..937a4ba414 100644 --- a/docs/contributing/contributing.md +++ b/docs/contributing/contributing.md @@ -10,7 +10,7 @@ The Haskell tooling dream is near, we need your help! - Join the [haskell-tooling channel](https://matrix.to/#/#haskell-tooling:matrix.org) in [matrix](https://matrix.org/). - Visit [the project GitHub repo](https://github.com/haskell/haskell-language-server) to view the source code, or open issues or pull requests. -## Building haskell-language-server +## Building Clone the repository: ```shell @@ -19,26 +19,18 @@ $ git clone https://github.com/haskell/haskell-language-server The project can then be built with both `cabal build` and `stack build`. -haskell-language-server can also be used with itself. We provide preset samples of `hie.yaml` for Cabal and Stack. - -Note: the `./install/` folder is not directly tied to the project so it has dedicated `./install/hie.yaml.[cbl|stack]` -templates. - ### Using Cabal ```shell -$ cp hie-cabal.yaml hie.yaml -$ cp install/hie-cabal.yaml install/hie.yaml +# If you have not run `cabal update` in a while +$ cabal update +# Then +$ cabal build ``` ### Using Stack ```shell -$ cp hie-stack.yaml hie.yaml -$ cp install/hie-stack.yaml install/hie.yaml -$ cp ghcide/hie-stack.yaml ghcide/hie.yaml -$ stack build --test --no-run-tests -$ cd install $ stack build ``` @@ -119,26 +111,39 @@ An alternative, which only recompiles when tests (or dependencies) change: $ cabal run haskell-language-server:func-test -- -p "hlint enables" ``` -### Test your hacked HLS in your editor +## Using HLS on HLS code + +[HLS project configuration guidelines](../configuration.md#configuring-your-project-build) also apply to the HLS project itself. + +Note: HLS implicitly detects HLS codebase as a Stack project (see [hie-bios implicit configuration documentation](https://github.com/haskell/hie-bios/blob/master/README.md#implicit-configuration)). +If you want HLS to use Cabal, you need to create an `hie.yaml` file: +```yaml +cradle: + cabal: +``` + +Also note that the `install/` subdirectory is a different project, so if you want to work on this part of the code, you may also have to create an `install/hie.yaml` file. +### Manually testing your hacked HLS If you want to test HLS while hacking on it, follow the steps below. To do once: -- Open some codebase on which you want to test your hacked HLS in your favorite editor +- Open some codebase on which you want to test your hacked HLS in your favorite editor (it can also be HLS codebase itself: see previous section for configuration) - Configure this editor to use your custom HLS executable - With Cabal: - On Unix systems: `cabal exec which haskell-language-server` - On Windows: `cabal exec where haskell-language-server` - With Stack: `$(stack path --dist-dir)/build/haskell-language-server/haskell-language-server` -To do every time you changed code and want to test it: +To do every time you change HLS code and want to test it: - Build HLS - With Cabal: `cabal build exe:haskell-language-server` - With Stack: `stack build haskell-language-server:exe:haskell-language-server` - Restart HLS - With VS Code: `Haskell: Restart Haskell LSP Server` + - With Emacs: `lsp-workspace-restart` ## Style guidelines diff --git a/docs/troubleshooting.md b/docs/troubleshooting.md index 7c67896027..2360caf4d1 100644 --- a/docs/troubleshooting.md +++ b/docs/troubleshooting.md @@ -21,19 +21,30 @@ Example with `tasty-discover`: This returns an error in HLS if 'tasty-discover' is not in the path: `could not execute: tasty-discover`. -## Common issues - -### Difficulties with Stack and `Paths_` modules +### Problems with multi component (tests suites, executables, benchmarks) support using stack -These are known to be somewhat buggy at the moment: . -This issue should be fixed in Stack versions >= 2.5. +Due to some limitations in the interaction between HLS and stack, there are some issues in projects with a main library and executables, test suites or benchmarks: +- The stack project has to be built succesfully *before* loading it with HLS to get components other than the library work. +- Changes in the library are not automatically propagated to other components, especially in the presence of errors in the library, so you have to restart HLS to get those components correctly loaded. The usual symptom is the editor showing errors like `Could not load module ...` or `Cannot satisfy -package ...` +- See https://github.com/haskell/haskell-language-server/issues/366 for more info about. +## Common issues ### Problems with dynamic linking As haskell-language-server prebuilt binaries are statically linked, they don't play well with projects using dynamic linking. An usual symptom is the presence of errors containing `unknown symbol` and it is typical in arch linux, where a dynamically linked version of ghc is used. -The workaround is to use a version of haskell-language-server compiled from source with `-dynamic` enabled`. See more details [here](https://github.com/haskell/haskell-language-server/issues/1160#issuecomment-756566273). +The workaround is to use a version of haskell-language-server compiled from source with the ghc option `-dynamic` enabled. See more details [here](https://github.com/haskell/haskell-language-server/issues/1160#issuecomment-756566273). + +### Problems with Template Haskell + +Due to how Template Haskell code is evaluated at compile time and some limitations in the interaction between HLS and GHC, the loading of modules using TH can be problematic. + +The errors thrown are usually related to linking and usually make HLS crash: `Segmentation fault`, `GHC runtime linker: fatal error`, etc + +A workaround which has helped in some cases is to compile HLS from source with the ghc option `-dynamic` enabled, as in the previous issue. + +We have a [dedicated label](https://github.com/haskell/haskell-language-server/issues?q=is%3Aissue+is%3Aopen+label%3A%22type%3A+template+haskell+related%22) in the issue tracker and an [general issue](https://github.com/haskell/haskell-language-server/issues/1431) tracking support for TH. ## Troubleshooting the server @@ -56,11 +67,17 @@ sent, or if there are any errors. To get a more verbose, also pass `--debug` to the executable. +### Identify which plugin could be the cause of the issue. + +Sometimes the issue is produced by one of the plugins included in HLS. To diagnose that and help to trace the final cause one possible strategy is simple disable all plugins, check if the issue is gone and then enable them selectively until the issue is reproduced again. + +There is a configuration json snippet which disables all plugins [here](https://github.com/haskell/haskell-language-server/issues/2151#issuecomment-911397030). + ## Troubleshooting the client Many clients provide diagnostic information about a LSP session. In particular, look for a way to get the status of the server, the server stderr, or a log of the messages that the client has sent to the server. For example, `lsp-mode` provides all of these (see its [troubleshooting page](https://emacs-lsp.github.io/lsp-mode/page/troubleshooting/) for details). +For vscode you can read how to access the lsp session log [here])https://github.com/haskell/vscode-haskell#investigating-and-reporting-problems). -The most common client-related problem is the client simply not finding the server executable, so make sure that you have the right `PATH` and you have configured -it to look for the right executable. +The most common client-related problem is the client simply not finding the server executable or the tools needed to load Haskell code (`ghc`, `cabal`, or `stack`). So make sure that you have the right `PATH` and you have configured the client to look for the right executables. diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml index 725604f7df..01f035184a 100644 --- a/ghcide/.hlint.yaml +++ b/ghcide/.hlint.yaml @@ -133,7 +133,7 @@ # Things that are unsafe in Haskell base library - {name: unsafeInterleaveIO, within: [Development.IDE.LSP.LanguageServer]} - {name: unsafeDupablePerformIO, within: []} - - {name: unsafeCoerce, within: [Ide.Plugin.Eval.Code]} + - {name: unsafeCoerce, within: [Ide.Plugin.Eval.Code, Development.IDE.Types.Shake]} # Things that are a bit dangerous in the GHC API - {name: nameModule, within: []} diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 587b18f8ca..78af32e8ba 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -14,6 +14,7 @@ import Development.IDE (Priority (Debug, Info), action) import Development.IDE.Core.OfInterest (kick) import Development.IDE.Core.Rules (mainRule) +import Development.IDE.Core.Tracing (withTelemetryLogger) import Development.IDE.Graph (ShakeOptions (shakeThreads)) import qualified Development.IDE.Main as Main import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde @@ -39,7 +40,7 @@ ghcideVersion = do <> gitHashSection main :: IO () -main = do +main = withTelemetryLogger $ \telemetryLogger -> do let hlsPlugins = pluginDescToIdePlugins GhcIde.descriptors -- WARNING: If you write to stdout before runLanguageServer -- then the language server will not work @@ -55,6 +56,7 @@ main = do Main.defaultMain arguments {Main.argCommand = argsCommand + ,Main.argsLogger = Main.argsLogger arguments <> pure telemetryLogger ,Main.argsRules = do -- install the main and ghcide-plugin rules diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 0ff9eb5adc..ccd1b0aa7d 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -77,7 +77,7 @@ library rope-utf16-splay, safe, safe-exceptions, - hls-graph ^>= 1.5, + hls-graph ^>= 1.5.1, sorted-list, sqlite-simple, stm, diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index a0af4d235a..39643d1ab8 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -80,6 +80,7 @@ import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TQueue import qualified Data.HashSet as Set import Database.SQLite.Simple +import Development.IDE.Core.Tracing (withTrace) import HieDb.Create import HieDb.Types import HieDb.Utils @@ -425,7 +426,12 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) <> " (for " <> T.pack lfp <> ")" eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $ - cradleToOptsAndLibDir logger cradle cfp + withTrace "Load cradle" $ \addTag -> do + addTag "file" lfp + res <- cradleToOptsAndLibDir logger cradle cfp + addTag "result" (show res) + return res + logDebug logger $ T.pack ("Session loading result: " <> show eopts) case eopts of diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 2cc9d1c7f1..fe52b65975 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -256,9 +256,9 @@ setFileModified state saved nfp = do ideOptions <- getIdeOptionsIO $ shakeExtras state doCheckParents <- optCheckParents ideOptions let checkParents = case doCheckParents of - AlwaysCheck -> True - CheckOnSaveAndClose -> saved - _ -> False + AlwaysCheck -> True + CheckOnSave -> saved + _ -> False VFSHandle{..} <- getIdeGlobalState state when (isJust setVirtualFileContents) $ fail "setFileModified can't be called on this type of VFSHandle" diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 880d9f456d..bc53fba870 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -15,7 +15,7 @@ module Development.IDE.Core.OfInterest( setFilesOfInterest, kick, FileOfInterestStatus(..), OfInterestVar(..) - ) where + ,scheduleGarbageCollection) where import Control.Concurrent.Strict import Control.Monad @@ -41,6 +41,7 @@ instance IsIdeGlobal OfInterestVar ofInterestRules :: Rules () ofInterestRules = do addIdeGlobal . OfInterestVar =<< liftIO (newVar HashMap.empty) + addIdeGlobal . GarbageCollectVar =<< liftIO (newVar False) defineEarlyCutoff $ RuleNoDiagnostics $ \IsFileOfInterest f -> do alwaysRerun filesOfInterest <- getFilesOfInterestUntracked @@ -54,6 +55,9 @@ ofInterestRules = do summarize (IsFOI (Modified False)) = BS.singleton 2 summarize (IsFOI (Modified True)) = BS.singleton 3 +------------------------------------------------------------ +newtype GarbageCollectVar = GarbageCollectVar (Var Bool) +instance IsIdeGlobal GarbageCollectVar ------------------------------------------------------------ -- Exposed API @@ -93,6 +97,10 @@ deleteFileOfInterest state f = do recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files) +scheduleGarbageCollection :: IdeState -> IO () +scheduleGarbageCollection state = do + GarbageCollectVar var <- getIdeGlobalState state + writeVar var True -- | Typecheck all the files of interest. -- Could be improved @@ -109,3 +117,9 @@ kick = do void $ liftIO $ modifyVar' exportsMap (exportsMap' <>) liftIO $ progressUpdate progress KickCompleted + + GarbageCollectVar var <- getIdeGlobalAction + garbageCollectionScheduled <- liftIO $ readVar var + when garbageCollectionScheduled $ do + void garbageCollectDirtyKeys + liftIO $ writeVar var False diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index b7ceb89d22..6f8900b54e 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -272,7 +272,10 @@ newtype GetModificationTime = GetModificationTime_ { missingFileDiagnostics :: Bool -- ^ If false, missing file diagnostics are not reported } - deriving (Show, Generic) + deriving (Generic) + +instance Show GetModificationTime where + show _ = "GetModificationTime" instance Eq GetModificationTime where -- Since the diagnostics are not part of the answer, the query identity is diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 60b7c34fe3..5670cb540b 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -53,7 +53,6 @@ module Development.IDE.Core.Shake( GlobalIdeOptions(..), HLS.getClientConfig, getPluginConfig, - garbageCollect, knownTargets, setPriority, ideLogger, @@ -74,7 +73,9 @@ module Development.IDE.Core.Shake( HieDb, HieDbWriter(..), VFSHandle(..), - addPersistentRule + addPersistentRule, + garbageCollectDirtyKeys, + garbageCollectDirtyKeysOlderThan, ) where import Control.Concurrent.Async @@ -94,7 +95,6 @@ import Data.List.Extra (foldl', partition, import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe -import qualified Data.Set as Set import qualified Data.SortedList as SL import qualified Data.Text as T import Data.Time @@ -118,7 +118,11 @@ import Development.IDE.GHC.Compat (NameCache, import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import qualified Development.IDE.Graph as Shake -import Development.IDE.Graph.Database +import Development.IDE.Graph.Database (ShakeDatabase, + shakeGetBuildStep, + shakeOpenDatabase, + shakeProfileDatabase, + shakeRunDatabaseForKeys) import Development.IDE.Graph.Rule import Development.IDE.Types.Action import Development.IDE.Types.Diagnostics @@ -144,7 +148,9 @@ import Language.LSP.Types.Capabilities import OpenTelemetry.Eventlog import Control.Exception.Extra hiding (bracket_) +import Data.Aeson (toJSON) import qualified Data.ByteString.Char8 as BS8 +import Data.Coerce (coerce) import Data.Default import Data.Foldable (toList) import Data.HashSet (HashSet) @@ -153,6 +159,7 @@ import Data.IORef.Extra (atomicModifyIORef'_, atomicModifyIORef_) import Data.String (fromString) import Data.Text (pack) +import Debug.Trace.Flags (userTracingEnabled) import qualified Development.IDE.Types.Exports as ExportsMap import HieDb.Types import Ide.Plugin.Config @@ -327,10 +334,10 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do MaybeT $ pure $ (,del,ver) <$> fromDynamic dv case mv of Nothing -> do - void $ modifyVar' state $ HMap.alter (alterValue $ Failed True) (file,Key k) + void $ modifyVar' state $ HMap.alter (alterValue $ Failed True) (toKey k file) return Nothing Just (v,del,ver) -> do - void $ modifyVar' state $ HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (file,Key k) + void $ modifyVar' state $ HMap.alter (alterValue $ Stale (Just del) ver (toDyn v)) (toKey k file) return $ Just (v,addDelta del $ mappingForVersion allMappings file ver) -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics @@ -341,7 +348,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do -- Something already succeeded before, leave it alone _ -> old - case HMap.lookup (file,Key k) hm of + case HMap.lookup (toKey k file) hm of Nothing -> readPersistent Just (ValueWithDiagnostics v _) -> case v of Succeeded ver (fromDynamic -> Just v) -> pure (Just (v, mappingForVersion allMappings file ver)) @@ -356,12 +363,6 @@ lastValue key file = do s <- getShakeExtras liftIO $ lastValueIO s key file -valueVersion :: Value v -> Maybe TextDocumentVersion -valueVersion = \case - Succeeded ver _ -> Just ver - Stale _ ver _ -> Just ver - Failed _ -> Nothing - mappingForVersion :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping)) -> NormalizedFilePath @@ -419,7 +420,7 @@ setValues :: IdeRule k v -> Vector FileDiagnostic -> IO () setValues state key file val diags = - void $ modifyVar' state $ HMap.insert (file, Key key) (ValueWithDiagnostics (fmap toDyn val) diags) + void $ modifyVar' state $ HMap.insert (toKey key file) (ValueWithDiagnostics (fmap toDyn val) diags) -- | Delete the value stored for a given ide build key @@ -430,7 +431,7 @@ deleteValue -> NormalizedFilePath -> IO () deleteValue ShakeExtras{dirtyKeys, state} key file = do - void $ modifyVar' state $ HMap.delete (file, Key key) + void $ modifyVar' state $ HMap.delete (toKey key file) atomicModifyIORef_ dirtyKeys $ HSet.insert (toKey key file) recordDirtyKeys @@ -454,7 +455,7 @@ getValues :: IO (Maybe (Value v, Vector FileDiagnostic)) getValues state key file = do vs <- readVar state - case HMap.lookup (file, Key key) vs of + case HMap.lookup (toKey key file) vs of Nothing -> pure Nothing Just (ValueWithDiagnostics v diagsV) -> do let r = fmap (fromJust . fromDynamic @v) v @@ -543,10 +544,31 @@ shakeOpen lspEnv defaultConfig logger debouncer { optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled , optProgressStyle } <- getIdeOptionsIO shakeExtras - startTelemetry otProfilingEnabled logger $ state shakeExtras + + void $ startTelemetry shakeDb shakeExtras + startProfilingTelemetry otProfilingEnabled logger $ state shakeExtras return ideState +startTelemetry :: ShakeDatabase -> ShakeExtras -> IO (Async ()) +startTelemetry db extras@ShakeExtras{..} + | userTracingEnabled = do + countKeys <- mkValueObserver "cached keys count" + countDirty <- mkValueObserver "dirty keys count" + countBuilds <- mkValueObserver "builds count" + IdeOptions{optCheckParents} <- getIdeOptionsIO extras + checkParents <- optCheckParents + regularly 1 $ do + readVar state >>= observe countKeys . countRelevantKeys checkParents . HMap.keys + readIORef dirtyKeys >>= observe countDirty . countRelevantKeys checkParents . HSet.toList + shakeGetBuildStep db >>= observe countBuilds + + | otherwise = async (pure ()) + where + regularly :: Seconds -> IO () -> IO (Async ()) + regularly delay act = async $ forever (act >> sleep delay) + + -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: IdeState -> IO () shakeSessionInit IdeState{..} = do @@ -733,20 +755,73 @@ getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do val <- readVar hiddenDiagnostics return $ getAllDiagnostics val --- | Clear the results for all files that do not match the given predicate. -garbageCollect :: (NormalizedFilePath -> Bool) -> Action () -garbageCollect keep = do - ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras - liftIO $ - do newState <- modifyVar' state $ HMap.filterWithKey (\(file, _) _ -> keep file) - void $ modifyVar' diagnostics $ filterDiagnostics keep - void $ modifyVar' hiddenDiagnostics $ filterDiagnostics keep - void $ modifyVar' publishedDiagnostics $ HMap.filterWithKey (\uri _ -> keep (fromUri uri)) - let versionsForFile = - HMap.fromListWith Set.union $ - mapMaybe (\((file, _key), ValueWithDiagnostics v _) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $ - HMap.toList newState - void $ modifyVar' positionMapping $ filterVersionMap versionsForFile +-- | Find and release old keys from the state Hashmap +-- For the record, there are other state sources that this process does not release: +-- * diagnostics store (normal, hidden and published) +-- * position mapping store +-- * indexing queue +-- * exports map +garbageCollectDirtyKeys :: Action [Key] +garbageCollectDirtyKeys = do + IdeOptions{optCheckParents} <- getIdeOptions + checkParents <- liftIO optCheckParents + garbageCollectDirtyKeysOlderThan 0 checkParents + +garbageCollectDirtyKeysOlderThan :: Int -> CheckParents -> Action [Key] +garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection "dirty GC" $ do + dirtySet <- getDirtySet + garbageCollectKeys "dirty GC" maxAge checkParents dirtySet + +garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key] +garbageCollectKeys label maxAge checkParents agedKeys = do + start <- liftIO offsetTime + extras <- getShakeExtras + (n::Int, garbage) <- liftIO $ modifyVar (state extras) $ \vmap -> + evaluate $ foldl' removeDirtyKey (vmap, (0,[])) agedKeys + liftIO $ atomicModifyIORef_ (dirtyKeys extras) $ \x -> + foldl' (flip HSet.insert) x garbage + t <- liftIO start + when (n>0) $ liftIO $ do + logDebug (logger extras) $ T.pack $ + label <> " of " <> show n <> " keys (took " <> showDuration t <> ")" + when (coerce $ ideTesting extras) $ liftIO $ mRunLspT (lspEnv extras) $ + LSP.sendNotification (SCustomMethod "ghcide/GC") + (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage) + return garbage + + where + showKey = show . Q + removeDirtyKey st@(vmap,(!counter, keys)) (k, age) + | age > maxAge + , Just (kt,_) <- fromKeyType k + , not(kt `HSet.member` preservedKeys checkParents) + , (True, vmap') <- HMap.alterF (\prev -> (isJust prev, Nothing)) k vmap + = (vmap', (counter+1, k:keys)) + | otherwise = st + +countRelevantKeys :: CheckParents -> [Key] -> Int +countRelevantKeys checkParents = + Prelude.length . filter (maybe False (not . (`HSet.member` preservedKeys checkParents) . fst) . fromKeyType) + +preservedKeys :: CheckParents -> HashSet TypeRep +preservedKeys checkParents = HSet.fromList $ + -- always preserved + [ typeOf GetFileExists + , typeOf GetModificationTime + , typeOf IsFileOfInterest + , typeOf GhcSessionIO + , typeOf GetClientSettings + , typeOf AddWatchedFile + , typeOf GetKnownTargets + ] + ++ concat + -- preserved if CheckParents is enabled since we need to rebuild the ModuleGraph + [ [ typeOf GetModSummary + , typeOf GetModSummaryWithoutTimestamps + , typeOf GetLocatedImports + ] + | checkParents /= NeverCheck + ] -- | Define a new Rule without early cutoff define @@ -921,8 +996,8 @@ defineEarlyCutoff' doDiagnostics cmp key file old mode action = do v <- liftIO $ getValues state key file case v of -- No changes in the dependencies and we have - -- an existing result. - Just (v, diags) -> do + -- an existing successful result. + Just (v@Succeeded{}, diags) -> do when doDiagnostics $ updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) $ Vector.toList diags return $ Just $ RunResult ChangedNothing old $ A v @@ -1128,20 +1203,6 @@ getUriDiagnostics uri ds = maybe [] getDiagnosticsFromStore $ HMap.lookup uri ds -filterDiagnostics :: - (NormalizedFilePath -> Bool) -> - DiagnosticStore -> - DiagnosticStore -filterDiagnostics keep = - HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri) - -filterVersionMap - :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion) - -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a) - -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a) -filterVersionMap = - HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep - updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO () updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do modifyVar_ positionMapping $ \allMappings -> do diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 0c24c8996c..e3c8ee3895 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -1,15 +1,19 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NoApplicativeDo #-} +{-# HLINT ignore #-} module Development.IDE.Core.Tracing ( otTracedHandler , otTracedAction - , startTelemetry + , startProfilingTelemetry , measureMemory , getInstrumentCached , otTracedProvider , otSetUri + , otTracedGarbageCollection , withTrace - ,withEventTrace) + , withEventTrace + , withTelemetryLogger + ) where import Control.Concurrent.Async (Async, async) @@ -31,7 +35,10 @@ import qualified Data.HashMap.Strict as HMap import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) import Data.String (IsString (fromString)) +import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) +import Data.Typeable (TypeRep, typeOf) +import Data.Word (Word16) import Debug.Trace.Flags (userTracingEnabled) import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), GhcSessionDeps (GhcSessionDeps), @@ -39,10 +46,11 @@ import Development.IDE.Core.RuleTypes (GhcSession (GhcSession), import Development.IDE.Graph (Action) import Development.IDE.Graph.Rule import Development.IDE.Types.Location (Uri (..)) -import Development.IDE.Types.Logger (Logger, logDebug, logInfo) -import Development.IDE.Types.Shake (Key (..), Value, +import Development.IDE.Types.Logger (Logger (Logger), logDebug, + logInfo) +import Development.IDE.Types.Shake (Value, ValueWithDiagnostics (..), - Values) + Values, fromKeyType) import Foreign.Storable (Storable (sizeOf)) import HeapSize (recursiveSize, runHeapsize) import Ide.PluginUtils (installSigUsr1Handler) @@ -50,12 +58,21 @@ import Ide.Types (PluginId (..)) import Language.LSP.Types (NormalizedFilePath, fromNormalizedFilePath) import Numeric.Natural (Natural) -import OpenTelemetry.Eventlog (Instrument, SpanInFlight (..), - Synchronicity (Asynchronous), - addEvent, beginSpan, endSpan, +import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent, + beginSpan, endSpan, mkValueObserver, observe, setTag, withSpan, withSpan_) +#if MIN_VERSION_ghc(8,8,0) +otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a +otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => ByteString -> f [a] -> f [a] +withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> ByteString -> m ()) -> m a) -> m a +#else +otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a +otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => String -> f [a] -> f [a] +withEventTrace :: (MonadMask m, MonadIO m) => String -> ((String -> ByteString -> m ()) -> m a) -> m a +#endif + withTrace :: (MonadMask m, MonadIO m) => String -> ((String -> String -> m ()) -> m a) -> m a withTrace name act @@ -65,17 +82,24 @@ withTrace name act act setSpan' | otherwise = act (\_ _ -> pure ()) -#if MIN_VERSION_ghc(8,8,0) -withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> ByteString -> m ()) -> m a) -> m a -#else -withEventTrace :: (MonadMask m, MonadIO m) => String -> ((String -> ByteString -> m ()) -> m a) -> m a -#endif withEventTrace name act | userTracingEnabled = withSpan (fromString name) $ \sp -> do act (addEvent sp) | otherwise = act (\_ _ -> pure ()) +-- | Returns a logger that produces telemetry events in a single span +withTelemetryLogger :: (MonadIO m, MonadMask m) => (Logger -> m a) -> m a +withTelemetryLogger k = withSpan "Logger" $ \sp -> + -- Tracy doesn't like when we create a new span for every log line. + -- To workaround that, we create a single span for all log events. + -- This is fine since we don't care about the span itself, only about the events + k $ Logger $ \p m -> + addEvent sp (fromString $ show p) (encodeUtf8 $ trim m) + where + -- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX + trim = T.take (fromIntegral(maxBound :: Word16) - 10) + -- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span. otTracedHandler :: MonadUnliftIO m @@ -127,11 +151,19 @@ otTracedAction key file mode result act (const act) | otherwise = act -#if MIN_VERSION_ghc(8,8,0) -otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a -#else -otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a -#endif +otTracedGarbageCollection label act + | userTracingEnabled = fst <$> + generalBracket + (beginSpan label) + (\sp ec -> do + case ec of + ExitCaseAbort -> setTag sp "aborted" "1" + ExitCaseException e -> setTag sp "exception" (pack $ show e) + ExitCaseSuccess res -> setTag sp "keys" (pack $ unlines $ map show res) + endSpan sp) + (const act) + | otherwise = act + otTracedProvider (PluginId pluginName) provider act | userTracingEnabled = do runInIO <- askRunInIO @@ -140,17 +172,17 @@ otTracedProvider (PluginId pluginName) provider act runInIO act | otherwise = act -startTelemetry :: Bool -> Logger -> Var Values -> IO () -startTelemetry allTheTime logger stateRef = do + +startProfilingTelemetry :: Bool -> Logger -> Var Values -> IO () +startProfilingTelemetry allTheTime logger stateRef = do instrumentFor <- getInstrumentCached - mapCountInstrument <- mkValueObserver "values map count" installSigUsr1Handler $ do logInfo logger "SIGUSR1 received: performing memory measurement" - performMeasurement logger stateRef instrumentFor mapCountInstrument + performMeasurement logger stateRef instrumentFor when allTheTime $ void $ regularly (1 * seconds) $ - performMeasurement logger stateRef instrumentFor mapCountInstrument + performMeasurement logger stateRef instrumentFor where seconds = 1000000 @@ -161,21 +193,23 @@ startTelemetry allTheTime logger stateRef = do performMeasurement :: Logger -> Var Values -> - (Maybe Key -> IO OurValueObserver) -> - Instrument 'Asynchronous a m' -> + (Maybe String -> IO OurValueObserver) -> IO () -performMeasurement logger stateRef instrumentFor mapCountInstrument = do - withSpan_ "Measure length" $ readVar stateRef >>= observe mapCountInstrument . length +performMeasurement logger stateRef instrumentFor = do values <- readVar stateRef - let keys = Key GhcSession - : Key GhcSessionDeps - : [ k | (_,k) <- HMap.keys values - -- do GhcSessionIO last since it closes over stateRef itself - , k /= Key GhcSession - , k /= Key GhcSessionDeps - , k /= Key GhcSessionIO - ] ++ [Key GhcSessionIO] + let keys = typeOf GhcSession + : typeOf GhcSessionDeps + -- TODO restore + : [ kty + | k <- HMap.keys values + , Just (kty,_) <- [fromKeyType k] + -- do GhcSessionIO last since it closes over stateRef itself + , kty /= typeOf GhcSession + , kty /= typeOf GhcSessionDeps + , kty /= typeOf GhcSessionIO + ] + ++ [typeOf GhcSessionIO] groupedForSharing <- evaluate (keys `using` seqList r0) measureMemory logger [groupedForSharing] instrumentFor stateRef `catch` \(e::SomeException) -> @@ -184,7 +218,7 @@ performMeasurement logger stateRef instrumentFor mapCountInstrument = do type OurValueObserver = Int -> IO () -getInstrumentCached :: IO (Maybe Key -> IO OurValueObserver) +getInstrumentCached :: IO (Maybe String -> IO OurValueObserver) getInstrumentCached = do instrumentMap <- newVar HMap.empty mapBytesInstrument <- mkValueObserver "value map size_bytes" @@ -206,8 +240,8 @@ whenNothing act mb = mb >>= f measureMemory :: Logger - -> [[Key]] -- ^ Grouping of keys for the sharing-aware analysis - -> (Maybe Key -> IO OurValueObserver) + -> [[TypeRep]] -- ^ Grouping of keys for the sharing-aware analysis + -> (Maybe String -> IO OurValueObserver) -> Var Values -> IO () measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" $ do @@ -222,7 +256,7 @@ measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" repeatUntilJust 3 $ do -- logDebug logger (fromString $ show $ map fst groupedValues) runHeapsize 25000000 $ - forM_ groupedValues $ \(k,v) -> withSpan ("Measure " <> (fromString $ show k)) $ \sp -> do + forM_ groupedValues $ \(k,v) -> withSpan ("Measure " <> fromString k) $ \sp -> do acc <- liftIO $ newIORef 0 observe <- liftIO $ instrumentFor $ Just k mapM_ (recursiveSize >=> \x -> liftIO (modifyIORef' acc (+ x))) v @@ -242,12 +276,13 @@ measureMemory logger groups instrumentFor stateRef = withSpan_ "Measure Memory" logInfo logger "Memory profiling could not be completed: increase the size of your nursery (+RTS -Ax) and try again" where - groupValues :: Values -> [ [(Key, [Value Dynamic])] ] + groupValues :: Values -> [ [(String, [Value Dynamic])] ] groupValues values = let !groupedValues = - [ [ (k, vv) - | k <- groupKeys - , let vv = [ v | ((_,k'), ValueWithDiagnostics v _) <- HMap.toList values , k == k'] + [ [ (show ty, vv) + | ty <- groupKeys + , let vv = [ v | (fromKeyType -> Just (kty,_), ValueWithDiagnostics v _) <- HMap.toList values + , kty == ty] ] | groupKeys <- groups ] diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index b2901bf32c..0c7ba6236e 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -14,30 +14,25 @@ module Development.IDE.LSP.Notifications import Language.LSP.Types import qualified Language.LSP.Types as LSP -import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.Service -import Development.IDE.Core.Shake -import Development.IDE.Types.Location -import Development.IDE.Types.Logger -import Development.IDE.Types.Options - import Control.Monad.Extra -import qualified Data.HashSet as S -import qualified Data.Text as Text - import Control.Monad.IO.Class import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as S +import qualified Data.Text as Text import Development.IDE.Core.FileExists (modifyFileExists, watchedGlobs) import Development.IDE.Core.FileStore (registerFileWatches, resetFileStore, setFileModified, - setSomethingModified, - typecheckParents) + setSomethingModified) +import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.OfInterest import Development.IDE.Core.RuleTypes (GetClientSettings (..)) +import Development.IDE.Core.Service +import Development.IDE.Core.Shake +import Development.IDE.Types.Location +import Development.IDE.Types.Logger import Development.IDE.Types.Shake (toKey) -import Ide.Plugin.Config (CheckParents (CheckOnClose)) import Ide.Types whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () @@ -74,10 +69,10 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = \ide _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do deleteFileOfInterest ide file - -- Refresh all the files that depended on this - checkParents <- optCheckParents =<< getIdeOptionsIO (shakeExtras ide) - when (checkParents >= CheckOnClose) $ typecheckParents ide file - logDebug (ideLogger ide) $ "Closed text document: " <> getUri _uri + let msg = "Closed text document: " <> getUri _uri + scheduleGarbageCollection ide + setSomethingModified ide [] $ Text.unpack msg + logDebug (ideLogger ide) msg , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWatchedFiles $ \ide _ (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 5f1defb027..a732fcd6fb 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -23,13 +23,11 @@ import Data.Hashable (hashed) import Data.List.Extra (intercalate, isPrefixOf, nub, nubOrd, partition) import Data.Maybe (catMaybes, isJust) -import Data.String import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.IO as T import Data.Text.Lazy.Encoding (decodeUtf8) import qualified Data.Text.Lazy.IO as LT -import Data.Word (Word16) +import Data.Typeable (typeOf) import Development.IDE (Action, GhcVersion (..), Priority (Debug), Rules, ghcVersion, @@ -54,8 +52,7 @@ import Development.IDE.Core.Service (initialise, runAction) import Development.IDE.Core.Shake (IdeState (shakeExtras), ShakeExtras (state), shakeSessionInit, uses) -import Development.IDE.Core.Tracing (measureMemory, - withEventTrace) +import Development.IDE.Core.Tracing (measureMemory) import Development.IDE.Graph (action) import Development.IDE.LSP.LanguageServer (runLanguageServer) import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) @@ -79,7 +76,7 @@ import Development.IDE.Types.Options (IdeGhcSession, defaultIdeOptions, optModifyDynFlags, optTesting) -import Development.IDE.Types.Shake (Key (Key)) +import Development.IDE.Types.Shake (fromKeyType) import GHC.Conc (getNumProcessors) import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Handle (hDuplicate) @@ -189,7 +186,7 @@ defaultArguments :: Priority -> Arguments defaultArguments priority = Arguments { argsOTMemoryProfiling = False , argCommand = LSP - , argsLogger = stderrLogger priority <> pure telemetryLogger + , argsLogger = stderrLogger priority , argsRules = mainRule >> action kick , argsGhcidePlugin = mempty , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors @@ -239,14 +236,6 @@ stderrLogger logLevel = do return $ Logger $ \p m -> when (p >= logLevel) $ withLock lock $ T.hPutStrLn stderr $ "[" <> T.pack (show p) <> "] " <> m -telemetryLogger :: Logger -telemetryLogger = Logger $ \p m -> - withEventTrace "Log" $ \addEvent -> - addEvent (fromString $ "Log " <> show p) (encodeUtf8 $ trim m) - where - -- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX - trim = T.take (fromIntegral(maxBound :: Word16) - 10) - defaultMain :: Arguments -> IO () defaultMain Arguments{..} = do setLocaleEncoding utf8 @@ -376,10 +365,10 @@ defaultMain Arguments{..} = do printf "# Shake value store contents(%d):\n" (length values) let keys = nub $ - Key GhcSession : - Key GhcSessionDeps : - [k | (_, k) <- HashMap.keys values, k /= Key GhcSessionIO] - ++ [Key GhcSessionIO] + typeOf GhcSession : + typeOf GhcSessionDeps : + [kty | (fromKeyType -> Just (kty,_)) <- HashMap.keys values, kty /= typeOf GhcSessionIO] ++ + [typeOf GhcSessionIO] measureMemory logger [keys] consoleObserver valuesRef unless (null failed) (exitWith $ ExitFailure (length failed)) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index edabeab3dd..30c7b500f9 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -882,8 +882,9 @@ suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) fileC "Ambiguous occurrence ‘([^’]+)’" , Just modules <- map last - <$> allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’" = - suggestions ambiguous modules + <$> allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’" + , local <- matchRegexUnifySpaces _message "defined at .+:[0-9]+:[0-9]+" = + suggestions ambiguous modules (isJust local) | otherwise = [] where locDic = @@ -906,16 +907,16 @@ suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) fileC -- > removeAllDuplicates [1, 1, 2, 3, 2] = [3] removeAllDuplicates = map head . filter ((==1) <$> length) . group . sort hasDuplicate xs = length xs /= length (S.fromList xs) - suggestions symbol mods + suggestions symbol mods local | hasDuplicate mods = case mapM toModuleTarget (removeAllDuplicates mods) of - Just targets -> suggestionsImpl symbol (map (, []) targets) + Just targets -> suggestionsImpl symbol (map (, []) targets) local Nothing -> [] | otherwise = case mapM toModuleTarget mods of - Just targets -> suggestionsImpl symbol (oneAndOthers targets) + Just targets -> suggestionsImpl symbol (oneAndOthers targets) local Nothing -> [] - suggestionsImpl symbol targetsWithRestImports = + suggestionsImpl symbol targetsWithRestImports local = sortOn fst - [ ( renderUniquify mode modNameText symbol + [ ( renderUniquify mode modNameText symbol False , disambiguateSymbol ps fileContents diag symbol mode ) | (modTarget, restImports) <- targetsWithRestImports @@ -942,10 +943,14 @@ suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) fileC _ -> False ] ++ [HideOthers restImports | not (null restImports)] + ] ++ [ ( renderUniquify mode T.empty symbol True + , disambiguateSymbol ps fileContents diag symbol mode + ) | local, not (null targetsWithRestImports) + , let mode = HideOthers (uncurry (:) (head targetsWithRestImports)) ] - renderUniquify HideOthers {} modName symbol = - "Use " <> modName <> " for " <> symbol <> ", hiding other imports" - renderUniquify (ToQualified _ qual) _ symbol = + renderUniquify HideOthers {} modName symbol local = + "Use " <> (if local then "local definition" else modName) <> " for " <> symbol <> ", hiding other imports" + renderUniquify (ToQualified _ qual) _ symbol _ = "Replace with qualified: " <> T.pack (moduleNameString qual) <> "." @@ -1005,7 +1010,6 @@ disambiguateSymbol pm fileContents Diagnostic {..} (T.unpack -> symbol) = \case liftParseAST @RdrName df $ prettyPrint $ L (mkGeneralSrcSpan "") rdr ] - findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) findImportDeclByRange xs range = find (\(L l _)-> srcSpanToRange l == Just range) xs diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index 965c05c27e..b611b049a9 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -11,17 +11,20 @@ module Development.IDE.Plugin.Test , blockCommandId ) where -import Control.Concurrent (threadDelay) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Extra (readVar) import Control.Monad import Control.Monad.IO.Class import Control.Monad.STM import Data.Aeson import Data.Aeson.Types import Data.Bifunctor -import Data.CaseInsensitive (CI, original) -import Data.Maybe (isJust) +import Data.CaseInsensitive (CI, original) +import qualified Data.HashMap.Strict as HM +import Data.Maybe (isJust) import Data.String -import Data.Text (Text, pack) +import Data.Text (Text, pack) +import Development.IDE.Core.OfInterest (getFilesOfInterest) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake @@ -29,14 +32,16 @@ import Development.IDE.GHC.Compat import Development.IDE.Graph (Action) import Development.IDE.Graph.Database (shakeLastBuildKeys) import Development.IDE.Types.Action -import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) -import Development.IDE.Types.Location (fromUri) -import GHC.Generics (Generic) +import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) +import Development.IDE.Types.Location (fromUri) +import GHC.Generics (Generic) +import Ide.Plugin.Config (CheckParents) import Ide.Types -import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Server as LSP import Language.LSP.Types import System.Time.Extra +type Age = Int data TestRequest = BlockSeconds Seconds -- ^ :: Null | GetInterfaceFilesDir Uri -- ^ :: String @@ -44,6 +49,9 @@ data TestRequest | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null | WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult | GetLastBuildKeys -- ^ :: [String] + | GarbageCollectDirtyKeys CheckParents Age -- ^ :: [String] (list of keys collected) + | GetStoredKeys -- ^ :: [String] (list of keys in store) + | GetFilesOfInterest -- ^ :: [FilePath] deriving Generic deriving anyclass (FromJSON, ToJSON) @@ -93,6 +101,15 @@ testRequestHandler s (WaitForIdeRule k file) = liftIO $ do testRequestHandler s GetLastBuildKeys = liftIO $ do keys <- shakeLastBuildKeys $ shakeDb s return $ Right $ toJSON $ map show keys +testRequestHandler s (GarbageCollectDirtyKeys parents age) = do + res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age parents + return $ Right $ toJSON $ map show res +testRequestHandler s GetStoredKeys = do + keys <- liftIO $ HM.keys <$> readVar (state $ shakeExtras s) + return $ Right $ toJSON $ map show keys +testRequestHandler s GetFilesOfInterest = do + ff <- liftIO $ getFilesOfInterest s + return $ Right $ toJSON $ map fromNormalizedFilePath $ HM.keys ff mkResponseError :: Text -> ResponseError mkResponseError msg = ResponseError InvalidRequest msg Nothing diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index 1a8ca906a9..bfd11413fc 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -50,6 +50,8 @@ data IdeOptions = IdeOptions -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants , optReportProgress :: IdeReportProgress -- ^ Whether to report progress during long operations. + , optMaxDirtyAge :: Int + -- ^ Age (in # builds) at which we collect dirty keys , optLanguageSyntax :: String -- ^ the ```language to use , optNewColonConvention :: Bool @@ -137,12 +139,13 @@ defaultIdeOptions session = IdeOptions ,optDefer = IdeDefer True ,optTesting = IdeTesting False ,optCheckProject = pure True - ,optCheckParents = pure CheckOnSaveAndClose + ,optCheckParents = pure CheckOnSave ,optHaddockParse = HaddockParse ,optModifyDynFlags = mempty ,optSkipProgress = defaultSkipProgress ,optProgressStyle = Explicit ,optRunSubset = True + ,optMaxDirtyAge = 100 } defaultSkipProgress :: Typeable a => a -> Bool diff --git a/ghcide/src/Development/IDE/Types/Shake.hs b/ghcide/src/Development/IDE/Types/Shake.hs index 750dbcdd11..8d30b59801 100644 --- a/ghcide/src/Development/IDE/Types/Shake.hs +++ b/ghcide/src/Development/IDE/Types/Shake.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} module Development.IDE.Types.Shake ( Q (..), @@ -12,7 +13,7 @@ module Development.IDE.Types.Shake ShakeValue(..), currentValue, isBadDependency, - toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey) + toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey,fromKey,fromKeyType) where import Control.DeepSeq @@ -21,6 +22,7 @@ import qualified Data.ByteString.Char8 as BS import Data.Dynamic import Data.HashMap.Strict import Data.Hashable +import Data.Typeable (cast) import Data.Vector (Vector) import Development.IDE.Core.PositionMapping import Development.IDE.Graph (Key (..), RuleResult) @@ -29,6 +31,11 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import GHC.Generics import Language.LSP.Types +import Type.Reflection (SomeTypeRep (SomeTypeRep), + pattern App, pattern Con, + typeOf, typeRep, + typeRepTyCon) +import Unsafe.Coerce (unsafeCoerce) data Value v = Succeeded TextDocumentVersion v @@ -49,7 +56,7 @@ data ValueWithDiagnostics = ValueWithDiagnostics !(Value Dynamic) !(Vector FileDiagnostic) -- | The state of the all values and diagnostics -type Values = HashMap (NormalizedFilePath, Key) ValueWithDiagnostics +type Values = HashMap Key ValueWithDiagnostics -- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency -- which short-circuits the rest of the action @@ -64,6 +71,19 @@ isBadDependency x toKey :: Shake.ShakeValue k => k -> NormalizedFilePath -> Key toKey = (Key.) . curry Q +fromKey :: Typeable k => Key -> Maybe (k, NormalizedFilePath) +fromKey (Key k) + | Just (Q (k', f)) <- cast k = Just (k', f) + | otherwise = Nothing + +-- | fromKeyType (Q (k,f)) = (typeOf k, f) +fromKeyType :: Key -> Maybe (SomeTypeRep, NormalizedFilePath) +fromKeyType (Key k) = case typeOf k of + App (Con tc) a | tc == typeRepTyCon (typeRep @Q) + -> case unsafeCoerce k of + Q (_ :: (), f) -> Just (SomeTypeRep a, f) + _ -> Nothing + toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key toNoFileKey k = Key $ Q (k, emptyFilePath) diff --git a/ghcide/test/data/hiding/HideFunctionWithoutLocal.expected.hs b/ghcide/test/data/hiding/HideFunctionWithoutLocal.expected.hs new file mode 100644 index 0000000000..82c57fd8ed --- /dev/null +++ b/ghcide/test/data/hiding/HideFunctionWithoutLocal.expected.hs @@ -0,0 +1,14 @@ +module HideFunctionWithoutLocal where + +import AVec (fromList) +import BVec (fromList) +import CVec hiding ((++), cons) +import DVec hiding ((++), cons, snoc) +import EVec as E hiding ((++)) +import Prelude hiding ((++)) + +theOp = (++) + +data Vec a + +(++) = undefined diff --git a/ghcide/test/data/hiding/HideFunctionWithoutLocal.hs b/ghcide/test/data/hiding/HideFunctionWithoutLocal.hs new file mode 100644 index 0000000000..0168627d45 --- /dev/null +++ b/ghcide/test/data/hiding/HideFunctionWithoutLocal.hs @@ -0,0 +1,13 @@ +module HideFunctionWithoutLocal where + +import AVec (fromList) +import BVec (fromList, (++)) +import CVec hiding (cons) +import DVec hiding (cons, snoc) +import EVec as E + +theOp = (++) + +data Vec a + +(++) = undefined diff --git a/ghcide/test/data/hiding/HidePreludeLocalInfix.expected.hs b/ghcide/test/data/hiding/HidePreludeLocalInfix.expected.hs new file mode 100644 index 0000000000..b0b97c348d --- /dev/null +++ b/ghcide/test/data/hiding/HidePreludeLocalInfix.expected.hs @@ -0,0 +1,9 @@ +module HidePreludeLocalInfix where +import Prelude hiding ((++)) + +infixed xs ys = xs ++ ys + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined diff --git a/ghcide/test/data/hiding/HidePreludeLocalInfix.hs b/ghcide/test/data/hiding/HidePreludeLocalInfix.hs new file mode 100644 index 0000000000..2e2dfb5df8 --- /dev/null +++ b/ghcide/test/data/hiding/HidePreludeLocalInfix.hs @@ -0,0 +1,8 @@ +module HidePreludeLocalInfix where + +infixed xs ys = xs ++ ys + +data Vec a + +(++) :: Vec a -> Vec a -> Vec a +(++) = undefined diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index d4231d56b4..eec662dcb8 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -50,7 +50,10 @@ import Development.IDE.Test (Cursor, expectNoMoreDiagnostics, flushMessages, standardizeQuotes, - waitForAction, getInterfaceFilesDir) + getInterfaceFilesDir, + waitForAction, + getStoredKeys, + waitForTypecheck, waitForGC) import Development.IDE.Test.Runfiles import qualified Development.IDE.Types.Diagnostics as Diagnostics import Development.IDE.Types.Location @@ -177,6 +180,7 @@ main = do , clientSettingsTest , codeActionHelperFunctionTests , referenceTests + , garbageCollectionTests ] initializeResponseTests :: TestTree @@ -723,7 +727,7 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r -- Now we edit the document and wait for the given key (if any) changeDoc doc [edit] whenJust mbKey $ \(key, expectedResult) -> do - Right WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc + WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc liftIO $ ideResultSuccess @?= expectedResult -- The 2nd edit cancels the active session and unbreaks the file @@ -737,7 +741,7 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s typeCheck doc = do - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ assertBool "The file should typecheck" ideResultSuccess -- wait for the debouncer to publish diagnostics if the rule runs liftIO $ sleep 0.2 @@ -1799,10 +1803,20 @@ suggestImportDisambiguationTests = testGroup "suggest import disambiguation acti compareHideFunctionTo [(8,9),(10,8)] "Use EVec for ++, hiding other imports" "HideFunction.expected.append.E.hs" + , testCase "Hide functions without local" $ + compareTwo + "HideFunctionWithoutLocal.hs" [(8,8)] + "Use local definition for ++, hiding other imports" + "HideFunctionWithoutLocal.expected.hs" , testCase "Prelude" $ compareHideFunctionTo [(8,9),(10,8)] "Use Prelude for ++, hiding other imports" "HideFunction.expected.append.Prelude.hs" + , testCase "Prelude and local definition, infix" $ + compareTwo + "HidePreludeLocalInfix.hs" [(2,19)] + "Use local definition for ++, hiding other imports" + "HidePreludeLocalInfix.expected.hs" , testCase "AVec, indented" $ compareTwo "HidePreludeIndented.hs" [(3,8)] "Use AVec for ++, hiding other imports" @@ -5040,7 +5054,7 @@ retryFailedCradle = testSession' "retry failed" $ \dir -> do liftIO $ writeFile hiePath hieContents let aPath = dir "A.hs" doc <- createDoc aPath "haskell" "main = return ()" - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess -- Fix the cradle and typecheck again @@ -5049,7 +5063,7 @@ retryFailedCradle = testSession' "retry failed" $ \dir -> do sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ List [FileEvent (filePathToUri $ dir "hie.yaml") FcChanged ] - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess @@ -5128,11 +5142,11 @@ simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraF bPath = dir "b/B.hs" aSource <- liftIO $ readFileUtf8 aPath adoc <- createDoc aPath "haskell" aSource - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc + WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc liftIO $ assertBool "A should typecheck" ideResultSuccess bSource <- liftIO $ readFileUtf8 bPath bdoc <- createDoc bPath "haskell" bSource - Right WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" bdoc + WaitForIdeRuleResult {..} <- 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 @@ -5254,7 +5268,7 @@ ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \d -- Check that we wrote the interfaces for B when we saved - Right hidir <- getInterfaceFilesDir bdoc + hidir <- getInterfaceFilesDir bdoc hi_exists <- liftIO $ doesFileExist $ hidir "B.hi" liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists @@ -5837,6 +5851,78 @@ unitTests = do , Progress.tests ] +garbageCollectionTests :: TestTree +garbageCollectionTests = testGroup "garbage collection" + [ testGroup "dirty keys" + [ testSession' "are collected" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + doc <- generateGarbage "A" dir + closeDoc doc + garbage <- waitForGC + liftIO $ assertBool "no garbage was found" $ not $ null garbage + + , testSession' "are deleted from the state" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + docA <- generateGarbage "A" dir + keys0 <- getStoredKeys + closeDoc docA + garbage <- waitForGC + liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage + keys1 <- getStoredKeys + liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0) + + , testSession' "are not regenerated unless needed" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}" + docA <- generateGarbage "A" dir + _docB <- generateGarbage "B" dir + + -- garbage collect A keys + keysBeforeGC <- getStoredKeys + closeDoc docA + garbage <- waitForGC + liftIO $ assertBool "something is wrong with this test - no garbage found" $ not $ null garbage + keysAfterGC <- getStoredKeys + liftIO $ assertBool "something is wrong with this test - keys were not deleted from the state" + (length keysAfterGC < length keysBeforeGC) + + -- re-typecheck B and check that the keys for A have not materialized back + _docB <- generateGarbage "B" dir + keysB <- getStoredKeys + let regeneratedKeys = Set.filter (not . isExpected) $ + Set.intersection (Set.fromList garbage) (Set.fromList keysB) + liftIO $ regeneratedKeys @?= mempty + + , testSession' "regenerate successfully" $ \dir -> do + liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" + docA <- generateGarbage "A" dir + closeDoc docA + garbage <- waitForGC + liftIO $ assertBool "no garbage was found" $ not $ null garbage + let edit = T.unlines + [ "module A where" + , "a :: Bool" + , "a = ()" + ] + doc <- generateGarbage "A" dir + changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing edit] + builds <- waitForTypecheck doc + liftIO $ assertBool "it still builds" builds + expectCurrentDiagnostics doc [(DsError, (2,4), "Couldn't match expected type")] + ] + ] + where + isExpected k = any (`T.isPrefixOf` k) ["GhcSessionIO"] + + generateGarbage :: String -> FilePath -> Session TextDocumentIdentifier + generateGarbage modName dir = do + let fp = modName <> ".hs" + body = printf "module %s where" modName + doc <- createDoc fp "haskell" (T.pack body) + liftIO $ writeFile (dir fp) body + builds <- waitForTypecheck doc + liftIO $ assertBool "something is wrong with this test" builds + return doc + findResolution_us :: Int -> IO Int findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution" findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 35ae059500..48fd9fa5bc 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} module Development.IDE.Test @@ -22,6 +23,13 @@ module Development.IDE.Test , waitForAction , getLastBuildKeys , getInterfaceFilesDir + , garbageCollectDirtyKeys + , getFilesOfInterest + , waitForTypecheck + , waitForBuildQueue + , getStoredKeys + , waitForCustomMessage + , waitForGC ) where import Control.Applicative.Combinators @@ -32,10 +40,13 @@ import qualified Data.Aeson as A import Data.Bifunctor (second) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) +import Data.Text (Text) import qualified Data.Text as T import Development.IDE.Plugin.Test (TestRequest (..), - WaitForIdeRuleResult) + WaitForIdeRuleResult, + ideResultSuccess) import Development.IDE.Test.Diagnostic +import Ide.Plugin.Config (CheckParents) import Language.LSP.Test hiding (message) import qualified Language.LSP.Test as LspTest import Language.LSP.Types hiding @@ -171,23 +182,51 @@ canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePat diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics) diagnostic = LspTest.message STextDocumentPublishDiagnostics -callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) +callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b callTestPlugin cmd = do let cm = SCustomMethod "test" waitId <- sendRequest cm (A.toJSON cmd) ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId - return $ do - e <- _result - case A.fromJSON e of - A.Error e -> Left $ ResponseError InternalError (T.pack e) Nothing - A.Success a -> pure a + return $ case _result of + Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err + Right json -> case A.fromJSON json of + A.Success a -> a + A.Error e -> error e -waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) +waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResult waitForAction key TextDocumentIdentifier{_uri} = callTestPlugin (WaitForIdeRule key _uri) -getLastBuildKeys :: Session (Either ResponseError [T.Text]) +getLastBuildKeys :: Session [T.Text] getLastBuildKeys = callTestPlugin GetLastBuildKeys -getInterfaceFilesDir :: TextDocumentIdentifier -> Session (Either ResponseError FilePath) +getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath getInterfaceFilesDir TextDocumentIdentifier{_uri} = callTestPlugin (GetInterfaceFilesDir _uri) + +garbageCollectDirtyKeys :: CheckParents -> Int -> Session [String] +garbageCollectDirtyKeys parents age = callTestPlugin (GarbageCollectDirtyKeys parents age) + +getStoredKeys :: Session [Text] +getStoredKeys = callTestPlugin GetStoredKeys + +waitForTypecheck :: TextDocumentIdentifier -> Session Bool +waitForTypecheck tid = ideResultSuccess <$> waitForAction "typecheck" tid + +waitForBuildQueue :: Session () +waitForBuildQueue = callTestPlugin WaitForShakeQueue + +getFilesOfInterest :: Session [FilePath] +getFilesOfInterest = callTestPlugin GetFilesOfInterest + +waitForCustomMessage :: T.Text -> (A.Value -> Maybe res) -> Session res +waitForCustomMessage msg pred = + skipManyTill anyMessage $ satisfyMaybe $ \case + FromServerMess (SCustomMethod lbl) (NotMess NotificationMessage{_params = value}) + | lbl == msg -> pred value + _ -> Nothing + +waitForGC :: Session [T.Text] +waitForGC = waitForCustomMessage "ghcide/GC" $ \v -> + case A.fromJSON v of + A.Success x -> Just x + _ -> Nothing diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index bc12321681..39936ae2f4 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -83,18 +83,11 @@ library default-extensions: DataKinds, TypeOperators -- Plugin flags are designed for 'cabal install haskell-language-server': --- - Packaged plugins should be manual:False --- - Non packaged plugins and bulk flags should be manual:True -- - Bulk flags should be default:False -- - Individual flags should be default:True -flag all-plugins - description: Enable all non formatter plugins - default: False - manual: True - -flag all-formatters - description: Enable all fomatters +flag ignore-plugins-ghc-bounds + description: Force the inclusion of plugins even if they are not buildable by default with a specific ghc version default: False manual: True @@ -196,94 +189,94 @@ common example-plugins Ide.Plugin.Example2 common class - if flag(class) || flag(all-plugins) + if flag(class) && (impl(ghc < 9.0.1) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-class-plugin ^>=1.0.0.1 cpp-options: -Dclass common callHierarchy - if flag(callHierarchy) || flag(all-plugins) + if flag(callHierarchy) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-call-hierarchy-plugin ^>=1.0.0.0 cpp-options: -DcallHierarchy common haddockComments - if flag(haddockComments) || flag(all-plugins) + if flag(haddockComments) build-depends: hls-haddock-comments-plugin ^>=1.0.0.1 cpp-options: -DhaddockComments common eval - if flag(eval) || flag(all-plugins) + if flag(eval) build-depends: hls-eval-plugin ^>=1.2.0.0 cpp-options: -Deval common importLens - if flag(importLens) || flag(all-plugins) + if flag(importLens) build-depends: hls-explicit-imports-plugin ^>=1.0.0.1 cpp-options: -DimportLens common refineImports - if flag(refineImports) || flag(all-plugins) + if flag(refineImports) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-refine-imports-plugin ^>=1.0.0.0 cpp-options: -DrefineImports common rename - if flag(rename) || flag(all-plugins) + if flag(rename) build-depends: hls-rename-plugin ^>= 1.0.0.0 cpp-options: -Drename common retrie - if flag(retrie) || flag(all-plugins) + if flag(retrie) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-retrie-plugin ^>=1.0.0.1 cpp-options: -Dretrie common tactic - if flag(tactic) || flag(all-plugins) + if flag(tactic) && (impl(ghc < 9.0.1) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-tactics-plugin >=1.2.0.0 && <1.5 cpp-options: -Dtactic common hlint - if flag(hlint) || flag(all-plugins) + if flag(hlint) build-depends: hls-hlint-plugin ^>=1.0.0.2 cpp-options: -Dhlint common moduleName - if flag(moduleName) || flag(all-plugins) + if flag(moduleName) build-depends: hls-module-name-plugin ^>=1.0.0.0 cpp-options: -DmoduleName common pragmas - if flag(pragmas) || flag(all-plugins) + if flag(pragmas) build-depends: hls-pragmas-plugin ^>=1.0.0.0 cpp-options: -Dpragmas common splice - if flag(splice) || flag(all-plugins) + if flag(splice) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-splice-plugin ^>=1.0.0.1 cpp-options: -Dsplice -- formatters common floskell - if flag(floskell) || flag(all-formatters) + if flag(floskell) && (impl(ghc < 9.0.1) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-floskell-plugin ^>=1.0.0.0 cpp-options: -Dfloskell common fourmolu - if flag(fourmolu) || flag(all-formatters) + if flag(fourmolu) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-fourmolu-plugin ^>=1.0.0.0 cpp-options: -Dfourmolu common ormolu - if flag(ormolu) || flag(all-formatters) + if flag(ormolu) build-depends: hls-ormolu-plugin ^>=1.0.0.0 cpp-options: -Dormolu common stylishHaskell - if flag(stylishHaskell) || flag(all-formatters) + if flag(stylishHaskell) && (impl(ghc < 9.0.1) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-stylish-haskell-plugin ^>=1.0.0.0 cpp-options: -DstylishHaskell common brittany - if (flag(brittany) || flag(all-formatters)) + if flag(brittany) && (impl(ghc < 9.0.1) || flag(ignore-plugins-ghc-bounds)) build-depends: hls-brittany-plugin ^>=1.0.0.1 cpp-options: -Dbrittany @@ -443,42 +436,16 @@ test-suite func-test if flag(pedantic) ghc-options: -Werror -Wredundant-constraints - if flag(callHierarchy) || flag(all-plugins) - cpp-options: -DcallHierarchy - if flag(class) || flag(all-plugins) - cpp-options: -Dclass - if flag(haddockComments) || flag(all-plugins) - cpp-options: -DhaddockComments - if flag(eval) || flag(all-plugins) +-- Duplicating inclusion plugin conditions until tests are moved to their own packages + if flag(eval) cpp-options: -Deval - if flag(importLens) || flag(all-plugins) - cpp-options: -DimportLens - if flag(rename) || flag(all-plugins) - cpp-options: -Drename - if flag(retrie) || flag(all-plugins) - cpp-options: -Dretrie - if flag(tactic) || flag(all-plugins) - cpp-options: -Dtactic - if flag(hlint) || flag(all-plugins) - cpp-options: -Dhlint - if flag(moduleName) || flag(all-plugins) - cpp-options: -DmoduleName - if flag(pragmas) || flag(all-plugins) - cpp-options: -Dpragmas - if flag(splice) || flag(all-plugins) - cpp-options: -Dsplice - -- formatters - if flag(floskell) || flag(all-formatters) + if flag(floskell) && (impl(ghc < 9.0.1) || flag(ignore-plugins-ghc-bounds)) cpp-options: -Dfloskell - if flag(fourmolu) || flag(all-formatters) + if flag(fourmolu) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) cpp-options: -Dfourmolu - if flag(ormolu) || flag(all-formatters) + if flag(ormolu) cpp-options: -Dormolu - if flag(stylishHaskell) || flag(all-formatters) - cpp-options: -DstylishHaskell - if (flag(brittany) || flag(all-formatters)) - cpp-options: -Dbrittany test-suite wrapper-test type: exitcode-stdio-1.0 diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 60d7e182b3..b0f296a37a 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-graph -version: 1.5.0.0 +version: 1.5.1.0 synopsis: Haskell Language Server internal graph API description: Please see the README on GitHub at diff --git a/hls-graph/src/Development/IDE/Graph.hs b/hls-graph/src/Development/IDE/Graph.hs index 6bd49e66f1..1561abc35b 100644 --- a/hls-graph/src/Development/IDE/Graph.hs +++ b/hls-graph/src/Development/IDE/Graph.hs @@ -17,6 +17,9 @@ module Development.IDE.Graph( alwaysRerun, -- * Batching reschedule, + -- * Actions for inspecting the keys in the database + getDirtySet, + getKeysAndVisitedAge, ) where import Development.IDE.Graph.Database diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs index 5a4d083e7b..96481a6f31 100644 --- a/hls-graph/src/Development/IDE/Graph/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Database.hs @@ -8,11 +8,13 @@ module Development.IDE.Graph.Database( shakeRunDatabase, shakeRunDatabaseForKeys, shakeProfileDatabase, + shakeGetBuildStep, + shakeGetDatabaseKeys, + shakeGetDirtySet, shakeLastBuildKeys ) where - import Data.Dynamic -import Data.IORef +import Data.IORef (readIORef) import Data.Maybe import Development.IDE.Graph.Classes () import Development.IDE.Graph.Internal.Action @@ -41,6 +43,22 @@ shakeNewDatabase opts rules = do shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()]) shakeRunDatabase = shakeRunDatabaseForKeys Nothing +-- | Returns the set of dirty keys annotated with their age (in # of builds) +shakeGetDirtySet :: ShakeDatabase -> IO [(Key, Int)] +shakeGetDirtySet (ShakeDatabase _ _ db) = + fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db + +-- | Returns ann approximation of the database keys, +-- annotated with how long ago (in # builds) they were visited +shakeGetDatabaseKeys :: ShakeDatabase -> IO [(Key, Int)] +shakeGetDatabaseKeys (ShakeDatabase _ _ db) = getKeysAndVisitAge db + +-- | Returns the build number +shakeGetBuildStep :: ShakeDatabase -> IO Int +shakeGetBuildStep (ShakeDatabase _ _ db) = do + Step s <- readIORef $ databaseStep db + return s + -- Only valid if we never pull on the results, which we don't unvoid :: Functor m => m () -> m a unvoid = fmap undefined diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs index ef1168685b..ad895c17c3 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs @@ -15,6 +15,8 @@ module Development.IDE.Graph.Internal.Action , parallel , reschedule , runActions +, Development.IDE.Graph.Internal.Action.getDirtySet +, getKeysAndVisitedAge ) where import Control.Concurrent.Async @@ -123,3 +125,14 @@ runActions :: Database -> [Action a] -> IO [a] runActions db xs = do deps <- newIORef mempty runReaderT (fromAction $ parallel xs) $ SAction db deps + +-- | Returns the set of dirty keys annotated with their age (in # of builds) +getDirtySet :: Action [(Key, Int)] +getDirtySet = do + db <- getDatabase + liftIO $ fmap snd <$> Development.IDE.Graph.Internal.Database.getDirtySet db + +getKeysAndVisitedAge :: Action [(Key, Int)] +getKeysAndVisitedAge = do + db <- getDatabase + liftIO $ Development.IDE.Graph.Internal.Database.getKeysAndVisitAge db diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 5717831c7b..4b8a1d985c 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -11,7 +11,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet) where +module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where import Control.Concurrent.Async import Control.Concurrent.Extra @@ -188,6 +188,16 @@ getDirtySet db = do calcAgeStatus (Dirty x)=calcAge <$> x calcAgeStatus _ = Nothing return $ mapMaybe ((secondM.secondM) calcAgeStatus) dbContents + +-- | Returns ann approximation of the database keys, +-- annotated with how long ago (in # builds) they were visited +getKeysAndVisitAge :: Database -> IO [(Key, Int)] +getKeysAndVisitAge db = do + values <- Ids.elems (databaseValues db) + Step curr <- readIORef (databaseStep db) + let keysWithVisitAge = mapMaybe (secondM (fmap getAge . getResult)) values + getAge Result{resultVisited = Step s} = curr - s + return keysWithVisitAge -------------------------------------------------------------------------------- -- Lazy IO trick diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 3adc0698d5..1bc0ced3a2 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -58,6 +58,8 @@ data SAction = SAction { actionDeps :: !(IORef ResultDeps) } +getDatabase :: Action Database +getDatabase = Action $ asks actionDatabase --------------------------------------------------------------------- -- DATABASE diff --git a/hls-plugin-api/src/Ide/Plugin/Config.hs b/hls-plugin-api/src/Ide/Plugin/Config.hs index dce08c6e24..6a286a5191 100644 --- a/hls-plugin-api/src/Ide/Plugin/Config.hs +++ b/hls-plugin-api/src/Ide/Plugin/Config.hs @@ -37,8 +37,7 @@ data CheckParents -- Note that ordering of constructors is meaningful and must be monotonically -- increasing in the scenarios where parents are checked = NeverCheck - | CheckOnClose - | CheckOnSaveAndClose + | CheckOnSave | AlwaysCheck deriving stock (Eq, Ord, Show, Generic) deriving anyclass (FromJSON, ToJSON) @@ -61,7 +60,7 @@ data Config = instance Default Config where def = Config - { checkParents = CheckOnSaveAndClose + { checkParents = CheckOnSave , checkProject = True , hlintOn = True , diagnosticsOnChange = True diff --git a/install/README.md b/install/README.md new file mode 100644 index 0000000000..4021eccf88 --- /dev/null +++ b/install/README.md @@ -0,0 +1,8 @@ +# hls-install + +This directory contains the `hls-install` project, an Haskell Language Server installer. +It is used when [installing from sources](https://haskell-language-server.readthedocs.io/en/latest/installation.html#building). + +Unlike other subdirectories (e.g. `hls-graph` or `ghcide`), this is not another package of the HLS project, but another project entirely (with another `stack.yaml`, another `cabal.project`, etc.). It just so happens to be in a subdirectory of HLS project for convenience, as this is tightly related to HLS. + +The rationale behind this choice is to keep the installer completely isolated from main HLS code: different dependencies, different builds, etc. diff --git a/install/hie-cabal.yaml b/install/hie-cabal.yaml deleted file mode 100644 index 8e3e7a02bd..0000000000 --- a/install/hie-cabal.yaml +++ /dev/null @@ -1,3 +0,0 @@ -cradle: - cabal: - component: "lib:hls-install" diff --git a/install/hie-stack.yaml b/install/hie-stack.yaml deleted file mode 100644 index 762c2dff79..0000000000 --- a/install/hie-stack.yaml +++ /dev/null @@ -1,3 +0,0 @@ -cradle: - stack: - component: "hls-install:lib" diff --git a/plugins/hls-tactics-plugin/src/Wingman/Judgements/SYB.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements/SYB.hs index ba3bba4378..db6e6e02c9 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Judgements/SYB.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements/SYB.hs @@ -85,8 +85,14 @@ sameTypeModuloLastApp = _ -> False -metaprogramQ :: SrcSpan -> GenericQ [(SrcSpan, T.Text)] -metaprogramQ ss = everythingContaining ss $ mkQ mempty $ \case +metaprogramAtQ :: SrcSpan -> GenericQ [(SrcSpan, T.Text)] +metaprogramAtQ ss = everythingContaining ss $ mkQ mempty $ \case + L new_span (WingmanMetaprogram program) -> pure (new_span, T.pack $ unpackFS $ program) + (_ :: LHsExpr GhcTc) -> mempty + + +metaprogramQ :: GenericQ [(SrcSpan, T.Text)] +metaprogramQ = everything (<>) $ mkQ mempty $ \case L new_span (WingmanMetaprogram program) -> pure (new_span, T.pack $ unpackFS $ program) (_ :: LHsExpr GhcTc) -> mempty diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index d607aeb96a..8e6319d806 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -26,12 +26,12 @@ import Data.Set (Set) import qualified Data.Set as S import qualified Data.Text as T import Data.Traversable -import Development.IDE (getFilesOfInterestUntracked, ShowDiagnostic (ShowDiag), srcSpanToRange) -import Development.IDE (hscEnv) +import Development.IDE (hscEnv, getFilesOfInterestUntracked, ShowDiagnostic (ShowDiag), srcSpanToRange, defineNoDiagnostics, IdeAction) +import Development.IDE.Core.PositionMapping (idDelta) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Rules (usePropertyAction) import Development.IDE.Core.Service (runAction) -import Development.IDE.Core.Shake (IdeState (..), uses, define, use) +import Development.IDE.Core.Shake (IdeState (..), uses, define, use, addPersistentRule) import qualified Development.IDE.Core.Shake as IDE import Development.IDE.Core.UseStale import Development.IDE.GHC.Compat hiding (empty) @@ -47,8 +47,7 @@ import qualified Ide.Plugin.Config as Plugin import Ide.Plugin.Properties import Ide.PluginUtils (usePropertyLsp) import Ide.Types (PluginId) -import Language.Haskell.GHC.ExactPrint (Transform) -import Language.Haskell.GHC.ExactPrint (modifyAnnsT, addAnnotationsForPretty) +import Language.Haskell.GHC.ExactPrint (Transform, modifyAnnsT, addAnnotationsForPretty) import Language.LSP.Server (MonadLsp, sendNotification) import Language.LSP.Types hiding (SemanticTokenAbsolute (length, line), @@ -60,7 +59,7 @@ import Retrie (transformA) import Wingman.Context import Wingman.GHC import Wingman.Judgements -import Wingman.Judgements.SYB (everythingContaining, metaprogramQ) +import Wingman.Judgements.SYB (everythingContaining, metaprogramQ, metaprogramAtQ) import Wingman.Judgements.Theta import Wingman.Range import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax) @@ -80,6 +79,9 @@ tcCommandName = T.pack . show runIde :: String -> String -> IdeState -> Action a -> IO a runIde herald action state = runAction ("Wingman." <> herald <> "." <> action) state +runIdeAction :: String -> String -> IdeState -> IdeAction a -> IO a +runIdeAction herald action state = IDE.runIdeAction ("Wingman." <> herald <> "." <> action) (shakeExtras state) + runCurrentIde :: forall a r @@ -126,6 +128,21 @@ unsafeRunStaleIde herald state nfp a = do (r, _) <- MaybeT $ runIde herald (show a) state $ IDE.useWithStale a nfp pure r +unsafeRunStaleIdeFast + :: forall a r + . ( r ~ RuleResult a + , Eq a , Hashable a , Show a , Typeable a , NFData a + , Show r, Typeable r, NFData r + ) + => String + -> IdeState + -> NormalizedFilePath + -> a + -> MaybeT IO r +unsafeRunStaleIdeFast herald state nfp a = do + (r, _) <- MaybeT $ runIdeAction herald (show a) state $ IDE.useWithStaleFast a nfp + pure r + ------------------------------------------------------------------------------ @@ -522,6 +539,14 @@ instance NFData WriteDiagnostics type instance RuleResult WriteDiagnostics = () +data GetMetaprograms = GetMetaprograms + deriving (Eq, Show, Typeable, Generic) + +instance Hashable GetMetaprograms +instance NFData GetMetaprograms + +type instance RuleResult GetMetaprograms = [(Tracked 'Current RealSrcSpan, T.Text)] + wingmanRules :: PluginId -> Rules () wingmanRules plId = do define $ \WriteDiagnostics nfp -> @@ -553,6 +578,21 @@ wingmanRules plId = do , Just () ) + defineNoDiagnostics $ \GetMetaprograms nfp -> do + TrackedStale tcg tcg_map <- fmap tmrTypechecked <$> useWithStale_ TypeCheck nfp + let scrutinees = traverse (metaprogramQ . tcg_binds) tcg + return $ Just $ flip mapMaybe scrutinees $ \aged@(unTrack -> (ss, program)) -> do + case ss of + RealSrcSpan r _ -> do + rss' <- mapAgeTo tcg_map $ unsafeCopyAge aged r + pure (rss', program) + UnhelpfulSpan _ -> Nothing + + -- This persistent rule helps to avoid blocking HLS hover providers at startup + -- Without it, the GetMetaprograms rule blocks on typecheck and prevents other + -- hover providers from being used to produce a response + addPersistentRule GetMetaprograms $ \_ -> return $ Just ([], idDelta, Nothing) + action $ do files <- getFilesOfInterestUntracked void $ uses WriteDiagnostics $ Map.keys files @@ -607,7 +647,7 @@ getMetaprogramAtSpan getMetaprogramAtSpan (unTrack -> ss) = fmap snd . listToMaybe - . metaprogramQ ss + . metaprogramAtQ ss . tcg_binds . unTrack diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/Metaprogram.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/Metaprogram.hs index 1cdee0b02d..096ccc0b79 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/Metaprogram.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/Metaprogram.hs @@ -15,18 +15,14 @@ import Control.Monad.Trans.Maybe import Data.List (find) import Data.Maybe import qualified Data.Text as T -import Data.Traversable import Development.IDE (positionToRealSrcLoc) import Development.IDE (realSrcSpanToRange) -import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake (IdeState (..)) import Development.IDE.Core.UseStale import Development.IDE.GHC.Compat hiding (empty) import Ide.Types import Language.LSP.Types import Prelude hiding (span) -import Wingman.GHC -import Wingman.Judgements.SYB (metaprogramQ) import Wingman.LanguageServer import Wingman.Metaprogramming.Parser (attempt_it) import Wingman.Types @@ -38,13 +34,14 @@ hoverProvider :: PluginMethodHandler IdeState TextDocumentHover hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurrent -> pos) _) | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do let loc = fmap (realSrcLocSpan . positionToRealSrcLoc nfp) pos + stale = unsafeRunStaleIdeFast "hoverProvider" state nfp cfg <- getTacticConfig plId liftIO $ fromMaybeT (Right Nothing) $ do - holes <- getMetaprogramsAtSpan state nfp $ RealSrcSpan (unTrack loc) Nothing + holes <- stale GetMetaprograms fmap (Right . Just) $ - case (find (flip containsSpan (unTrack loc) . unTrack . fst) holes) of + case find (flip containsSpan (unTrack loc) . unTrack . fst) holes of Just (trss, program) -> do let tr_range = fmap realSrcSpanToRange trss rsl = realSrcSpanStart $ unTrack trss @@ -59,27 +56,5 @@ hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurr Nothing -> empty hoverProvider _ _ _ = pure $ Right Nothing - fromMaybeT :: Functor m => a -> MaybeT m a -> m a fromMaybeT def = fmap (fromMaybe def) . runMaybeT - - -getMetaprogramsAtSpan - :: IdeState - -> NormalizedFilePath - -> SrcSpan - -> MaybeT IO [(Tracked 'Current RealSrcSpan, T.Text)] -getMetaprogramsAtSpan state nfp ss = do - let stale a = runStaleIde "getMetaprogramsAtSpan" state nfp a - - TrackedStale tcg tcg_map <- fmap (fmap tmrTypechecked) $ stale TypeCheck - - let scrutinees = traverse (metaprogramQ ss . tcg_binds) tcg - for scrutinees $ \aged@(unTrack -> (ss, program)) -> do - case ss of - RealSrcSpan r _ -> do - rss' <- liftMaybe $ mapAgeTo tcg_map $ unsafeCopyAge aged r - pure (rss', program) - UnhelpfulSpan _ -> empty - - diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 10939035ef..e4b7cec41e 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -16,6 +16,7 @@ import Data.Default import Data.List (sort) import qualified Data.Text as T import Development.IDE.Core.Rules +import Development.IDE.Core.Tracing (withTelemetryLogger) import Development.IDE.Graph (ShakeOptions (shakeThreads)) import Development.IDE.Main (isLSP) import qualified Development.IDE.Main as Main @@ -90,7 +91,7 @@ hlsLogger = G.Logger $ \pri txt -> -- --------------------------------------------------------------------- runLspMode :: GhcideArguments -> IdePlugins IdeState -> IO () -runLspMode ghcideArgs@GhcideArguments{..} idePlugins = do +runLspMode ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryLogger $ \telemetryLogger -> do whenJust argsCwd IO.setCurrentDirectory dir <- IO.getCurrentDirectory LSP.setupLogger argsLogFile ["hls", "hie-bios"] @@ -105,7 +106,7 @@ runLspMode ghcideArgs@GhcideArguments{..} idePlugins = do Main.defaultMain def { Main.argCommand = argsCommand , Main.argsHlsPlugins = idePlugins - , Main.argsLogger = pure hlsLogger + , Main.argsLogger = pure hlsLogger <> pure telemetryLogger , Main.argsThreads = if argsThreads == 0 then Nothing else Just $ fromIntegral argsThreads , Main.argsIdeOptions = \_config sessionLoader -> let defOptions = Ghcide.defaultIdeOptions sessionLoader diff --git a/test/functional/Main.hs b/test/functional/Main.hs index ff9473e56c..c8c1651701 100644 --- a/test/functional/Main.hs +++ b/test/functional/Main.hs @@ -34,7 +34,7 @@ main = defaultTestRunner , FunctionalLiquid.tests , HieBios.tests , Highlight.tests - , Progress.tests + , ignoreInEnv [HostOS Windows, GhcVer GHC90] "Tests gets stuck in ci" $ Progress.tests , Reference.tests , Symbol.tests , TypeDefinition.tests diff --git a/test/utils/Test/Hls/Flags.hs b/test/utils/Test/Hls/Flags.hs index ce17c7568e..7ff17af076 100644 --- a/test/utils/Test/Hls/Flags.hs +++ b/test/utils/Test/Hls/Flags.hs @@ -1,28 +1,13 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-unused-imports #-} -- | Module for disabling tests if their plugins are disabled +-- DEPRECATED: To be removed when all plugin tests are in their own packages module Test.Hls.Flags where import Test.Hls (TestTree, ignoreTestBecause) -- * Plugin dependent tests --- | Disable test unless the class flag is set -requiresClassPlugin :: TestTree -> TestTree -#if class -requiresClassPlugin = id -#else -requiresClassPlugin = ignoreTestBecause "Class plugin disabled" -#endif - --- | Disable test unless the haddockComments flag is set -requiresHaddockCommentsPlugin :: TestTree -> TestTree -#if haddockComments -requiresHaddockCommentsPlugin = id -#else -requiresHaddockCommentsPlugin = ignoreTestBecause "HaddockComments plugin disabled" -#endif - -- | Disable test unless the eval flag is set requiresEvalPlugin :: TestTree -> TestTree #if eval @@ -31,71 +16,6 @@ requiresEvalPlugin = id requiresEvalPlugin = ignoreTestBecause "Eval plugin disabled" #endif --- | Disable test unless the importLens flag is set -requiresImportLensPlugin :: TestTree -> TestTree -#if importLens -requiresImportLensPlugin = id -#else -requiresImportLensPlugin = ignoreTestBecause "ImportLens plugin disabled" -#endif - --- | Disable test unless the rename flag is set -requiresRenamePlugin :: TestTree -> TestTree -#if rename -requiresRenamePlugin = id -#else -requiresRenamePlugin = ignoreTestBecause "Rename plugin disabled" -#endif - --- | Disable test unless the retrie flag is set -requiresRetriePlugin :: TestTree -> TestTree -#if retrie -requiresRetriePlugin = id -#else -requiresRetriePlugin = ignoreTestBecause "Retrie plugin disabled" -#endif - --- | Disable test unless the tactic flag is set -requiresTacticPlugin :: TestTree -> TestTree -#if tactic -requiresTacticPlugin = id -#else -requiresTacticPlugin = ignoreTestBecause "Tactic plugin disabled" -#endif - --- | Disable test unless the hlint flag is set -requiresHlintPlugin :: TestTree -> TestTree -#if hlint -requiresHlintPlugin = id -#else -requiresHlintPlugin = ignoreTestBecause "Hlint plugin disabled" -#endif - --- | Disable test unless the moduleName flag is set -requiresModuleNamePlugin :: TestTree -> TestTree -#if moduleName -requiresModuleNamePlugin = id -#else -requiresModuleNamePlugin = ignoreTestBecause "ModuleName plugin disabled" -#endif - --- | Disable test unless the pragmas flag is set -requiresPragmasPlugin :: TestTree -> TestTree -#if pragmas -requiresPragmasPlugin = id -#else -requiresPragmasPlugin = ignoreTestBecause "Pragmas plugin disabled" -#endif - --- | Disable test unless the splice flag is set -requiresSplicePlugin :: TestTree -> TestTree -#if splice -requiresSplicePlugin = id -#else -requiresSplicePlugin = ignoreTestBecause "Splice plugin disabled" -#endif - - -- * Formatters -- | Disable test unless the floskell flag is set requiresFloskellPlugin :: TestTree -> TestTree @@ -120,20 +40,3 @@ requiresOrmoluPlugin = id #else requiresOrmoluPlugin = ignoreTestBecause "Ormolu plugin disabled" #endif - --- | Disable test unless the stylishHaskell flag is set -requiresStylishHaskellPlugin :: TestTree -> TestTree -#if stylishHaskell -requiresStylishHaskellPlugin = id -#else -requiresStylishHaskellPlugin = ignoreTestBecause "StylishHaskell plugin disabled" -#endif - --- | Disable test unless the brittany flag is set -requiresBrittanyPlugin :: TestTree -> TestTree -#if brittany -requiresBrittanyPlugin = id -#else -requiresBrittanyPlugin = ignoreTestBecause "Brittany plugin disabled" -#endif -