diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,45 +1,5 @@ # `ghcide` - A library for building Haskell IDE tooling -Our vision is that you should build an IDE by combining: - -![vscode](https://raw.githubusercontent.com/haskell/ghcide/master/img/vscode2.png) - -* [`hie-bios`](https://github.com/mpickering/hie-bios) for determining where your files are, what are their dependencies, what extensions are enabled and so on; -* `ghcide` (i.e. this library) for defining how to type check, when to type check, and producing diagnostic messages; -* A bunch of plugins that haven't yet been written, e.g. [`hie-hlint`](https://github.com/ndmitchell/hlint) and [`hie-ormolu`](https://github.com/tweag/ormolu), to choose which features you want; -* [`haskell-lsp`](https://github.com/alanz/haskell-lsp) for sending those messages to a [Language Server Protocol (LSP)](https://microsoft.github.io/language-server-protocol/) server; -* An LSP client for your editor. - -There are more details about our approach [in this blog post](https://4ta.uk/p/shaking-up-the-ide). - -## Features - -`ghcide` already exports the following features via the lsp protocol: - -| Feature | LSP name | -| - | - | -| Display error messages (parse errors, typecheck errors, etc.) and enabled warnings. | diagnostics | -| Go to definition in local package | definition | -| Display type and source module of values | hover | -| Remove redundant imports, replace suggested typos for values and module imports, fill type holes, insert missing type signatures, add suggested ghc extensions | codeAction (quickfix) | - - -## Limitations to Multi-Component support - -`ghcide` supports loading multiple components into the same session so that -features such as go-to definition work across components. However, there are -some limitations to this. - -1. You will get much better results currently manually specifying the hie.yaml file. -Until tools like cabal and stack provide the right interface to support multi-component -projects, it is always advised to specify explicitly how your project partitions. -2. Cross-component features only work if you have loaded at least one file -from each component. -3. There is a known issue where if you have three components, such that A depends on B which depends on C -then if you load A and C into the session but not B then under certain situations you -can get strange errors about a type coming from two different places. See [this repo](https://github.com/fendor/ghcide-bad-interface-files) for -a simple reproduction of the bug. - ## Using it `ghcide` is not an end-user tool, [don't use `ghcide`](https://neilmitchell.blogspot.com/2020/09/dont-use-ghcide-anymore-directly.html) directly (more about the rationale [here](https://github.com/haskell/ghcide/pull/939)). @@ -47,294 +7,4 @@ [`haskell-language-server`](http://github.com/haskell/haskell-language-server) is an LSP server built on top of `ghcide` with additional features and a user friendly deployment model. To get it, simply install the [Haskell extension](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) in VS Code, or download prebuilt binaries from the [haskell-language-server](https://github.com/haskell/haskell-language-server) project page. -The instructions below are meant for developers interested in setting up ghcide as an LSP server for testing purposes. - -### Install `ghcide` - -#### With Nix - -Note that you need to compile `ghcide` with the same `ghc` as the project you are working on. - -1. If the `ghc` you are using matches the version (or better is) from `nixpkgs` it‘s easiest to use the `ghcide` from `nixpkgs`. You can do so via - ``` - nix-env -iA haskellPackages.ghcide - ``` - or e.g. including `pkgs.haskellPackages.ghcide` in your projects `shell.nix`. - Depending on your `nixpkgs` channel that might not be the newest `ghcide`, though. - -2. If your `ghc` does not match nixpkgs you should try the [ghcide-nix repository](https://github.com/cachix/ghcide-nix) - which provides a `ghcide` via the `haskell.nix` infrastructure. - -#### With Cabal or Stack - -First install the `ghcide` binary using `stack` or `cabal`, e.g. - -1. `git clone https://github.com/haskell/ghcide.git` -2. `cd ghcide` -3. `cabal install` or `stack install` (and make sure `~/.local/bin` is on your `$PATH`) - -It's important that `ghcide` is compiled with the same compiler you use to build your projects. - -### Test `ghcide` - -Next, check that `ghcide` is capable of loading your code. Change to the project directory and run `ghcide`, which will try and load everything using the same code as the IDE, but in a way that's much easier to understand. For example, taking the example of [`shake`](https://github.com/ndmitchell/shake), running `ghcide` gives some error messages and warnings before reporting at the end: - -```console -Files that failed: - * .\model\Main.hs - * .\model\Model.hs - * .\model\Test.hs - * .\model\Util.hs - * .\output\docs\Main.hs - * .\output\docs\Part_Architecture_md.hs -Completed (152 worked, 6 failed) -``` - -Of the 158 files in Shake, as of this moment, 152 can be loaded by the IDE, but 6 can't (error messages for the reasons they can't be loaded are given earlier). The failing files are all prototype work or test output, meaning I can confidently use Shake. - -The `ghcide` executable mostly relies on [`hie-bios`](https://github.com/mpickering/hie-bios) to do the difficult work of setting up your GHC environment. If it doesn't work, see [the `hie-bios` manual](https://github.com/mpickering/hie-bios#readme) to get it working. My default fallback is to figure it out by hand and create a `direct` style [`hie.yaml`](https://github.com/ndmitchell/shake/blob/master/hie.yaml) listing the command line arguments to load the project. - -If you can't get `ghcide` working outside the editor, see [this setup troubleshooting guide](docs/Setup.md). Once you have got `ghcide` working outside the editor, the next step is to pick which editor to integrate with. - -### Optimal project setup - -`ghcide` has been designed to handle projects with hundreds or thousands of modules. If `ghci` can handle it, then `ghcide` should be able to handle it. The only caveat is that this currently requires GHC >= 8.8, and that the first time a module is loaded in the editor will trigger generation of support files in the background if those do not already exist. - -### Using with VS Code - -The [Haskell](https://marketplace.visualstudio.com/items?itemName=haskell.haskell) extension has a setting for ghcide. - -### Using with Atom - -You can follow the [instructions](https://github.com/moodmosaic/ide-haskell-ghcide#readme) to install with `apm`. - -### Using with Sublime Text - -* Install [LSP](https://packagecontrol.io/packages/LSP) -* Press Ctrl+Shift+P or Cmd+Shift+P in Sublime Text and search for *Preferences: LSP Settings*, then paste these settings -``` -{ - "clients": - { - "ghcide": - { - "enabled" : true, - "languageId": "haskell", - "command" : ["ghcide", "--lsp"], - "scopes" : ["source.haskell"], - "syntaxes" : ["Packages/Haskell/Haskell.sublime-syntax"] - } - } -} -``` - -### Using with Emacs - -If you don't already have [MELPA](https://melpa.org/#/) package installation configured, visit MELPA [getting started](https://melpa.org/#/getting-started) page to get set up. Then, install [`use-package`](https://melpa.org/#/use-package). - -Now you have a choice of two different Emacs packages which can be used to communicate with the `ghcide` LSP server: - -+ `lsp-ui` -+ `eglot` (requires Emacs 26.1+) - -In each case, you can enable support by adding the shown lines to your `.emacs`: - -#### lsp-ui - -```elisp -;; LSP -(use-package flycheck - :ensure t - :init - (global-flycheck-mode t)) -(use-package yasnippet - :ensure t) -(use-package lsp-mode - :ensure t - :hook (haskell-mode . lsp) - :commands lsp) -(use-package lsp-ui - :ensure t - :commands lsp-ui-mode) -(use-package lsp-haskell - :ensure t - :config - (setq lsp-haskell-process-path-hie "ghcide") - (setq lsp-haskell-process-args-hie '()) - ;; Comment/uncomment this line to see interactions between lsp client/server. - ;;(setq lsp-log-io t) -) -``` - -#### eglot - -````elisp -(use-package eglot - :ensure t - :config - (add-to-list 'eglot-server-programs '(haskell-mode . ("ghcide" "--lsp")))) -```` - -### Using with Vim/Neovim - -#### LanguageClient-neovim -Install [LanguageClient-neovim](https://github.com/autozimu/LanguageClient-neovim) - -Add this to your vim config: -```vim -let g:LanguageClient_rootMarkers = ['*.cabal', 'stack.yaml'] -let g:LanguageClient_serverCommands = { - \ 'rust': ['rls'], - \ 'haskell': ['ghcide', '--lsp'], - \ } -``` - -Refer to `:he LanguageClient` for more details on usage and configuration. - -#### vim-lsp -Install [vim-lsp](https://github.com/prabirshrestha/vim-lsp). - -Add this to your vim config: - -```vim -au User lsp_setup call lsp#register_server({ - \ 'name': 'ghcide', - \ 'cmd': {server_info->['/your/path/to/ghcide', '--lsp']}, - \ 'whitelist': ['haskell'], - \ }) -``` - -To verify it works move your cursor over a symbol and run `:LspHover`. - -### coc.nvim - -Install [coc.nvim](https://github.com/neoclide/coc.nvim) - -Add this to your coc-settings.json (which you can edit with :CocConfig): - -```json -{ - "languageserver": { - "haskell": { - "command": "ghcide", - "args": [ - "--lsp" - ], - "rootPatterns": [ - ".stack.yaml", - ".hie-bios", - "BUILD.bazel", - "cabal.config", - "package.yaml" - ], - "filetypes": [ - "hs", - "lhs", - "haskell" - ] - } - } -} -``` - -Here's a nice article on setting up neovim and coc: [Vim and Haskell in -2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/) (this is actually for haskell-ide, not ghcide) - -Here is a Docker container that pins down the build and configuration for -Neovim and ghcide on a minimal Debian 10 base system: -[docker-ghcide-neovim](https://github.com/carlohamalainen/docker-ghcide-neovim/). - -### SpaceVim - -In the `autocomplete` layer, add the `autocomplete_method` option to force the use of `coc`: - -```toml -[[layers]] - name = 'autocomplete' - auto-completion-return-key-behavior = "complete" - auto-completion-tab-key-behavior = "smart" - [options] - autocomplete_method = "coc" -``` - -Add this to your coc-settings.json (which you can edit with :CocConfig): - -```json -{ - "languageserver": { - "haskell": { - "command": "ghcide", - "args": [ - "--lsp" - ], - "rootPatterns": [ - ".stack.yaml", - ".hie-bios", - "BUILD.bazel", - "cabal.config", - "package.yaml" - ], - "filetypes": [ - "hs", - "lhs", - "haskell" - ] - } - } -} -``` - -This example above describes a setup in which `ghcide` is installed -using `stack install ghcide` within a project. - -### Using with Kakoune - -Install [kak-lsp](https://github.com/ul/kak-lsp). - -Change `kak-lsp.toml` to include this: - -```toml -[language.haskell] -filetypes = ["haskell"] -roots = ["Setup.hs", "stack.yaml", "*.cabal", "cabal.project", "hie.yaml"] -command = "ghcide" -args = ["--lsp"] -``` - -## Hacking on ghcide - -To build and work on `ghcide` itself, you should use cabal, e.g., -running `cabal test` will execute the test suite. You can use `stack test` too, but -note that some tests will fail, and none of the maintainers are currently using `stack`. - -If you are using Nix, there is a Cachix nix-shell cache for all the supported platforms: `cachix use haskell-ghcide`. - -If you are using Windows, you should disable the `auto.crlf` setting and configure your editor to use LF line endings, directly or making it use the existing `.editor-config`. - -If you are chasing down test failures, you can use the tasty-rerun feature by running tests as - - cabal test --test-options"--rerun" - -This writes a log file called `.tasty-rerun-log` of the failures, and only runs those. -See the [tasty-rerun](https://hackage.haskell.org/package/tasty-rerun-1.1.17/docs/Test-Tasty-Ingredients-Rerun.html) documentation for other options. - -If you are touching performance sensitive code, take the time to run a differential -benchmark between HEAD and master using the benchHist script. This assumes that -"master" points to the upstream master. - -Run the benchmarks with `cabal bench`. - -It should take around 15 minutes and the results will be stored in the `bench-results` folder. To interpret the results, see the comments in the `bench/hist/Main.hs` module. - -More details in [bench/README](bench/README.md) - - -## History and relationship to other Haskell IDE's - -The teams behind this project and the [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme) have agreed to join forces under the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server), see the [original announcement](https://neilmitchell.blogspot.com/2020/01/one-haskell-ide-to-rule-them-all.html). The technical work is ongoing, with the likely model being that this project serves as the core, while plugins and integrations are kept in the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server). - -The code behind `ghcide` was originally developed by [Digital Asset](https://digitalasset.com/) as part of the [DAML programming language](https://github.com/digital-asset/daml). DAML is a smart contract language targeting distributed-ledger runtimes, based on [GHC](https://www.haskell.org/ghc/) with custom language extensions. The DAML programming language has [an IDE](https://webide.daml.com/), and work was done to separate off a reusable Haskell-only IDE (what is now `ghcide`) which the [DAML IDE then builds upon](https://github.com/digital-asset/daml/tree/master/compiler/damlc). Since that time, there have been various [non-Digital Asset contributors](https://github.com/haskell/ghcide/graphs/contributors), in addition to continued investment by Digital Asset. The project has been handed over to Haskell.org as of September 2020. - -The Haskell community [has](https://github.com/DanielG/ghc-mod) [various](https://github.com/chrisdone/intero) [IDE](https://github.com/rikvdkleij/intellij-haskell) [choices](http://leksah.org/), but the one that had been gathering momentum is [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme). Our project owes a debt of gratitude to the `haskell-ide-engine`. We reuse libraries from their ecosystem, including [`hie-bios`](https://github.com/mpickering/hie-bios#readme) (a likely future environment setup layer in `haskell-ide-engine`), [`haskell-lsp`](https://github.com/alanz/haskell-lsp#readme) and [`lsp-test`](https://github.com/bubba/lsp-test#readme) (the `haskell-ide-engine` [LSP protocol](https://microsoft.github.io/language-server-protocol/) pieces). We make heavy use of their contributions to GHC itself, in particular the work to make GHC take string buffers rather than files. - -The best summary of the architecture of `ghcide` is available [this talk](https://www.youtube.com/watch?v=cijsaeWNf2E&list=PLxxF72uPfQVRdAsvj7THoys-nVj-oc4Ss) ([slides](https://ndmitchell.com/downloads/slides-making_a_haskell_ide-07_sep_2019.pdf)), given at [MuniHac 2019](https://munihac.de/2019.html). However, since that talk the project has renamed from `hie-core` to `ghcide`, and the repo has moved to [this location](https://github.com/haskell/ghcide/). +Set-up and usage instructions can be found on [haskell-language-server documentation](https://haskell-language-server.readthedocs.io/en/latest/components/ghcide.html) diff --git a/exe/Arguments.hs b/exe/Arguments.hs --- a/exe/Arguments.hs +++ b/exe/Arguments.hs @@ -20,7 +20,6 @@ ,argsVerbose :: Bool ,argsCommand :: Command ,argsConservativeChangeTracking :: Bool - ,argsMonitoringPort :: Int } getArguments :: IdePlugins IdeState -> IO Arguments @@ -43,7 +42,6 @@ <*> switch (short 'd' <> long "verbose" <> help "Include internal events in logging output") <*> (commandP plugins <|> lspCommand <|> checkCommand) <*> switch (long "conservative-change-tracking" <> help "disable reactive change tracking (for testing/debugging)") - <*> option auto (long "monitoring-port" <> metavar "PORT" <> value 8999 <> showDefault <> help "Port to use for EKG monitoring (if the binary is built with EKG)") where checkCommand = Check <$> many (argument str (metavar "FILES/DIRS...")) lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP client") diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,29 +1,24 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above {-# LANGUAGE TemplateHaskell #-} module Main(main) where import Arguments (Arguments (..), getArguments) -import Control.Monad.Extra (unless) import Control.Monad.IO.Class (liftIO) import Data.Default (def) import Data.Function ((&)) import Data.Version (showVersion) import Development.GitRev (gitHash) -import Development.IDE (action) -import Development.IDE.Core.OfInterest (kick) import Development.IDE.Core.Rules (mainRule) import qualified Development.IDE.Core.Rules as Rules -import Development.IDE.Core.Tracing (withTelemetryLogger) +import Development.IDE.Core.Tracing (withTelemetryRecorder) import qualified Development.IDE.Main as IDEMain -import qualified Development.IDE.Monitoring.EKG as EKG import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde -import Development.IDE.Types.Logger (Logger (Logger), - LoggingColumn (DataColumn, PriorityColumn), +import Development.IDE.Types.Options +import Ide.Logger (LoggingColumn (..), Pretty (pretty), Priority (Debug, Error, Info), WithPriority (WithPriority, priority), @@ -33,16 +28,14 @@ layoutPretty, makeDefaultStderrRecorder, renderStrict) -import qualified Development.IDE.Types.Logger as Logger -import Development.IDE.Types.Options -import GHC.Stack (emptyCallStack) +import qualified Ide.Logger as Logger import Ide.Plugin.Config (Config (checkParents, checkProject)) import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types (PluginDescriptor (pluginNotificationHandlers), defaultPluginDescriptor, mkPluginNotificationHandler) +import Language.LSP.Protocol.Message as LSP import Language.LSP.Server as LSP -import Language.LSP.Types as LSP import Paths_ghcide (version) import qualified System.Directory.Extra as IO import System.Environment (getExecutablePath) @@ -73,11 +66,11 @@ <> gitHashSection main :: IO () -main = withTelemetryLogger $ \telemetryLogger -> do +main = withTelemetryRecorder $ \telemetryRecorder -> do -- stderr recorder just for plugin cli commands pluginCliRecorder <- cmapWithPrio pretty - <$> makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Info + <$> makeDefaultStderrRecorder (Just [ThreadIdColumn, PriorityColumn, DataColumn]) let hlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde pluginCliRecorder)) -- WARNING: If you write to stdout before runLanguageServer @@ -94,14 +87,14 @@ let minPriority = if argsVerbose then Debug else Info - docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) minPriority + docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) (lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder (lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder -- This plugin just installs a handler for the `initialized` notification, which then -- picks up the LSP environment and feeds it to our recorders - let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback") - { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SInitialized $ \_ _ _ _ -> do + let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback" "Internal plugin") + { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SMethod_Initialized $ \_ _ _ _ -> do env <- LSP.getLspEnv liftIO $ (cb1 <> cb2) env } @@ -111,32 +104,24 @@ (lspLogRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions) & cfilter (\WithPriority{ priority } -> priority >= minPriority)) <> (lspMessageRecorder & cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions) - & cfilter (\WithPriority{ priority } -> priority >= Error)) - - -- exists so old-style logging works. intended to be phased out - let logger = Logger $ \p m -> Logger.logger_ docWithFilteredPriorityRecorder (WithPriority p emptyCallStack (pretty m)) + & cfilter (\WithPriority{ priority } -> priority >= Error)) <> + telemetryRecorder let recorder = docWithFilteredPriorityRecorder & cmapWithPrio pretty let arguments = if argsTesting - then IDEMain.testing (cmapWithPrio LogIDEMain recorder) logger hlsPlugins - else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) logger hlsPlugins + then IDEMain.testing (cmapWithPrio LogIDEMain recorder) argsCwd hlsPlugins + else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) argsCwd hlsPlugins IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments - { IDEMain.argsProjectRoot = Just argsCwd + { IDEMain.argsProjectRoot = argsCwd , IDEMain.argCommand = argsCommand - , IDEMain.argsLogger = IDEMain.argsLogger arguments <> pure telemetryLogger , IDEMain.argsHlsPlugins = IDEMain.argsHlsPlugins arguments <> pluginDescToIdePlugins [lspRecorderPlugin] , IDEMain.argsRules = do - -- install the main and ghcide-plugin rules mainRule (cmapWithPrio LogRules recorder) def - -- install the kick action, which triggers a typecheck on every - -- Shake database restart, i.e. on every user edit. - unless argsDisableKick $ - action kick , IDEMain.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i) @@ -149,5 +134,5 @@ , optRunSubset = not argsConservativeChangeTracking , optVerifyCoreFile = argsVerifyCoreFile } - , IDEMain.argsMonitoring = OpenTelemetry.monitoring <> EKG.monitoring logger argsMonitoringPort + , IDEMain.argsMonitoring = OpenTelemetry.monitoring } diff --git a/ghcide.cabal b/ghcide.cabal --- a/ghcide.cabal +++ b/ghcide.cabal @@ -1,399 +1,255 @@ -cabal-version: 3.0 +cabal-version: 3.4 build-type: Simple category: Development name: ghcide -version: 1.9.1.0 +version: 2.14.0.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors maintainer: Ghcide contributors copyright: Digital Asset and Ghcide contributors 2018-2020 synopsis: The core of an IDE -description: - A library for building Haskell IDE's on top of the GHC API. -homepage: https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme +description: A library for building Haskell IDE's on top of the GHC API. +homepage: + https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme + bug-reports: https://github.com/haskell/haskell-language-server/issues -tested-with: GHC == 8.10.7 || == 9.0.2 || == 9.2.5 -extra-source-files: README.md CHANGELOG.md - test/data/**/*.project - test/data/**/*.cabal - test/data/**/*.yaml - test/data/**/*.hs - test/data/**/*.hs-boot +tested-with: GHC == {9.14.1, 9.12.2, 9.10.3, 9.8.4, 9.6.7} +extra-source-files: + CHANGELOG.md + README.md source-repository head - type: git - location: https://github.com/haskell/haskell-language-server.git + type: git + location: https://github.com/haskell/haskell-language-server.git -flag ghc-patched-unboxed-bytecode - description: The GHC version we link against supports unboxed sums and tuples in bytecode - default: False - manual: True +flag pedantic + description: Enable -Werror + default: False + manual: True -flag ekg - description: Enable EKG monitoring of the build graph and other metrics on port 8999 - default: False - manual: True +common warnings + ghc-options: + -Werror=incomplete-patterns + -Wall + -Wincomplete-uni-patterns + -Wunused-packages + -Wno-name-shadowing + -Wno-unticked-promoted-constructors + -fno-ignore-asserts library - default-language: Haskell2010 - build-depends: - aeson, - aeson-pretty, - array, - async, - base == 4.*, - binary, - bytestring, - case-insensitive, - co-log-core, - containers, - data-default, - deepseq, - directory, - dependent-map, - dependent-sum, - dlist, - exceptions, - extra >= 1.7.4, - enummapset, - filepath, - fingertree, - focus, - ghc-trace-events, - Glob, - haddock-library >= 1.8 && < 1.12, - hashable, - hie-compat ^>= 0.3.0.0, - hls-plugin-api ^>= 1.6, - lens, - list-t, - hiedb == 0.4.2.*, - lsp-types ^>= 1.6.0.0, - lsp ^>= 1.6.0.0 , - mtl, - optparse-applicative, - parallel, - prettyprinter-ansi-terminal, - prettyprinter >= 1.6, - random, - regex-tdfa >= 1.3.1.0, - text-rope, - safe-exceptions, - hls-graph ^>= 1.9, - sorted-list, - sqlite-simple, - stm, - stm-containers, - syb, - text, - time, - transformers, - unordered-containers >= 0.2.10.0, - vector, - hslogger, - Diff ^>=0.4.0, - vector, - opentelemetry >=0.6.1, - unliftio >= 0.2.6, - unliftio-core, - ghc-boot-th, - ghc-boot, - ghc >= 8.10, - ghc-check >=0.5.0.8, - ghc-paths, - cryptohash-sha1 >=0.11.100 && <0.12, - hie-bios ^>= 0.11.0, - -- implicit-hie 0.1.3.0 introduced an unexpected behavioral change. - -- https://github.com/Avi-D-coder/implicit-hie/issues/50 - -- to make sure ghcide behaves in a desirable way, we put implicit-hie - -- fake dependency here. - implicit-hie < 0.1.3, - implicit-hie-cradle ^>= 0.3.0.5 || ^>= 0.5, - base16-bytestring >=0.1.1 && <1.1 - if os(windows) - build-depends: - Win32 - else - build-depends: - unix - - default-extensions: - BangPatterns - DeriveFunctor - DeriveGeneric - DeriveFoldable - DeriveTraversable - FlexibleContexts - GeneralizedNewtypeDeriving - LambdaCase - NamedFieldPuns - OverloadedStrings - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns - DataKinds - TypeOperators - KindSignatures - - hs-source-dirs: - src - session-loader - exposed-modules: - Control.Concurrent.Strict - Generics.SYB.GHC - Development.IDE - Development.IDE.Main - Development.IDE.Core.Actions - Development.IDE.Main.HeapStats - Development.IDE.Core.Debouncer - Development.IDE.Core.FileStore - Development.IDE.Core.FileUtils - Development.IDE.Core.IdeConfiguration - Development.IDE.Core.OfInterest - Development.IDE.Core.PositionMapping - Development.IDE.Core.Preprocessor - Development.IDE.Core.ProgressReporting - Development.IDE.Core.Rules - Development.IDE.Core.RuleTypes - Development.IDE.Core.Service - Development.IDE.Core.Shake - Development.IDE.Core.Tracing - Development.IDE.Core.UseStale - Development.IDE.GHC.Compat - Development.IDE.GHC.Compat.Core - Development.IDE.GHC.Compat.Env - Development.IDE.GHC.Compat.Iface - Development.IDE.GHC.Compat.Logger - Development.IDE.GHC.Compat.Outputable - Development.IDE.GHC.Compat.Parser - Development.IDE.GHC.Compat.Plugins - Development.IDE.GHC.Compat.Units - Development.IDE.GHC.Compat.Util - Development.IDE.Core.Compile - Development.IDE.GHC.CoreFile - Development.IDE.GHC.Error - Development.IDE.GHC.Orphans - Development.IDE.GHC.Util - Development.IDE.Import.DependencyInformation - Development.IDE.Import.FindImports - Development.IDE.Monitoring.EKG - Development.IDE.LSP.HoverDefinition - Development.IDE.LSP.LanguageServer - Development.IDE.LSP.Notifications - Development.IDE.LSP.Outline - Development.IDE.LSP.Server - Development.IDE.Session - Development.IDE.Spans.Common - Development.IDE.Spans.Documentation - Development.IDE.Spans.AtPoint - Development.IDE.Spans.LocalBindings - Development.IDE.Spans.Pragmas - Development.IDE.Types.Diagnostics - Development.IDE.Types.Exports - Development.IDE.Types.HscEnvEq - Development.IDE.Types.KnownTargets - Development.IDE.Types.Location - Development.IDE.Types.Logger - Development.IDE.Types.Monitoring - Development.IDE.Monitoring.OpenTelemetry - Development.IDE.Types.Options - Development.IDE.Types.Shake - Development.IDE.Plugin - Development.IDE.Plugin.Completions - Development.IDE.Plugin.Completions.Types - Development.IDE.Plugin.HLS - Development.IDE.Plugin.HLS.GhcIde - Development.IDE.Plugin.Test - Development.IDE.Plugin.TypeLenses - Text.Fuzzy.Parallel - - other-modules: - Development.IDE.Core.FileExists - Development.IDE.GHC.CPP - Development.IDE.GHC.Warnings - Development.IDE.Plugin.Completions.Logic - Development.IDE.Session.VersionCheck - Development.IDE.Types.Action - - ghc-options: - -Wall - -Wno-name-shadowing - -Wincomplete-uni-patterns - -Wno-unticked-promoted-constructors - -fno-ignore-asserts + import: warnings + default-language: GHC2021 + build-depends: + , aeson + , array + , async + , base >=4.16 && <5 + , base16-bytestring >=0.1.1 && <1.1 + , binary + , bytestring + , case-insensitive + , co-log-core + , containers + , cryptohash-sha1 >=0.11.100 && <0.12 + , data-default + , deepseq + , dependent-map + , dependent-sum + , Diff ^>=0.5 || ^>=1.0.0 + , directory + , dlist + , edit-distance + , enummapset + , exceptions + , extra >=1.7.14 + , filepath + , fingertree + , focus >=1.0.3.2 + , ghc >=9.2 + , ghc-boot + , ghc-boot-th + , ghc-trace-events + , Glob + , haddock-library >=1.8 && <1.12 + , hashable + , hie-bios ^>= 0.19.0 + , hiedb ^>= 0.8.0.0 + , hls-graph == 2.14.0.0 + , hls-plugin-api == 2.14.0.0 + , implicit-hie >= 0.1.4.0 && < 0.1.5 + , lens + , lens-aeson + , list-t + , lsp ^>=2.8 + , lsp-types ^>=2.4 + , mtl + , opentelemetry >=0.6.1 + , optparse-applicative + , parallel + , process + , prettyprinter >=1.7 + , prettyprinter-ansi-terminal + , random + , regex-tdfa >=1.3.1.0 + , safe-exceptions + , sorted-list + , sqlite-simple + , stm + , stm-containers + , syb + , text + , text-rope + , time + , transformers + , unliftio >=0.2.6 + , unliftio-core + , unordered-containers >=0.2.21 + , vector - if flag(ghc-patched-unboxed-bytecode) - cpp-options: -DGHC_PATCHED_UNBOXED_BYTECODE + if os(windows) + build-depends: Win32 - if impl(ghc >= 9) - ghc-options: -Wunused-packages + else + build-depends: unix - if flag(ekg) - build-depends: - ekg-wai, - ekg-core, - cpp-options: -DMONITORING_EKG + default-extensions: + DataKinds + ExplicitNamespaces + LambdaCase + OverloadedStrings + RecordWildCards + ViewPatterns -flag test-exe - description: Build the ghcide-test-preprocessor executable - default: True + hs-source-dirs: src session-loader + exposed-modules: + Control.Concurrent.Strict + Development.IDE + Development.IDE.Core.Actions + Development.IDE.Core.Compile + Development.IDE.Core.Debouncer + Development.IDE.Core.FileStore + Development.IDE.Core.FileUtils + Development.IDE.Core.IdeConfiguration + Development.IDE.Core.LookupMod + Development.IDE.Core.OfInterest + Development.IDE.Core.PluginUtils + Development.IDE.Core.PositionMapping + Development.IDE.Core.Preprocessor + Development.IDE.Core.ProgressReporting + Development.IDE.Core.Rules + Development.IDE.Core.RuleTypes + Development.IDE.Core.Service + Development.IDE.Core.Shake + Development.IDE.Core.Tracing + Development.IDE.Core.UseStale + Development.IDE.Core.WorkerThread + Development.IDE.GHC.Compat + Development.IDE.GHC.Compat.Core + Development.IDE.GHC.Compat.CmdLine + Development.IDE.GHC.Compat.Driver + Development.IDE.GHC.Compat.Env + Development.IDE.GHC.Compat.Error + Development.IDE.GHC.Compat.Iface + Development.IDE.GHC.Compat.Logger + Development.IDE.GHC.Compat.Outputable + Development.IDE.GHC.Compat.Parser + Development.IDE.GHC.Compat.Plugins + Development.IDE.GHC.Compat.Units + Development.IDE.GHC.Compat.Util + Development.IDE.GHC.CoreFile + Development.IDE.GHC.Error + Development.IDE.GHC.Orphans + Development.IDE.GHC.Util + Development.IDE.Import.DependencyInformation + Development.IDE.Import.FindImports + Development.IDE.LSP.HoverDefinition + Development.IDE.LSP.LanguageServer + Development.IDE.LSP.Notifications + Development.IDE.LSP.Outline + Development.IDE.LSP.Server + Development.IDE.Main + Development.IDE.Main.HeapStats + Development.IDE.Monitoring.OpenTelemetry + Development.IDE.Plugin + Development.IDE.Plugin.Completions + Development.IDE.Plugin.Completions.Types + Development.IDE.Plugin.Completions.Logic + Development.IDE.Plugin.HLS + Development.IDE.Plugin.HLS.GhcIde + Development.IDE.Plugin.Test + Development.IDE.Plugin.TypeLenses + Development.IDE.Session + Development.IDE.Session.Dependency + Development.IDE.Session.Diagnostics + Development.IDE.Session.Ghc + Development.IDE.Session.Implicit + Development.IDE.Spans.AtPoint + Development.IDE.Spans.Common + Development.IDE.Spans.Documentation + Development.IDE.Spans.LocalBindings + Development.IDE.Spans.Pragmas + Development.IDE.Types.Diagnostics + Development.IDE.Types.Exports + Development.IDE.Types.HscEnvEq + Development.IDE.Types.KnownTargets + Development.IDE.Types.Location + Development.IDE.Types.Monitoring + Development.IDE.Types.Options + Development.IDE.Types.Shake + Generics.SYB.GHC + Text.Fuzzy.Parallel + Text.Fuzzy.Levenshtein -executable ghcide-test-preprocessor - default-language: Haskell2010 - hs-source-dirs: test/preprocessor - ghc-options: -Wall -Wno-name-shadowing - main-is: Main.hs - build-depends: - base == 4.* + other-modules: + Development.IDE.Core.FileExists + Development.IDE.GHC.CPP + Development.IDE.GHC.Warnings + Development.IDE.Types.Action + Development.IDE.Session.OrderedSet - if !flag(test-exe) - buildable: False + if flag(pedantic) + ghc-options: + -Werror flag executable - description: Build the ghcide executable - default: True + description: Build the ghcide executable + default: True executable ghcide - default-language: Haskell2010 - hs-source-dirs: exe - ghc-options: - -threaded - -Wall - -Wincomplete-uni-patterns - -Wno-name-shadowing - -- allow user RTS overrides - -rtsopts - -- disable idle GC - -- increase nursery size - -- Enable collection of heap statistics - "-with-rtsopts=-I0 -A128M -T" - main-is: Main.hs - build-depends: - base == 4.*, - data-default, - extra, - gitrev, - lsp, - lsp-types, - hls-plugin-api, - ghcide, - optparse-applicative, - other-modules: - Arguments - Paths_ghcide - autogen-modules: - Paths_ghcide + import: warnings + default-language: GHC2021 + hs-source-dirs: exe + ghc-options: -threaded -rtsopts "-with-rtsopts=-I0 -A128M -T" - default-extensions: - BangPatterns - DeriveFunctor - DeriveGeneric - FlexibleContexts - GeneralizedNewtypeDeriving - LambdaCase - NamedFieldPuns - OverloadedStrings - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns - if !flag(executable) - buildable: False - if flag(ekg) - build-depends: - ekg-wai, - ekg-core, - cpp-options: -DMONITORING_EKG - if impl(ghc >= 9) - ghc-options: -Wunused-packages + -- allow user RTS overrides + -- disable idle GC + -- increase nursery size + -- Enable collection of heap statistics + main-is: Main.hs + build-depends: + , base >=4.16 && <5 + , data-default + , extra + , ghcide + , gitrev + , hls-plugin-api + , lsp + , lsp-types + , optparse-applicative + other-modules: + Arguments + Paths_ghcide -test-suite ghcide-tests - type: exitcode-stdio-1.0 - default-language: Haskell2010 - build-tool-depends: - ghcide:ghcide, - ghcide:ghcide-test-preprocessor, - implicit-hie:gen-hie - build-depends: - aeson, - async, - base, - containers, - data-default, - directory, - extra, - filepath, - fuzzy, - -------------------------------------------------------------- - -- The MIN_VERSION_ghc macro relies on MIN_VERSION pragmas - -- which require depending on ghc. So the tests need to depend - -- on ghc if they need to use MIN_VERSION_ghc. Maybe a - -- better solution can be found, but this is a quick solution - -- which works for now. - ghc, - -------------------------------------------------------------- - ghcide, - lsp, - lsp-types, - hls-plugin-api, - lens, - list-t, - lsp-test ^>= 0.14, - monoid-subclasses, - network-uri, - QuickCheck, - random, - regex-tdfa ^>= 1.3.1, - shake, - sqlite-simple, - stm, - stm-containers, - tasty, - tasty-expected-failure, - tasty-hunit >= 0.10, - tasty-quickcheck, - tasty-rerun, - text, - text-rope, - unordered-containers, - if impl(ghc < 9.2) - build-depends: - record-dot-preprocessor, - record-hasfield - if impl(ghc < 9.3) - build-depends: ghc-typelits-knownnat - if impl(ghc >= 9) - ghc-options: -Wunused-packages - hs-source-dirs: test/cabal test/exe test/src - ghc-options: -threaded -Wall -Wno-name-shadowing -O0 -Wno-unticked-promoted-constructors - main-is: Main.hs - other-modules: - Development.IDE.Test.Runfiles - FuzzySearch - Progress - HieDbRetry - Development.IDE.Test - Development.IDE.Test.Diagnostic - default-extensions: - BangPatterns - DeriveFunctor - DeriveGeneric - FlexibleContexts - GeneralizedNewtypeDeriving - LambdaCase - NamedFieldPuns - OverloadedStrings - RecordWildCards - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications - ViewPatterns + autogen-modules: Paths_ghcide + default-extensions: + LambdaCase + OverloadedStrings + RecordWildCards + ViewPatterns + + if !flag(executable) + buildable: False diff --git a/session-loader/Development/IDE/Session.hs b/session-loader/Development/IDE/Session.hs --- a/session-loader/Development/IDE/Session.hs +++ b/session-loader/Development/IDE/Session.hs @@ -1,1123 +1,1139 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - -{-| -The logic for setting up a ghcide session by tapping into hie-bios. --} -module Development.IDE.Session - (SessionLoadingOptions(..) - ,CacheDirs(..) - ,loadSession - ,loadSessionWithOptions - ,setInitialDynFlags - ,getHieDbLoc - ,runWithDb - ,retryOnSqliteBusy - ,retryOnException - ,Log(..) - ) where - --- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses --- the real GHC library and the types are incompatible. Furthermore, when --- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios! - -import Control.Concurrent.Async -import Control.Concurrent.Strict -import Control.Exception.Safe as Safe -import Control.Monad -import Control.Monad.Extra -import Control.Monad.IO.Class -import qualified Crypto.Hash.SHA1 as H -import Data.Aeson hiding (Error) -import Data.Bifunctor -import qualified Data.ByteString.Base16 as B16 -import qualified Data.ByteString.Char8 as B -import Data.Default -import Data.Either.Extra -import Data.Function -import Data.Hashable -import qualified Data.HashMap.Strict as HM -import Data.IORef -import Data.List -import qualified Data.Map.Strict as Map -import Data.Maybe -import qualified Data.Text as T -import Data.Time.Clock -import Data.Version -import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake hiding (Log, Priority, - withHieDb) -import qualified Development.IDE.GHC.Compat as Compat -import Development.IDE.GHC.Compat.Core hiding (Target, - TargetFile, TargetModule, - Var, Warning) -import qualified Development.IDE.GHC.Compat.Core as GHC -import Development.IDE.GHC.Compat.Env hiding (Logger) -import Development.IDE.GHC.Compat.Units (UnitId) -import Development.IDE.GHC.Util -import Development.IDE.Graph (Action) -import Development.IDE.Session.VersionCheck -import Development.IDE.Types.Diagnostics -import Development.IDE.Types.Exports -import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq, - newHscEnvEqPreserveImportPaths) -import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), - Priority (Debug, Error, Info, Warning), - Recorder, WithPriority, - cmapWithPrio, logWith, - nest, - toCologActionWithPrio, - vcat, viaShow, (<+>)) -import Development.IDE.Types.Options -import GHC.Check -import qualified HIE.Bios as HieBios -import HIE.Bios.Environment hiding (getCacheDir) -import HIE.Bios.Types hiding (Log) -import qualified HIE.Bios.Types as HieBios -import Hie.Implicit.Cradle (loadImplicitHieCradle) -import Language.LSP.Server -import Language.LSP.Types -import System.Directory -import qualified System.Directory.Extra as IO -import System.FilePath -import System.Info - -import Control.Applicative (Alternative ((<|>))) -import Data.Void - -import Control.Concurrent.STM.Stats (atomically, modifyTVar', - readTVar, writeTVar) -import Control.Concurrent.STM.TQueue -import Control.DeepSeq -import Control.Exception (evaluate) -import Control.Monad.IO.Unlift (MonadUnliftIO) -import Data.Foldable (for_) -import Data.HashMap.Strict (HashMap) -import Data.HashSet (HashSet) -import qualified Data.HashSet as Set -import Database.SQLite.Simple -import Development.IDE.Core.Tracing (withTrace) -import Development.IDE.Types.Shake (WithHieDb) -import HieDb.Create -import HieDb.Types -import HieDb.Utils -import qualified System.Random as Random -import System.Random (RandomGen) - -data Log - = LogSettingInitialDynFlags - | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void) - | LogGetInitialGhcLibDirDefaultCradleNone - | LogHieDbRetry !Int !Int !Int !SomeException - | LogHieDbRetriesExhausted !Int !Int !Int !SomeException - | LogHieDbWriterThreadSQLiteError !SQLError - | LogHieDbWriterThreadException !SomeException - | LogInterfaceFilesCacheDir !FilePath - | LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedFilePath)) - | LogMakingNewHscEnv ![UnitId] - | LogDLLLoadError !String - | LogCradlePath !FilePath - | LogCradleNotFound !FilePath - | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath)) - | LogCradle !(Cradle Void) - | LogNoneCradleFound FilePath - | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) - | LogHieBios HieBios.Log -deriving instance Show Log - -instance Pretty Log where - pretty = \case - LogNoneCradleFound path -> - "None cradle found for" <+> pretty path <+> ", ignoring the file" - LogSettingInitialDynFlags -> - "Setting initial dynflags..." - LogGetInitialGhcLibDirDefaultCradleFail cradleError rootDirPath hieYamlPath cradle -> - nest 2 $ - vcat - [ "Couldn't load cradle for ghc libdir." - , "Cradle error:" <+> viaShow cradleError - , "Root dir path:" <+> pretty rootDirPath - , "hie.yaml path:" <+> pretty hieYamlPath - , "Cradle:" <+> viaShow cradle ] - LogGetInitialGhcLibDirDefaultCradleNone -> - "Couldn't load cradle. Cradle not found." - LogHieDbRetry delay maxDelay maxRetryCount e -> - nest 2 $ - vcat - [ "Retrying hiedb action..." - , "delay:" <+> pretty delay - , "maximum delay:" <+> pretty maxDelay - , "retries remaining:" <+> pretty maxRetryCount - , "SQLite error:" <+> pretty (displayException e) ] - LogHieDbRetriesExhausted baseDelay maxDelay maxRetryCount e -> - nest 2 $ - vcat - [ "Retries exhausted for hiedb action." - , "base delay:" <+> pretty baseDelay - , "maximum delay:" <+> pretty maxDelay - , "retries remaining:" <+> pretty maxRetryCount - , "Exception:" <+> pretty (displayException e) ] - LogHieDbWriterThreadSQLiteError e -> - nest 2 $ - vcat - [ "HieDb writer thread SQLite error:" - , pretty (displayException e) ] - LogHieDbWriterThreadException e -> - nest 2 $ - vcat - [ "HieDb writer thread exception:" - , pretty (displayException e) ] - LogInterfaceFilesCacheDir path -> - "Interface files cache directory:" <+> pretty path - LogKnownFilesUpdated targetToPathsMap -> - nest 2 $ - vcat - [ "Known files updated:" - , viaShow $ (HM.map . Set.map) fromNormalizedFilePath targetToPathsMap - ] - LogMakingNewHscEnv inPlaceUnitIds -> - "Making new HscEnv. In-place unit ids:" <+> pretty (map show inPlaceUnitIds) - LogDLLLoadError errorString -> - "Error dynamically loading libm.so.6:" <+> pretty errorString - LogCradlePath path -> - "Cradle path:" <+> pretty path - LogCradleNotFound path -> - vcat - [ "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for" <+> pretty path <> "." - , "Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie)." - , "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ] - LogSessionLoadingResult e -> - "Session loading result:" <+> viaShow e - LogCradle cradle -> - "Cradle:" <+> viaShow cradle - LogNewComponentCache componentCache -> - "New component cache HscEnvEq:" <+> viaShow componentCache - LogHieBios log -> pretty log - --- | Bump this version number when making changes to the format of the data stored in hiedb -hiedbDataVersion :: String -hiedbDataVersion = "1" - -data CacheDirs = CacheDirs - { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath} - -data SessionLoadingOptions = SessionLoadingOptions - { findCradle :: FilePath -> IO (Maybe FilePath) - -- | Load the cradle with an optional 'hie.yaml' location. - -- If a 'hie.yaml' is given, use it to load the cradle. - -- Otherwise, use the provided project root directory to determine the cradle type. - , loadCradle :: Maybe FilePath -> FilePath -> IO (HieBios.Cradle Void) - -- | Given the project name and a set of command line flags, - -- return the path for storing generated GHC artifacts, - -- or 'Nothing' to respect the cradle setting - , getCacheDirs :: String -> [String] -> IO CacheDirs - -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' - , getInitialGhcLibDir :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir) -#if !MIN_VERSION_ghc(9,3,0) - , fakeUid :: UnitId - -- ^ unit id used to tag the internal component built by ghcide - -- To reuse external interface files the unit ids must match, - -- thus make sure to build them with `--this-unit-id` set to the - -- same value as the ghcide fake uid -#endif - } - -instance Default SessionLoadingOptions where - def = SessionLoadingOptions - {findCradle = HieBios.findCradle - ,loadCradle = loadWithImplicitCradle - ,getCacheDirs = getCacheDirsDefault - ,getInitialGhcLibDir = getInitialGhcLibDirDefault -#if !MIN_VERSION_ghc(9,3,0) - ,fakeUid = Compat.toUnitId (Compat.stringToUnit "main") -#endif - } - --- | Find the cradle for a given 'hie.yaml' configuration. --- --- If a 'hie.yaml' is given, the cradle is read from the config. --- If this config does not comply to the "hie.yaml" --- specification, an error is raised. --- --- If no location for "hie.yaml" is provided, the implicit config is used --- using the provided root directory for discovering the project. --- The implicit config uses different heuristics to determine the type --- of the project that may or may not be accurate. -loadWithImplicitCradle :: Maybe FilePath - -- ^ Optional 'hie.yaml' location. Will be used if given. - -> FilePath - -- ^ Root directory of the project. Required as a fallback - -- if no 'hie.yaml' location is given. - -> IO (HieBios.Cradle Void) -loadWithImplicitCradle mHieYaml rootDir = do - case mHieYaml of - Just yaml -> HieBios.loadCradle yaml - Nothing -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir - -getInitialGhcLibDirDefault :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir) -getInitialGhcLibDirDefault recorder rootDir = do - let log = logWith recorder - hieYaml <- findCradle def rootDir - cradle <- loadCradle def hieYaml rootDir - libDirRes <- getRuntimeGhcLibDir cradle - case libDirRes of - CradleSuccess libdir -> pure $ Just $ LibDir libdir - CradleFail err -> do - log Error $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle - pure Nothing - CradleNone -> do - log Warning LogGetInitialGhcLibDirDefaultCradleNone - pure Nothing - --- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir -setInitialDynFlags :: Recorder (WithPriority Log) -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir) -setInitialDynFlags recorder rootDir SessionLoadingOptions{..} = do - libdir <- getInitialGhcLibDir recorder rootDir - dynFlags <- mapM dynFlagsForPrinting libdir - logWith recorder Debug LogSettingInitialDynFlags - mapM_ setUnsafeGlobalDynFlags dynFlags - pure libdir - --- | If the action throws exception that satisfies predicate then we sleep for --- a duration determined by the random exponential backoff formula, --- `uniformRandom(0, min (maxDelay, (baseDelay * 2) ^ retryAttempt))`, and try --- the action again for a maximum of `maxRetryCount` times. --- `MonadIO`, `MonadCatch` are used as constraints because there are a few --- HieDb functions that don't return IO values. -retryOnException - :: (MonadIO m, MonadCatch m, RandomGen g, Exception e) - => (e -> Maybe e) -- ^ only retry on exception if this predicate returns Just - -> Recorder (WithPriority Log) - -> Int -- ^ maximum backoff delay in microseconds - -> Int -- ^ base backoff delay in microseconds - -> Int -- ^ maximum number of times to retry - -> g -- ^ random number generator - -> m a -- ^ action that may throw exception - -> m a -retryOnException exceptionPred recorder maxDelay !baseDelay !maxRetryCount rng action = do - result <- tryJust exceptionPred action - case result of - Left e - | maxRetryCount > 0 -> do - -- multiply by 2 because baseDelay is midpoint of uniform range - let newBaseDelay = min maxDelay (baseDelay * 2) - let (delay, newRng) = Random.randomR (0, newBaseDelay) rng - let newMaxRetryCount = maxRetryCount - 1 - liftIO $ do - log Warning $ LogHieDbRetry delay maxDelay newMaxRetryCount (toException e) - threadDelay delay - retryOnException exceptionPred recorder maxDelay newBaseDelay newMaxRetryCount newRng action - - | otherwise -> do - liftIO $ do - log Warning $ LogHieDbRetriesExhausted baseDelay maxDelay maxRetryCount (toException e) - throwIO e - - Right b -> pure b - where - log = logWith recorder - --- | in microseconds -oneSecond :: Int -oneSecond = 1000000 - --- | in microseconds -oneMillisecond :: Int -oneMillisecond = 1000 - --- | default maximum number of times to retry hiedb call -maxRetryCount :: Int -maxRetryCount = 10 - -retryOnSqliteBusy :: (MonadIO m, MonadCatch m, RandomGen g) - => Recorder (WithPriority Log) -> g -> m a -> m a -retryOnSqliteBusy recorder rng action = - let isErrorBusy e - | SQLError{ sqlError = ErrorBusy } <- e = Just e - | otherwise = Nothing - in - retryOnException isErrorBusy recorder oneSecond oneMillisecond maxRetryCount rng action - -makeWithHieDbRetryable :: RandomGen g => Recorder (WithPriority Log) -> g -> HieDb -> WithHieDb -makeWithHieDbRetryable recorder rng hieDb f = - retryOnSqliteBusy recorder rng (f hieDb) - --- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for --- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial --- by a worker thread using a dedicated database connection. --- This is done in order to serialize writes to the database, or else SQLite becomes unhappy -runWithDb :: Recorder (WithPriority Log) -> FilePath -> (WithHieDb -> IndexQueue -> IO ()) -> IO () -runWithDb recorder fp k = do - -- use non-deterministic seed because maybe multiple HLS start at same time - -- and send bursts of requests - rng <- Random.newStdGen - -- Delete the database if it has an incompatible schema version - retryOnSqliteBusy - recorder - rng - (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp) - - withHieDb fp $ \writedb -> do - -- the type signature is necessary to avoid concretizing the tyvar - -- e.g. `withWriteDbRetryable initConn` without type signature will - -- instantiate tyvar `a` to `()` - let withWriteDbRetryable :: WithHieDb - withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb - withWriteDbRetryable initConn - - chan <- newTQueueIO - - withAsync (writerThread withWriteDbRetryable chan) $ \_ -> do - withHieDb fp (\readDb -> k (makeWithHieDbRetryable recorder rng readDb) chan) - where - log = logWith recorder - - writerThread :: WithHieDb -> IndexQueue -> IO () - writerThread withHieDbRetryable chan = do - -- Clear the index of any files that might have been deleted since the last run - _ <- withHieDbRetryable deleteMissingRealFiles - _ <- withHieDbRetryable garbageCollectTypeNames - forever $ do - k <- atomically $ readTQueue chan - -- TODO: probably should let exceptions be caught/logged/handled by top level handler - k withHieDbRetryable - `Safe.catch` \e@SQLError{} -> do - log Error $ LogHieDbWriterThreadSQLiteError e - `Safe.catchAny` \e -> do - log Error $ LogHieDbWriterThreadException e - - -getHieDbLoc :: FilePath -> IO FilePath -getHieDbLoc dir = do - let db = intercalate "-" [dirHash, takeBaseName dir, Compat.ghcVersionStr, hiedbDataVersion] <.> "hiedb" - dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir - cDir <- IO.getXdgDirectory IO.XdgCache cacheDir - createDirectoryIfMissing True cDir - pure (cDir db) - --- | Given a root directory, return a Shake 'Action' which setups an --- 'IdeGhcSession' given a file. --- Some of the many things this does: --- --- * Find the cradle for the file --- * Get the session options, --- * Get the GHC lib directory --- * Make sure the GHC compiletime and runtime versions match --- * Restart the Shake session --- --- This is the key function which implements multi-component support. All --- components mapping to the same hie.yaml file are mapped to the same --- HscEnv which is updated as new components are discovered. -loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession) -loadSession recorder = loadSessionWithOptions recorder def - -loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) -loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do - -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file - hscEnvs <- newVar Map.empty :: IO (Var HieMap) - -- Mapping from a Filepath to HscEnv - fileToFlags <- newVar Map.empty :: IO (Var FlagsMap) - -- Mapping from a Filepath to its 'hie.yaml' location. - -- Should hold the same Filepaths as 'fileToFlags', otherwise - -- they are inconsistent. So, everywhere you modify 'fileToFlags', - -- you have to modify 'filesMap' as well. - filesMap <- newVar HM.empty :: IO (Var FilesMap) - -- Version of the mappings above - version <- newVar 0 - let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version) - -- This caches the mapping from Mod.hs -> hie.yaml - cradleLoc <- liftIO $ memoIO $ \v -> do - res <- findCradle v - -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path - -- try and normalise that - -- e.g. see https://github.com/haskell/ghcide/issues/126 - res' <- traverse makeAbsolute res - return $ normalise <$> res' - - dummyAs <- async $ return (error "Uninitialised") - runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath]))) - - return $ do - extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv - } <- getShakeExtras - let invalidateShakeCache :: IO () - invalidateShakeCache = do - void $ modifyVar' version succ - join $ atomically $ recordDirtyKeys extras GhcSessionIO [emptyFilePath] - - IdeOptions{ optTesting = IdeTesting optTesting - , optCheckProject = getCheckProject - , optExtensions - } <- getIdeOptions - - -- populate the knownTargetsVar with all the - -- files in the project so that `knownFiles` can learn about them and - -- we can generate a complete module graph - let extendKnownTargets newTargets = do - knownTargets <- forM newTargets $ \TargetDetails{..} -> - case targetTarget of - TargetFile f -> pure (targetTarget, [f]) - TargetModule _ -> do - found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations - return (targetTarget, found) - hasUpdate <- join $ atomically $ do - known <- readTVar knownTargetsVar - let known' = flip mapHashed known $ \k -> - HM.unionWith (<>) k $ HM.fromList $ map (second Set.fromList) knownTargets - hasUpdate = if known /= known' then Just (unhashed known') else Nothing - writeTVar knownTargetsVar known' - logDirtyKeys <- recordDirtyKeys extras GetKnownTargets [emptyFilePath] - return (logDirtyKeys >> pure hasUpdate) - for_ hasUpdate $ \x -> - logWith recorder Debug $ LogKnownFilesUpdated x - - -- Create a new HscEnv from a hieYaml root and a set of options - -- If the hieYaml file already has an HscEnv, the new component is - -- combined with the components in the old HscEnv into a new HscEnv - -- which contains the union. - let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO (HscEnv, ComponentInfo, [ComponentInfo]) - packageSetup (hieYaml, cfp, opts, libDir) = do - -- Parse DynFlags for the newly discovered component - hscEnv <- emptyHscEnv ideNc libDir - (df, targets) <- evalGhcEnv hscEnv $ setOptions opts (hsc_dflags hscEnv) - let deps = componentDependencies opts ++ maybeToList hieYaml - dep_info <- getDependencyInfo deps - -- Now lookup to see whether we are combining with an existing HscEnv - -- or making a new one. The lookup returns the HscEnv and a list of - -- information about other components loaded into the HscEnv - -- (unitId, DynFlag, Targets) - modifyVar hscEnvs $ \m -> do - -- Just deps if there's already an HscEnv - -- Nothing is it's the first time we are making an HscEnv - let oldDeps = Map.lookup hieYaml m - let -- Add the raw information about this component to the list - -- We will modify the unitId and DynFlags used for - -- compilation but these are the true source of - -- information. - new_deps = RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info - : maybe [] snd oldDeps - -- Get all the unit-ids for things in this component - inplace = map rawComponentUnitId new_deps - - new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do - -- Remove all inplace dependencies from package flags for - -- components in this HscEnv -#if MIN_VERSION_ghc(9,3,0) - let (df2, uids) = (rawComponentDynFlags, []) -#else - let (df2, uids) = removeInplacePackages fakeUid inplace rawComponentDynFlags -#endif - let prefix = show rawComponentUnitId - -- See Note [Avoiding bad interface files] - let hscComponents = sort $ map show uids - cacheDirOpts = hscComponents ++ componentOptions opts - cacheDirs <- liftIO $ getCacheDirs prefix cacheDirOpts - processed_df <- setCacheDirs recorder cacheDirs df2 - -- The final component information, mostly the same but the DynFlags don't - -- contain any packages which are also loaded - -- into the same component. - pure $ ComponentInfo rawComponentUnitId - processed_df - uids - rawComponentTargets - rawComponentFP - rawComponentCOptions - rawComponentDependencyInfo - -- Make a new HscEnv, we have to recompile everything from - -- scratch again (for now) - -- It's important to keep the same NameCache though for reasons - -- that I do not fully understand - log Info $ LogMakingNewHscEnv inplace - hscEnv <- emptyHscEnv ideNc libDir - !newHscEnv <- - -- Add the options for the current component to the HscEnv - evalGhcEnv hscEnv $ do - _ <- setSessionDynFlags -#if !MIN_VERSION_ghc(9,3,0) - $ setHomeUnitId_ fakeUid -#endif - df - getSession - - -- Modify the map so the hieYaml now maps to the newly created - -- HscEnv - -- Returns - -- . the new HscEnv so it can be used to modify the - -- FilePath -> HscEnv map (fileToFlags) - -- . The information for the new component which caused this cache miss - -- . The modified information (without -inplace flags) for - -- existing packages - pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps')) - - - let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) - -> IO (IdeResult HscEnvEq,[FilePath]) - session args@(hieYaml, _cfp, _opts, _libDir) = do - (hscEnv, new, old_deps) <- packageSetup args - - -- Whenever we spin up a session on Linux, dynamically load libm.so.6 - -- in. We need this in case the binary is statically linked, in which - -- case the interactive session will fail when trying to load - -- ghc-prim, which happens whenever Template Haskell is being - -- evaluated or haskell-language-server's eval plugin tries to run - -- some code. If the binary is dynamically linked, then this will have - -- no effect. - -- See https://github.com/haskell/haskell-language-server/issues/221 - when (os == "linux") $ do - initObjLinker hscEnv - res <- loadDLL hscEnv "libm.so.6" - case res of - Nothing -> pure () - Just err -> log Error $ LogDLLLoadError err - - - -- Make a map from unit-id to DynFlags, this is used when trying to - -- resolve imports. (especially PackageImports) - let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps) - - -- For each component, now make a new HscEnvEq which contains the - -- HscEnv for the hie.yaml file but the DynFlags for that component - - -- New HscEnv for the component in question, returns the new HscEnvEq and - -- a mapping from FilePath to the newly created HscEnvEq. - let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv uids - (cs, res) <- new_cache new - -- Modified cache targets for everything else in the hie.yaml file - -- which now uses the same EPS and so on - cached_targets <- concatMapM (fmap fst . new_cache) old_deps - - let all_targets = cs ++ cached_targets - - void $ modifyVar' fileToFlags $ - Map.insert hieYaml (HM.fromList (concatMap toFlagsMap all_targets)) - void $ modifyVar' filesMap $ - flip HM.union (HM.fromList (zip (map fst $ concatMap toFlagsMap all_targets) (repeat hieYaml))) - - void $ extendKnownTargets all_targets - - -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - invalidateShakeCache - - -- The VFS doesn't change on cradle edits, re-use the old one. - restartShakeSession VFSUnmodified "new component" [] - - -- Typecheck all files in the project on startup - checkProject <- getCheckProject - unless (null cs || not checkProject) $ do - cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations cs) - void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do - mmt <- uses GetModificationTime cfps' - let cs_exist = catMaybes (zipWith (<$) cfps' mmt) - modIfaces <- uses GetModIface cs_exist - -- update exports map - extras <- getShakeExtras - let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces - liftIO $ atomically $ modifyTVar' (exportsMap extras) (exportsMap' <>) - - return (second Map.keys res) - - let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath]) - consultCradle hieYaml cfp = do - lfp <- flip makeRelative cfp <$> getCurrentDirectory - log Info $ LogCradlePath lfp - - when (isNothing hieYaml) $ - log Warning $ LogCradleNotFound lfp - - cradle <- loadCradle hieYaml dir - lfp <- flip makeRelative cfp <$> getCurrentDirectory - - when optTesting $ mRunLspT lspEnv $ - sendNotification (SCustomMethod "ghcide/cradle/loaded") (toJSON cfp) - - -- Display a user friendly progress message here: They probably don't know what a cradle is - let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) - <> " (for " <> T.pack lfp <> ")" - eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $ - withTrace "Load cradle" $ \addTag -> do - addTag "file" lfp - res <- cradleToOptsAndLibDir recorder cradle cfp - addTag "result" (show res) - return res - - log Debug $ LogSessionLoadingResult eopts - case eopts of - -- The cradle gave us some options so get to work turning them - -- into and HscEnv. - Right (opts, libDir) -> do - installationCheck <- ghcVersionChecker libDir - case installationCheck of - InstallationNotFound{..} -> - error $ "GHC installation not found in libdir: " <> libdir - InstallationMismatch{..} -> - return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[]) - InstallationChecked _compileTime _ghcLibCheck -> - session (hieYaml, toNormalizedFilePath' cfp, opts, libDir) - -- Failure case, either a cradle error or the none cradle - Left err -> do - dep_info <- getDependencyInfo (maybeToList hieYaml) - let ncfp = toNormalizedFilePath' cfp - let res = (map (renderCradleError ncfp) err, Nothing) - void $ modifyVar' fileToFlags $ - Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) - void $ modifyVar' filesMap $ HM.insert ncfp hieYaml - return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err) - - -- This caches the mapping from hie.yaml + Mod.hs -> [String] - -- Returns the Ghc session and the cradle dependencies - let sessionOpts :: (Maybe FilePath, FilePath) - -> IO (IdeResult HscEnvEq, [FilePath]) - sessionOpts (hieYaml, file) = do - v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags - cfp <- makeAbsolute file - case HM.lookup (toNormalizedFilePath' cfp) v of - Just (opts, old_di) -> do - deps_ok <- checkDependencyInfo old_di - if not deps_ok - then do - -- If the dependencies are out of date then clear both caches and start - -- again. - modifyVar_ fileToFlags (const (return Map.empty)) - -- Keep the same name cache - modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml ) - consultCradle hieYaml cfp - else return (opts, Map.keys old_di) - Nothing -> consultCradle hieYaml cfp - - -- The main function which gets options for a file. We only want one of these running - -- at a time. Therefore the IORef contains the currently running cradle, if we try - -- to get some more options then we wait for the currently running action to finish - -- before attempting to do so. - let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath]) - getOptions file = do - ncfp <- toNormalizedFilePath' <$> makeAbsolute file - cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap - hieYaml <- cradleLoc file - sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e -> - return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) - - returnWithVersion $ \file -> do - opts <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do - -- If the cradle is not finished, then wait for it to finish. - void $ wait as - as <- async $ getOptions file - return (as, wait as) - pure opts - where - log = logWith recorder - --- | Run the specific cradle on a specific FilePath via hie-bios. --- This then builds dependencies or whatever based on the cradle, gets the --- GHC options/dynflags needed for the session and the GHC library directory -cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> Cradle Void -> FilePath - -> IO (Either [CradleError] (ComponentOptions, FilePath)) -cradleToOptsAndLibDir recorder cradle file = do - -- let noneCradleFoundMessage :: FilePath -> T.Text - -- noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file" - -- Start off by getting the session options - logWith recorder Debug $ LogCradle cradle - let logger = toCologActionWithPrio $ cmapWithPrio LogHieBios recorder - cradleRes <- HieBios.getCompilerOptions logger file cradle - case cradleRes of - CradleSuccess r -> do - -- Now get the GHC lib dir - libDirRes <- getRuntimeGhcLibDir cradle - case libDirRes of - -- This is the successful path - CradleSuccess libDir -> pure (Right (r, libDir)) - CradleFail err -> return (Left [err]) - CradleNone -> do - logWith recorder Info $ LogNoneCradleFound file - return (Left []) - - CradleFail err -> return (Left [err]) - CradleNone -> do - logWith recorder Info $ LogNoneCradleFound file - return (Left []) - -#if MIN_VERSION_ghc(9,3,0) -emptyHscEnv :: NameCache -> FilePath -> IO HscEnv -#else -emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv -#endif -emptyHscEnv nc libDir = do - env <- runGhc (Just libDir) getSession - initDynLinker env - pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) - -data TargetDetails = TargetDetails - { - targetTarget :: !Target, - targetEnv :: !(IdeResult HscEnvEq), - targetDepends :: !DependencyInfo, - targetLocations :: ![NormalizedFilePath] - } - -fromTargetId :: [FilePath] -- ^ import paths - -> [String] -- ^ extensions to consider - -> TargetId - -> IdeResult HscEnvEq - -> DependencyInfo - -> IO [TargetDetails] --- For a target module we consider all the import paths -fromTargetId is exts (GHC.TargetModule mod) env dep = do - let fps = [i moduleNameSlashes mod -<.> ext <> boot - | ext <- exts - , i <- is - , boot <- ["", "-boot"] - ] - locs <- mapM (fmap toNormalizedFilePath' . makeAbsolute) fps - return [TargetDetails (TargetModule mod) env dep locs] --- For a 'TargetFile' we consider all the possible module names -fromTargetId _ _ (GHC.TargetFile f _) env deps = do - nf <- toNormalizedFilePath' <$> makeAbsolute f - return [TargetDetails (TargetFile nf) env deps [nf]] - -toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))] -toFlagsMap TargetDetails{..} = - [ (l, (targetEnv, targetDepends)) | l <- targetLocations] - - -#if MIN_VERSION_ghc(9,3,0) -setNameCache :: NameCache -> HscEnv -> HscEnv -#else -setNameCache :: IORef NameCache -> HscEnv -> HscEnv -#endif -setNameCache nc hsc = hsc { hsc_NC = nc } - --- | Create a mapping from FilePaths to HscEnvEqs -newComponentCache - :: Recorder (WithPriority Log) - -> [String] -- File extensions to consider - -> Maybe FilePath -- Path to cradle - -> NormalizedFilePath -- Path to file that caused the creation of this component - -> HscEnv - -> [(UnitId, DynFlags)] - -> ComponentInfo - -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo)) -newComponentCache recorder exts cradlePath cfp hsc_env uids ci = do - let df = componentDynFlags ci - hscEnv' <- -#if MIN_VERSION_ghc(9,3,0) - -- Set up a multi component session with the other units on GHC 9.4 - Compat.initUnits (map snd uids) (hscSetFlags df hsc_env) -#elif MIN_VERSION_ghc(9,2,0) - -- This initializes the units for GHC 9.2 - -- Add the options for the current component to the HscEnv - -- We want to call `setSessionDynFlags` instead of `hscSetFlags` - -- because `setSessionDynFlags` also initializes the package database, - -- which we need for any changes to the package flags in the dynflags - -- to be visible. - -- See #2693 - evalGhcEnv hsc_env $ do - _ <- setSessionDynFlags $ df - getSession -#else - -- getOptions is enough to initialize units on GHC <9.2 - pure $ hscSetFlags df hsc_env { hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } -#endif - - let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath - henv <- newFunc hscEnv' uids - let targetEnv = ([], Just henv) - targetDepends = componentDependencyInfo ci - res = (targetEnv, targetDepends) - logWith recorder Debug $ LogNewComponentCache res - evaluate $ liftRnf rwhnf $ componentTargets ci - - let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends - ctargets <- concatMapM mk (componentTargets ci) - - -- A special target for the file which caused this wonderful - -- component to be created. In case the cradle doesn't list all the targets for - -- the component, in which case things will be horribly broken anyway. - -- Otherwise, we will immediately attempt to reload this module which - -- causes an infinite loop and high CPU usage. - let special_target = TargetDetails (TargetFile cfp) targetEnv targetDepends [componentFP ci] - return (special_target:ctargets, res) - -{- Note [Avoiding bad interface files] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Originally, we set the cache directory for the various components once -on the first occurrence of the component. -This works fine if these components have no references to each other, -but you have components that depend on each other, the interface files are -updated for each component. -After restarting the session and only opening the component that depended -on the other, suddenly the interface files of this component are stale. -However, from the point of view of `ghcide`, they do not look stale, -thus, not regenerated and the IDE shows weird errors such as: -``` -typecheckIface -Declaration for Rep_ClientRunFlags -Axiom branches Rep_ClientRunFlags: - Failed to load interface for ‘Distribution.Simple.Flag’ - Use -v to see a list of the files searched for. -``` -and -``` -expectJust checkFamInstConsistency -CallStack (from HasCallStack): - error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes - expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst -``` - -To mitigate this, we set the cache directory for each component dependent -on the components of the current `HscEnv`, additionally to the component options -of the respective components. -Assume two components, c1, c2, where c2 depends on c1, and the options of the -respective components are co1, co2. -If we want to load component c2, followed by c1, we set the cache directory for -each component in this way: - - * Load component c2 - * (Cache Directory State) - - name of c2 + co2 - * Load component c1 - * (Cache Directory State) - - name of c2 + name of c1 + co2 - - name of c2 + name of c1 + co1 - -Overall, we created three cache directories. If we opened c1 first, then we -create a fourth cache directory. -This makes sure that interface files are always correctly updated. - -Since this causes a lot of recompilation, we only update the cache-directory, -if the dependencies of a component have really changed. -E.g. when you load two executables, they can not depend on each other. They -should be filtered out, such that we dont have to re-compile everything. --} - --- | Set the cache-directory based on the ComponentOptions and a list of --- internal packages. --- For the exact reason, see Note [Avoiding bad interface files]. -setCacheDirs :: MonadUnliftIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags -setCacheDirs recorder CacheDirs{..} dflags = do - logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir) - pure $ dflags - & maybe id setHiDir hiCacheDir - & maybe id setHieDir hieCacheDir - & maybe id setODir oCacheDir - - -renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic -renderCradleError nfp (CradleError _ _ec t) = - ideErrorWithSource (Just "cradle") (Just DsError) nfp (T.unlines (map T.pack t)) - --- See Note [Multi Cradle Dependency Info] -type DependencyInfo = Map.Map FilePath (Maybe UTCTime) -type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo]) --- | Maps a "hie.yaml" location to all its Target Filepaths and options. -type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) --- | Maps a Filepath to its respective "hie.yaml" location. --- It aims to be the reverse of 'FlagsMap'. -type FilesMap = HM.HashMap NormalizedFilePath (Maybe FilePath) - --- This is pristine information about a component -data RawComponentInfo = RawComponentInfo - { rawComponentUnitId :: UnitId - -- | Unprocessed DynFlags. Contains inplace packages such as libraries. - -- We do not want to use them unprocessed. - , rawComponentDynFlags :: DynFlags - -- | All targets of this components. - , rawComponentTargets :: [GHC.Target] - -- | Filepath which caused the creation of this component - , rawComponentFP :: NormalizedFilePath - -- | Component Options used to load the component. - , rawComponentCOptions :: ComponentOptions - -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file - -- to last modification time. See Note [Multi Cradle Dependency Info]. - , rawComponentDependencyInfo :: DependencyInfo - } - --- This is processed information about the component, in particular the dynflags will be modified. -data ComponentInfo = ComponentInfo - { componentUnitId :: UnitId - -- | Processed DynFlags. Does not contain inplace packages such as local - -- libraries. Can be used to actually load this Component. - , componentDynFlags :: DynFlags - -- | Internal units, such as local libraries, that this component - -- is loaded with. These have been extracted from the original - -- ComponentOptions. - , _componentInternalUnits :: [UnitId] - -- | All targets of this components. - , componentTargets :: [GHC.Target] - -- | Filepath which caused the creation of this component - , componentFP :: NormalizedFilePath - -- | Component Options used to load the component. - , _componentCOptions :: ComponentOptions - -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file - -- to last modification time. See Note [Multi Cradle Dependency Info] - , componentDependencyInfo :: DependencyInfo - } - --- | Check if any dependency has been modified lately. -checkDependencyInfo :: DependencyInfo -> IO Bool -checkDependencyInfo old_di = do - di <- getDependencyInfo (Map.keys old_di) - return (di == old_di) - --- Note [Multi Cradle Dependency Info] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Why do we implement our own file modification tracking here? --- The primary reason is that the custom caching logic is quite complicated and going into shake --- adds even more complexity and more indirection. I did try for about 5 hours to work out how to --- use shake rules rather than IO but eventually gave up. - --- | Computes a mapping from a filepath to its latest modification date. --- See Note [Multi Cradle Dependency Info] why we do this ourselves instead --- of letting shake take care of it. -getDependencyInfo :: [FilePath] -> IO DependencyInfo -getDependencyInfo fs = Map.fromList <$> mapM do_one fs - - where - tryIO :: IO a -> IO (Either IOException a) - tryIO = Safe.try - - do_one :: FilePath -> IO (FilePath, Maybe UTCTime) - do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp) - --- | This function removes all the -package flags which refer to packages we --- are going to deal with ourselves. For example, if a executable depends --- on a library component, then this function will remove the library flag --- from the package flags for the executable --- --- There are several places in GHC (for example the call to hptInstances in --- tcRnImports) which assume that all modules in the HPT have the same unit --- ID. Therefore we create a fake one and give them all the same unit id. -removeInplacePackages - :: UnitId -- ^ fake uid to use for our internal component - -> [UnitId] - -> DynFlags - -> (DynFlags, [UnitId]) -removeInplacePackages fake_uid us df = (setHomeUnitId_ fake_uid $ - df { packageFlags = ps }, uids) - where - (uids, ps) = Compat.filterInplaceUnits us (packageFlags df) - --- | Memoize an IO function, with the characteristics: --- --- * If multiple people ask for a result simultaneously, make sure you only compute it once. --- --- * If there are exceptions, repeatedly reraise them. --- --- * If the caller is aborted (async exception) finish computing it anyway. -memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b) -memoIO op = do - ref <- newVar Map.empty - return $ \k -> join $ mask_ $ modifyVar ref $ \mp -> - case Map.lookup k mp of - Nothing -> do - res <- onceFork $ op k - return (Map.insert k res mp, res) - Just res -> return (mp, res) - --- | Throws if package flags are unsatisfiable -setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [GHC.Target]) -setOptions (ComponentOptions theOpts compRoot _) dflags = do - (dflags', targets') <- addCmdOpts theOpts dflags - let targets = makeTargetsAbsolute compRoot targets' - let dflags'' = - disableWarningsAsErrors $ - -- disabled, generated directly by ghcide instead - flip gopt_unset Opt_WriteInterface $ - -- disabled, generated directly by ghcide instead - -- also, it can confuse the interface stale check - dontWriteHieFiles $ - setIgnoreInterfacePragmas $ - setBytecodeLinkerOptions $ - disableOptimisation $ - Compat.setUpTypedHoles $ - makeDynFlagsAbsolute compRoot dflags' - -- initPackages parses the -package flags and - -- sets up the visibility for each component. - -- Throws if a -package flag cannot be satisfied. - -- This only works for GHC <9.2 - -- For GHC >= 9.2, we need to modify the unit env in the hsc_dflags, which - -- is done later in newComponentCache - final_flags <- liftIO $ wrapPackageSetupException $ Compat.oldInitUnits dflags'' - return (final_flags, targets) - -setIgnoreInterfacePragmas :: DynFlags -> DynFlags -setIgnoreInterfacePragmas df = - gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges - -disableOptimisation :: DynFlags -> DynFlags -disableOptimisation df = updOptLevel 0 df - -setHiDir :: FilePath -> DynFlags -> DynFlags -setHiDir f d = - -- override user settings to avoid conflicts leading to recompilation - d { hiDir = Just f} - -setODir :: FilePath -> DynFlags -> DynFlags -setODir f d = - -- override user settings to avoid conflicts leading to recompilation - d { objectDir = Just f} - -getCacheDirsDefault :: String -> [String] -> IO CacheDirs -getCacheDirsDefault prefix opts = do - dir <- Just <$> getXdgDirectory XdgCache (cacheDir prefix ++ "-" ++ opts_hash) - return $ CacheDirs dir dir dir - where - -- Create a unique folder per set of different GHC options, assuming that each different set of - -- GHC options will create incompatible interface files. - opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts) - --- | Sub directory for the cache path -cacheDir :: String -cacheDir = "ghcide" - ----------------------------------------------------------------------------------------------------- - -data PackageSetupException - = PackageSetupException - { message :: !String - } - | GhcVersionMismatch - { compileTime :: !Version - , runTime :: !Version - } - | PackageCheckFailed !NotCompatibleReason - deriving (Eq, Show, Typeable) - -instance Exception PackageSetupException - --- | Wrap any exception as a 'PackageSetupException' -wrapPackageSetupException :: IO a -> IO a -wrapPackageSetupException = handleAny $ \case - e | Just (pkgE :: PackageSetupException) <- fromException e -> throwIO pkgE - e -> (throwIO . PackageSetupException . show) e - -showPackageSetupException :: PackageSetupException -> String -showPackageSetupException GhcVersionMismatch{..} = unwords - ["ghcide compiled against GHC" - ,showVersion compileTime - ,"but currently using" - ,showVersion runTime - ,"\nThis is unsupported, ghcide must be compiled with the same GHC version as the project." - ] -showPackageSetupException PackageSetupException{..} = unwords - [ "ghcide compiled by GHC", showVersion compilerVersion - , "failed to load packages:", message <> "." - , "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."] -showPackageSetupException (PackageCheckFailed PackageVersionMismatch{..}) = unwords - ["ghcide compiled with package " - , packageName <> "-" <> showVersion compileTime - ,"but project uses package" - , packageName <> "-" <> showVersion runTime - ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project." - ] -showPackageSetupException (PackageCheckFailed BasePackageAbiMismatch{..}) = unwords - ["ghcide compiled with base-" <> showVersion compileTime <> "-" <> compileTimeAbi - ,"but project uses base-" <> showVersion compileTime <> "-" <> runTimeAbi - ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project." - ] - -renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic) -renderPackageSetupException fp e = - ideErrorWithSource (Just "cradle") (Just DsError) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) +{-# LANGUAGE TypeFamilies #-} + +{-| +The logic for setting up a ghcide session by tapping into hie-bios. +-} +module Development.IDE.Session + (SessionLoadingOptions(..) + ,CacheDirs(..) + ,loadSessionWithOptions + ,getInitialGhcLibDirDefault + ,getHieDbLoc + ,retryOnSqliteBusy + ,retryOnException + ,SessionLoaderPendingBarrierVar(..) + ,setSessionLoaderPendingBarrier + ,clearSessionLoaderPendingBarrier + ,Log(..) + ,runWithDb + ) where + +-- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses +-- the real GHC library and the types are incompatible. Furthermore, when +-- building with ghc-lib we need to make this Haskell agnostic, so no hie-bios! + +import Control.Concurrent.Strict +import Control.Exception.Safe as Safe +import Control.Monad +import Control.Monad.Extra as Extra +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) +import qualified Crypto.Hash.SHA1 as H +import Data.Aeson hiding (Error, Key) +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Char8 as B +import Data.Default +import Data.Hashable hiding (hash) +import qualified Data.HashMap.Strict as HM +import Data.List +import Data.List.Extra as L +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Proxy +import qualified Data.Text as T +import Data.Version +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Shake hiding (Log, knownTargets, + withHieDb) +import qualified Development.IDE.GHC.Compat as Compat +import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile, + TargetModule, Var, + Warning, getOptions) +import Development.IDE.GHC.Compat.Env hiding (Logger) +import Development.IDE.GHC.Util +import Development.IDE.Graph (Action, Key) +import qualified Development.IDE.Session.Implicit as GhcIde +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.Exports +import Development.IDE.Types.HscEnvEq (HscEnvEq) +import Development.IDE.Types.Location +import Development.IDE.Types.Options +import qualified HIE.Bios as HieBios +import HIE.Bios.Environment hiding (getCacheDir) +import HIE.Bios.Types hiding (Log) +import qualified HIE.Bios.Types as HieBios +import Ide.Logger (Pretty (pretty), + Priority (Debug, Error, Info, Warning), + Recorder, WithPriority, + cmapWithPrio, logWith, + nest, + toCologActionWithPrio, + vcat, viaShow, (<+>)) +import Ide.Types (Config, + SessionLoadingPreferenceConfig (..), + sessionLoading) +import Language.LSP.Protocol.Message +import Language.LSP.Server +import System.Directory +import qualified System.Directory.Extra as IO +import System.FilePath +import System.Info + +import Control.Applicative (Alternative ((<|>))) +import Data.Void + +import Control.Concurrent.STM.Stats (atomically, modifyTVar', + readTVar, writeTVar) +import Control.Monad.Trans.Cont (ContT (ContT, runContT)) +import Data.Foldable (for_) +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +import qualified Data.HashSet as Set +import Database.SQLite.Simple +import Development.IDE.Core.Tracing (withTrace) +import Development.IDE.Core.WorkerThread +import Development.IDE.Session.Dependency +import Development.IDE.Session.Diagnostics (renderCradleError) +import Development.IDE.Session.Ghc hiding (Log) +import Development.IDE.Types.Shake (WithHieDb, + WithHieDbShield (..), + toNoFileKey) +import HieDb.Create +import HieDb.Types +import Ide.PluginUtils (toAbsolute) +import qualified System.Random as Random +import System.Random (RandomGen) +import Text.ParserCombinators.ReadP (readP_to_S) + +import Control.Concurrent.STM (STM, TVar) +import qualified Control.Monad.STM as STM +import Control.Monad.Trans.Reader +import qualified Development.IDE.Session.Ghc as Ghc +import qualified Development.IDE.Session.OrderedSet as S +import qualified Focus +import qualified StmContainers.Map as STM + +data Log + = LogSettingInitialDynFlags + | LogGetInitialGhcLibDirDefaultCradleFail !CradleError !FilePath !(Maybe FilePath) !(Cradle Void) + | LogGetInitialGhcLibDirDefaultCradleNone + | LogHieDbRetry !Int !Int !Int !SomeException + | LogHieDbRetriesExhausted !Int !Int !Int !SomeException + | LogHieDbWriterThreadSQLiteError !SQLError + | LogHieDbWriterThreadException !SomeException + | LogKnownFilesUpdated !(HashMap Target (HashSet NormalizedFilePath)) + | LogCradlePath !FilePath + | LogCradleNotFound !FilePath + | LogSessionLoadingResult !(Either [CradleError] (ComponentOptions, FilePath, String)) + | LogCradle !(Cradle Void) + | LogNoneCradleFound FilePath + | LogHieBios HieBios.Log + | LogSessionLoadingChanged + | LogSessionWorkerThread LogWorkerThread + | LogSessionNewLoadedFiles ![FilePath] + | LogSessionReloadOnError FilePath ![FilePath] + | LogGetOptionsLoop !FilePath + | LogLookupSessionCache !FilePath + | LogTime !String + | LogSessionGhc Ghc.Log +deriving instance Show Log + +instance Pretty Log where + pretty = \case + LogSessionWorkerThread msg -> pretty msg + LogTime s -> "Time:" <+> pretty s + LogLookupSessionCache path -> "Looking up session cache for" <+> pretty path + LogGetOptionsLoop fp -> "Loop: getOptions for" <+> pretty fp + LogSessionReloadOnError path files -> + "Reloading file due to error in" <+> pretty path <+> "with files:" <+> pretty files + LogSessionNewLoadedFiles files -> + "New loaded files:" <+> pretty files + LogNoneCradleFound path -> + "None cradle found for" <+> pretty path <+> ", ignoring the file" + LogSettingInitialDynFlags -> + "Setting initial dynflags..." + LogGetInitialGhcLibDirDefaultCradleFail cradleError rootDirPath hieYamlPath cradle -> + nest 2 $ + vcat + [ "Couldn't load cradle for ghc libdir." + , "Cradle error:" <+> viaShow cradleError + , "Root dir path:" <+> pretty rootDirPath + , "hie.yaml path:" <+> pretty hieYamlPath + , "Cradle:" <+> viaShow cradle ] + LogGetInitialGhcLibDirDefaultCradleNone -> + "Couldn't load cradle. Cradle not found." + LogHieDbRetry delay maxDelay retriesRemaining e -> + nest 2 $ + vcat + [ "Retrying hiedb action..." + , "delay:" <+> pretty delay + , "maximum delay:" <+> pretty maxDelay + , "retries remaining:" <+> pretty retriesRemaining + , "SQLite error:" <+> pretty (displayException e) ] + LogHieDbRetriesExhausted baseDelay maxDelay retriesRemaining e -> + nest 2 $ + vcat + [ "Retries exhausted for hiedb action." + , "base delay:" <+> pretty baseDelay + , "maximum delay:" <+> pretty maxDelay + , "retries remaining:" <+> pretty retriesRemaining + , "Exception:" <+> pretty (displayException e) ] + LogHieDbWriterThreadSQLiteError e -> + nest 2 $ + vcat + [ "HieDb writer thread SQLite error:" + , pretty (displayException e) ] + LogHieDbWriterThreadException e -> + nest 2 $ + vcat + [ "HieDb writer thread exception:" + , pretty (displayException e) ] + LogKnownFilesUpdated targetToPathsMap -> + nest 2 $ + vcat + [ "Known files updated:" + , viaShow $ (HM.map . Set.map) fromNormalizedFilePath targetToPathsMap + ] + LogCradlePath path -> + "Cradle path:" <+> pretty path + LogCradleNotFound path -> + vcat + [ "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for" <+> pretty path <> "." + , "Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie)." + , "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ] + LogSessionLoadingResult e -> + "Session loading result:" <+> viaShow e + LogCradle cradle -> + "Cradle:" <+> viaShow cradle + LogHieBios msg -> pretty msg + LogSessionGhc msg -> pretty msg + LogSessionLoadingChanged -> + "Session Loading config changed, reloading the full session." + +-- | Bump this version number when making changes to the format of the data stored in hiedb +hiedbDataVersion :: String +hiedbDataVersion = "2" + +data SessionLoadingOptions = SessionLoadingOptions + { findCradle :: FilePath -> IO (Maybe FilePath) + -- | Load the cradle with an optional 'hie.yaml' location. + -- If a 'hie.yaml' is given, use it to load the cradle. + -- Otherwise, use the provided project root directory to determine the cradle type. + , loadCradle :: Recorder (WithPriority Log) -> Maybe FilePath -> FilePath -> IO (HieBios.Cradle Void) + -- | Given the project name and a set of command line flags, + -- return the path for storing generated GHC artifacts, + -- or 'Nothing' to respect the cradle setting + , getCacheDirs :: String -> Maybe B.ByteString -> [String] -> IO CacheDirs + -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' + , getInitialGhcLibDir :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir) + } + +instance Default SessionLoadingOptions where + def = SessionLoadingOptions + {findCradle = HieBios.findCradle + ,loadCradle = loadWithImplicitCradle + ,getCacheDirs = getCacheDirsDefault + ,getInitialGhcLibDir = getInitialGhcLibDirDefault + } + +-- | Find the cradle for a given 'hie.yaml' configuration. +-- +-- If a 'hie.yaml' is given, the cradle is read from the config. +-- If this config does not comply to the "hie.yaml" +-- specification, an error is raised. +-- +-- If no location for "hie.yaml" is provided, the implicit config is used +-- using the provided root directory for discovering the project. +-- The implicit config uses different heuristics to determine the type +-- of the project that may or may not be accurate. +loadWithImplicitCradle + :: Recorder (WithPriority Log) + -> Maybe FilePath + -- ^ Optional 'hie.yaml' location. Will be used if given. + -> FilePath + -- ^ Root directory of the project. Required as a fallback + -- if no 'hie.yaml' location is given. + -> IO (HieBios.Cradle Void) +loadWithImplicitCradle recorder mHieYaml rootDir = do + let logger = toCologActionWithPrio (cmapWithPrio LogHieBios recorder) + case mHieYaml of + Just yaml -> HieBios.loadCradle logger yaml + Nothing -> GhcIde.loadImplicitCradle logger rootDir + +getInitialGhcLibDirDefault :: Recorder (WithPriority Log) -> FilePath -> IO (Maybe LibDir) +getInitialGhcLibDirDefault recorder rootDir = do + hieYaml <- findCradle def (rootDir "a") + cradle <- loadCradle def recorder hieYaml rootDir + libDirRes <- getRuntimeGhcLibDir cradle + case libDirRes of + CradleSuccess libdir -> pure $ Just $ LibDir libdir + CradleFail err -> do + logWith recorder Error $ LogGetInitialGhcLibDirDefaultCradleFail err rootDir hieYaml cradle + pure Nothing + CradleNone -> do + logWith recorder Warning LogGetInitialGhcLibDirDefaultCradleNone + pure Nothing + +-- | If the action throws exception that satisfies predicate then we sleep for +-- a duration determined by the random exponential backoff formula, +-- `uniformRandom(0, min (maxDelay, (baseDelay * 2) ^ retryAttempt))`, and try +-- the action again for a maximum of `maxRetryCount` times. +-- `MonadIO`, `MonadCatch` are used as constraints because there are a few +-- HieDb functions that don't return IO values. +retryOnException + :: (MonadIO m, MonadCatch m, RandomGen g, Exception e) + => (e -> Maybe e) -- ^ only retry on exception if this predicate returns Just + -> Recorder (WithPriority Log) + -> Int -- ^ maximum backoff delay in microseconds + -> Int -- ^ base backoff delay in microseconds + -> Int -- ^ maximum number of times to retry + -> g -- ^ random number generator + -> m a -- ^ action that may throw exception + -> m a +retryOnException exceptionPred recorder maxDelay !baseDelay !maxTimesRetry rng action = do + result <- tryJust exceptionPred action + case result of + Left e + | maxTimesRetry > 0 -> do + -- multiply by 2 because baseDelay is midpoint of uniform range + let newBaseDelay = min maxDelay (baseDelay * 2) + let (delay, newRng) = Random.randomR (0, newBaseDelay) rng + let newMaxTimesRetry = maxTimesRetry - 1 + liftIO $ do + logWith recorder Warning $ LogHieDbRetry delay maxDelay newMaxTimesRetry (toException e) + threadDelay delay + retryOnException exceptionPred recorder maxDelay newBaseDelay newMaxTimesRetry newRng action + + | otherwise -> do + liftIO $ do + logWith recorder Warning $ LogHieDbRetriesExhausted baseDelay maxDelay maxTimesRetry (toException e) + throwIO e + + Right b -> pure b + +-- | in microseconds +oneSecond :: Int +oneSecond = 1000000 + +-- | in microseconds +oneMillisecond :: Int +oneMillisecond = 1000 + +-- | default maximum number of times to retry hiedb call +maxRetryCount :: Int +maxRetryCount = 10 + +retryOnSqliteBusy :: (MonadIO m, MonadCatch m, RandomGen g) + => Recorder (WithPriority Log) -> g -> m a -> m a +retryOnSqliteBusy recorder rng action = + let isErrorBusy e + | SQLError{ sqlError = ErrorBusy } <- e = Just e + | otherwise = Nothing + in + retryOnException isErrorBusy recorder oneSecond oneMillisecond maxRetryCount rng action + +makeWithHieDbRetryable :: RandomGen g => Recorder (WithPriority Log) -> g -> HieDb -> WithHieDb +makeWithHieDbRetryable recorder rng hieDb f = + retryOnSqliteBusy recorder rng (f hieDb) + +-- | Wraps `withHieDb` to provide a database connection for reading, and a `HieWriterChan` for +-- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial +-- by a worker thread using a dedicated database connection. +-- This is done in order to serialize writes to the database, or else SQLite becomes unhappy +-- +-- Also see Note [Serializing runs in separate thread] +runWithDb :: Recorder (WithPriority Log) -> FilePath -> ContT () IO (WithHieDbShield, IndexQueue) +runWithDb recorder fp = ContT $ \k -> do + -- use non-deterministic seed because maybe multiple HLS start at same time + -- and send bursts of requests + rng <- Random.newStdGen + -- Delete the database if it has an incompatible schema version + retryOnSqliteBusy + recorder + rng + (withHieDb fp (const $ pure ()) `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp) + + withHieDb fp $ \writedb -> do + -- the type signature is necessary to avoid concretizing the tyvar + -- e.g. `withWriteDbRetryable initConn` without type signature will + -- instantiate tyvar `a` to `()` + let withWriteDbRetryable :: WithHieDb + withWriteDbRetryable = makeWithHieDbRetryable recorder rng writedb + withWriteDbRetryable (setupHieDb . getConn) + + + -- Clear the index of any files that might have been deleted since the last run + _ <- withWriteDbRetryable deleteMissingRealFiles + _ <- withWriteDbRetryable garbageCollectTypeNames + + runContT (withWorkerQueue (cmapWithPrio LogSessionWorkerThread recorder) "hiedb thread" (writer withWriteDbRetryable)) + $ \chan -> withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan)) + where + writer withHieDbRetryable l = do + -- TODO: probably should let exceptions be caught/logged/handled by top level handler + l withHieDbRetryable + `Safe.catch` \e@SQLError{} -> do + logWith recorder Error $ LogHieDbWriterThreadSQLiteError e + `Safe.catchAny` \f -> do + logWith recorder Error $ LogHieDbWriterThreadException f + + +getHieDbLoc :: FilePath -> IO FilePath +getHieDbLoc dir = do + let db = intercalate "-" [dirHash, takeBaseName dir, Compat.ghcVersionStr, hiedbDataVersion] <.> "hiedb" + dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir + cDir <- IO.getXdgDirectory IO.XdgCache cacheDir + createDirectoryIfMissing True cDir + pure (cDir db) + +-- Note [SessionState and batch load] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- SessionState manages the state for batch loading files in the session loader. +-- +-- - When a new file needs to be loaded, it is added to the 'pendingFiles' set. +-- - The loader processes files from 'pendingFiles', attempting to load them in batches. +-- - (SBL1) If a file is already in 'failedFiles', it is loaded individually (single-file mode). +-- - (SBL2) Otherwise, the loader tries to load as many files as possible together (batch mode). +-- +-- On success: +-- - (SBL3) All successfully loaded files are removed from 'pendingFiles' and 'failedFiles', +-- and added to 'loadedFiles'. +-- +-- On failure: +-- - (SBL4) If loading a single file fails, it is added to 'failedFiles' and removed from 'loadedFiles' and 'pendingFiles'. +-- - (SBL5) If batch loading fails, all files attempted are added to 'failedFiles'. +-- +-- This approach ensures efficient batch loading while isolating problematic files for individual handling. + +-- SBL3 +handleBatchLoadSuccess :: Foldable t => Recorder (WithPriority Log) -> SessionState -> Maybe FilePath -> HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo) -> t TargetDetails -> IO () +handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets = do + pendings <- getPendingFiles sessionState + -- this_flags_map might contains files not in pendingFiles, take the intersection + let newLoaded = pendings `Set.intersection` Set.fromList (fromNormalizedFilePath <$> HM.keys this_flags_map) + atomically $ do + STM.insert this_flags_map hieYaml (fileToFlags sessionState) + insertAllFileMappings sessionState $ map ((hieYaml,) . fst) $ concatMap toFlagsMap all_targets + logWith recorder Info $ LogSessionNewLoadedFiles $ Set.toList newLoaded + atomically $ forM_ (Set.toList newLoaded) $ flip S.delete (pendingFiles sessionState) + mapM_ (removeErrorLoadingFile sessionState) (Set.toList newLoaded) + addCradleFiles sessionState newLoaded + +-- SBL5 +handleBatchLoadFailure :: SessionState -> [FilePath] -> IO () +handleBatchLoadFailure sessionState files = do + mapM_ (addErrorLoadingFile sessionState) files + +-- SBL4 +handleSingleLoadFailure :: SessionState -> FilePath -> IO () +handleSingleLoadFailure sessionState file = do + addErrorLoadingFile sessionState file + atomically $ S.delete file (pendingFiles sessionState) + removeCradleFile sessionState file + +data SessionState = SessionState + { loadedFiles :: !(Var (HashSet FilePath)) + -- ^ Set of files that loaded successfully + , failedFiles :: !(Var (HashSet FilePath)) + -- ^ Set of files that we tried to load but failed + -- for various reasons, such as cradle load errors + , pendingFiles :: !(S.OrderedSet FilePath) + -- ^ Files we are currently trying to load into the HLS session. + , hscEnvs :: !(Var HieMap) + -- ^ Map @hie.yaml@ location to all components that have this @hie.yaml@ as + -- the root location. + , fileToFlags :: !FlagsMap + -- ^ Map @hie.yaml@ to all modules that have this @hie.yaml@ as the root location. + , filesMap :: !FilesMap + -- ^ Maps a 'NormalizedFilePath' to its @hie.yaml@, the reverse of 'fileToFlags'. + , version :: !(Var Int) + -- ^ Session loading version, incremented whenever the shake cache needs to be invalidated. + , sessionLoadingPreferenceConfig :: !(Var (Maybe SessionLoadingPreferenceConfig)) + -- ^ How do we load files? The user can choose to load multiple components at once + -- or to load only one component after the other. + -- + -- Changing this value invalidates the entire shake session. + } + +newtype SessionLoaderPendingBarrierVar = SessionLoaderPendingBarrierVar (TVar (Maybe Int)) +instance IsIdeGlobal SessionLoaderPendingBarrierVar + +setSessionLoaderPendingBarrier :: IdeState -> Int -> IO () +setSessionLoaderPendingBarrier ideState n = do + SessionLoaderPendingBarrierVar barrier <- getIdeGlobalState ideState + atomically $ writeTVar barrier (Just n) + +clearSessionLoaderPendingBarrier :: IdeState -> IO () +clearSessionLoaderPendingBarrier ideState = do + SessionLoaderPendingBarrierVar barrier <- getIdeGlobalState ideState + atomically $ writeTVar barrier Nothing + +waitForSessionLoaderPendingBarrier :: TVar (Maybe Int) -> SessionState -> IO () +waitForSessionLoaderPendingBarrier barrier state = + -- Block the session-loader queue until we have enqueued enough pending files. + -- This is used by tests to enforce true batch setup before consuming pending work. + atomically $ do + mTarget <- readTVar barrier + case mTarget of + Nothing -> pure () + Just targetSize -> do + pending <- S.toHashSet (pendingFiles state) + if Set.size pending < targetSize + then STM.retry + else writeTVar barrier Nothing + +-- | Helper functions for SessionState management +-- These functions encapsulate common operations on the SessionState + +-- | Add a file to the set of files with errors during loading +addErrorLoadingFile :: MonadIO m => SessionState -> FilePath -> m () +addErrorLoadingFile state file = + liftIO $ modifyVar_' (failedFiles state) (\xs -> return $ Set.insert file xs) + +-- | Remove a file from the set of files with errors during loading +removeErrorLoadingFile :: MonadIO m => SessionState -> FilePath -> m () +removeErrorLoadingFile state file = + liftIO $ modifyVar_' (failedFiles state) (\xs -> return $ Set.delete file xs) + +addCradleFiles :: MonadIO m => SessionState -> HashSet FilePath -> m () +addCradleFiles state files = + liftIO $ modifyVar_' (loadedFiles state) (\xs -> return $ files <> xs) + +-- | Remove a file from the cradle files set +removeCradleFile :: MonadIO m => SessionState -> FilePath -> m () +removeCradleFile state file = + liftIO $ modifyVar_' (loadedFiles state) (\xs -> return $ Set.delete file xs) + +-- | Clear error loading files and reset to empty set +clearErrorLoadingFiles :: MonadIO m => SessionState -> m () +clearErrorLoadingFiles state = + liftIO $ modifyVar_' (failedFiles state) (const $ return Set.empty) + +-- | Clear cradle files and reset to empty set +clearCradleFiles :: MonadIO m => SessionState -> m () +clearCradleFiles state = + liftIO $ modifyVar_' (loadedFiles state) (const $ return Set.empty) + +-- | Reset the file maps in the session state +resetFileMaps :: SessionState -> STM () +resetFileMaps state = do + STM.reset (filesMap state) + STM.reset (fileToFlags state) + +-- | Insert or update file flags for a specific hieYaml and normalized file path +insertFileFlags :: SessionState -> Maybe FilePath -> NormalizedFilePath -> (IdeResult HscEnvEq, DependencyInfo) -> STM () +insertFileFlags state hieYaml ncfp flags = + STM.focus (Focus.insertOrMerge HM.union (HM.singleton ncfp flags)) hieYaml (fileToFlags state) + +-- | Insert a file mapping from normalized path to hieYaml location +insertFileMapping :: SessionState -> Maybe FilePath -> NormalizedFilePath -> STM () +insertFileMapping state hieYaml ncfp = + STM.insert hieYaml ncfp (filesMap state) + +-- | Remove a file from the pending file set +removeFromPending :: SessionState -> FilePath -> STM () +removeFromPending state file = + S.delete file (pendingFiles state) + +-- | Add a file to the pending file set +addToPending :: SessionState -> FilePath -> STM () +addToPending state file = + S.insert file (pendingFiles state) + +-- | Insert multiple file mappings at once +insertAllFileMappings :: SessionState -> [(Maybe FilePath, NormalizedFilePath)] -> STM () +insertAllFileMappings state mappings = + mapM_ (\(yaml, path) -> insertFileMapping state yaml path) mappings + +-- | Increment the version counter +incrementVersion :: SessionState -> IO Int +incrementVersion state = modifyVar' (version state) succ + +-- | Get files from the pending file set +getPendingFiles :: SessionState -> IO (HashSet FilePath) +getPendingFiles state = atomically $ S.toHashSet (pendingFiles state) + +-- | Handle errors during session loading by recording file as having error and removing from pending +handleSingleFileProcessingError' :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> SessionM () +handleSingleFileProcessingError' state hieYaml file e = do + handleSingleFileProcessingError state hieYaml file [renderPackageSetupException file e] mempty + +-- | Common pattern: Insert file flags, insert file mapping, and remove from pending +handleSingleFileProcessingError :: SessionState -> Maybe FilePath -> FilePath -> [FileDiagnostic] -> [FilePath] -> SessionM () +handleSingleFileProcessingError state hieYaml file diags extraDepFiles = liftIO $ do + dep <- getDependencyInfo $ maybeToList hieYaml <> extraDepFiles + let ncfp = toNormalizedFilePath' file + let flags = ((diags, Nothing), dep) + handleSingleLoadFailure state file + atomically $ do + insertFileFlags state hieYaml ncfp flags + insertFileMapping state hieYaml ncfp + +-- | Get the set of extra files to load based on the current file path. +-- +-- If the current file is in error loading files, we fallback to single loading mode (empty set) +-- Otherwise, we remove error files from pending files and also exclude the current file +getExtraFilesToLoad :: SessionState -> FilePath -> IO [FilePath] +getExtraFilesToLoad state cfp = do + pendingFiles <- getPendingFiles state + errorFiles <- readVar (failedFiles state) + old_files <- readVar (loadedFiles state) + -- if the file is in error loading files, we fall back to single loading mode + return $ + Set.toList $ + if cfp `Set.member` errorFiles + then Set.empty + -- remove error files from pending files since error loading need to load one by one + else (Set.delete cfp $ pendingFiles `Set.difference` errorFiles) <> old_files + +-- | We allow users to specify a loading strategy. +-- Check whether this config was changed since the last time we have loaded +-- a session. +-- +-- If the loading configuration changed, we likely should restart the session +-- in its entirety. +didSessionLoadingPreferenceConfigChange :: SessionState -> SessionM Bool +didSessionLoadingPreferenceConfigChange s = do + clientConfig <- asks sessionClientConfig + let biosSessionLoadingVar = sessionLoadingPreferenceConfig s + mLoadingConfig <- liftIO $ readVar biosSessionLoadingVar + case mLoadingConfig of + Nothing -> do + liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) + pure False + Just loadingConfig -> do + liftIO $ writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig)) + pure (loadingConfig /= sessionLoading clientConfig) + +newSessionState :: IO SessionState +newSessionState = do + -- Initialize SessionState + sessionState <- SessionState + <$> newVar (Set.fromList []) -- loadedFiles + <*> newVar (Set.fromList []) -- failedFiles + <*> S.newIO -- pendingFiles + <*> newVar Map.empty -- hscEnvs + <*> STM.newIO -- fileToFlags + <*> STM.newIO -- filesMap + <*> newVar 0 -- version + <*> newVar Nothing -- sessionLoadingPreferenceConfig + return sessionState + +-- | Given a root directory, return a Shake 'Action' which setups an +-- 'IdeGhcSession' given a file. +-- Some of the many things this does: +-- +-- * Find the cradle for the file +-- * Get the session options, +-- * Get the GHC lib directory +-- * Make sure the GHC compiletime and runtime versions match +-- * Restart the Shake session +-- +-- This is the key function which implements multi-component support. All +-- components mapping to the same hie.yaml file are mapped to the same +-- HscEnv which is updated as new components are discovered. + +loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TaskQueue (IO ()) -> IO (Action IdeGhcSession) +loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do + let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] + + sessionState <- newSessionState + let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar (version sessionState)) + + -- This caches the mapping from Mod.hs -> hie.yaml + cradleLoc <- liftIO $ memoIO $ \v -> do + res <- findCradle v + -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path + -- try and normalise that + -- e.g. see https://github.com/haskell/ghcide/issues/126 + let res' = toAbsolutePath <$> res + return $ normalise <$> res' + + return $ do + clientConfig <- getClientConfigAction + extras@ShakeExtras{ideNc, knownTargetsVar + } <- getShakeExtras + let invalidateShakeCache = do + void $ incrementVersion sessionState + return $ toNoFileKey GhcSessionIO + + ideOptions <- getIdeOptions + SessionLoaderPendingBarrierVar pendingBarrier <- getIdeGlobalAction + + -- see Note [Serializing runs in separate thread] + -- Start the 'getOptionsLoop' if the queue is empty + liftIO $ atomically $ + Extra.whenM (isEmptyTaskQueue que) $ do + let newSessionLoadingOptions = SessionLoadingOptions + { findCradle = cradleLoc + , .. + } + sessionShake = SessionShake + { restartSession = restartShakeSession extras + , invalidateCache = invalidateShakeCache + , enqueueActions = shakeEnqueue extras + } + sessionEnv = SessionEnv + { sessionLspContext = lspEnv extras + , sessionRootDir = rootDir + , sessionIdeOptions = ideOptions + , sessionPendingBarrier = pendingBarrier + , sessionClientConfig = clientConfig + , sessionSharedNameCache = ideNc + , sessionLoadingOptions = newSessionLoadingOptions + } + + writeTaskQueue que (runReaderT (getOptionsLoop recorder sessionShake sessionState knownTargetsVar) sessionEnv) + + -- Each one of deps will be registered as a FileSystemWatcher in the GhcSession action + -- so that we can get a workspace/didChangeWatchedFiles notification when a dep changes. + -- The GlobPattern of a FileSystemWatcher can be absolute or relative. + -- We use the absolute one because it is supported by more LSP clients. + -- Here we make sure deps are absolute and later we use those absolute deps as GlobPattern. + let absolutePathsCradleDeps (eq, deps) = (eq, fmap toAbsolutePath $ Map.keys deps) + returnWithVersion $ \file -> do + let absFile = toAbsolutePath file + absolutePathsCradleDeps <$> lookupOrWaitCache recorder sessionState absFile + +-- | Given a file, this function will return the HscEnv and the dependencies +-- it would look up the cache first, if the cache is not available, it would +-- submit a request to the getOptionsLoop to get the options for the file +-- and wait until the options are available +lookupOrWaitCache :: Recorder (WithPriority Log) -> SessionState -> FilePath -> IO (IdeResult HscEnvEq, DependencyInfo) +lookupOrWaitCache recorder sessionState absFile = do + let ncfp = toNormalizedFilePath' absFile + cacheResult <- maybeM + (return Nothing) + (guardedA (checkDependencyInfo . snd)) + (atomically $ do + -- wait until target file is not in pendingFiles + Extra.whenM (S.lookup absFile (pendingFiles sessionState)) STM.retry + -- check if in the cache + checkInCache sessionState ncfp) + + + logWith recorder Debug $ LogLookupSessionCache absFile + + case cacheResult of + Just r -> return r + Nothing -> do + -- if not ok, we need to reload the session + atomically $ addToPending sessionState absFile + lookupOrWaitCache recorder sessionState absFile + +checkInCache :: SessionState -> NormalizedFilePath -> STM (Maybe (IdeResult HscEnvEq, DependencyInfo)) +checkInCache sessionState ncfp = runMaybeT $ do + cachedHieYamlLocation <- MaybeT $ STM.lookup ncfp (filesMap sessionState) + m <- MaybeT $ STM.lookup cachedHieYamlLocation (fileToFlags sessionState) + MaybeT $ pure $ HM.lookup ncfp m + +-- | Modify the shake state. +data SessionShake = SessionShake + { restartSession :: VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () + , invalidateCache :: IO Key + , enqueueActions :: DelayedAction () -> IO (IO ()) + } + +-- | Read-only data that the initialisation logic needs access to. +data SessionEnv = SessionEnv + { sessionLspContext :: Maybe (LanguageContextEnv Config) + , sessionRootDir :: FilePath + , sessionIdeOptions :: IdeOptions + , sessionPendingBarrier :: TVar (Maybe Int) + , sessionClientConfig :: Config + , sessionSharedNameCache :: NameCache + , sessionLoadingOptions :: SessionLoadingOptions + } + +type SessionM = ReaderT SessionEnv IO + +-- | The main function which gets options for a file. +-- +-- The general approach is as follows: +-- 1. Find the 'hie.yaml' for the next file target, if there is any. +-- 2. Check in the cache, whether the given 'hie.yaml' was already loaded before +-- 3.1. If it wasn't, initialise a new session and continue with step 4. +-- 3.2. If it is loaded, check whether we need to reload the session, e.g. because the `.cabal` file was modified +-- 3.2.1. If we need to reload, remove the +-- +-- See Note [SessionState and batch load] for an overview of the strategy. +getOptionsLoop :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> SessionM () +getOptionsLoop recorder sessionShake sessionState knownTargetsVar = forever $ do + pendingBarrier <- asks sessionPendingBarrier + IdeTesting isTestMode <- asks (optTesting . sessionIdeOptions) + when isTestMode $ + liftIO $ waitForSessionLoaderPendingBarrier pendingBarrier sessionState + + -- Get the next file to load + file <- liftIO $ atomically $ S.readQueue (pendingFiles sessionState) + logWith recorder Debug (LogGetOptionsLoop file) + + hieLoc <- findHieYamlForTarget (filesMap sessionState) file + sessionOpts recorder sessionShake sessionState knownTargetsVar (hieLoc, file) + `Safe.catch` handleSingleFileProcessingError' sessionState hieLoc file + +findHieYamlForTarget :: FilesMap -> FilePath -> SessionM (Maybe FilePath) +findHieYamlForTarget filesMapping file = do + let ncfp = toNormalizedFilePath' file + cachedHieYamlLocation <- join <$> liftIO (atomically (STM.lookup ncfp filesMapping)) + sessionLoadingOptions <- asks sessionLoadingOptions + hieYaml <- liftIO $ findCradle sessionLoadingOptions file + pure $ cachedHieYamlLocation <|> hieYaml + +-- | This caches the mapping from hie.yaml + Mod.hs -> [String] +-- Returns the Ghc session and the cradle dependencies +sessionOpts :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> (Maybe FilePath, FilePath) -> SessionM () +sessionOpts recorder sessionShake sessionState knownTargetsVar (hieYaml, file) = do + Extra.whenM (didSessionLoadingPreferenceConfigChange sessionState) $ do + logWith recorder Info LogSessionLoadingChanged + liftIO $ atomically $ resetFileMaps sessionState + -- Don't even keep the name cache, we start from scratch here! + liftIO $ modifyVar_ (hscEnvs sessionState) (const (return Map.empty)) + -- cleanup error loading files and cradle files + clearErrorLoadingFiles sessionState + clearCradleFiles sessionState + cacheKey <- liftIO $ invalidateCache sessionShake + liftIO $ restartSession sessionShake VFSUnmodified "didSessionLoadingPreferenceConfigChange" [] (return [cacheKey]) + + v <- liftIO $ atomically $ STM.lookup hieYaml (fileToFlags sessionState) + case v >>= HM.lookup (toNormalizedFilePath' file) of + Just (_opts, old_di) -> do + deps_ok <- liftIO $ checkDependencyInfo old_di + if not deps_ok + then do + -- if deps are old, we can try to load the error files again + removeErrorLoadingFile sessionState file + removeCradleFile sessionState file + -- If the dependencies are out of date then clear both caches and start + -- again. + liftIO $ atomically $ resetFileMaps sessionState + -- Keep the same name cache + liftIO $ modifyVar_ (hscEnvs sessionState) (return . Map.adjust (const []) hieYaml) + -- This file needs to be reloaded! + consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml file + else do + -- If deps are ok, we can just remove the file from pending files. + -- This unblocks the STM waiting in 'lookupOrWaitCache'. + liftIO $ atomically $ removeFromPending sessionState file + Nothing -> + -- This file has never been loaded before, so actually load it now! + consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml file + +consultCradle :: Recorder (WithPriority Log) -> SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> Maybe FilePath -> FilePath -> SessionM () +consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml cfp = do + (cradle, eopts) <- loadCradleWithNotifications recorder sessionState hieYaml cfp + + logWith recorder Debug $ LogSessionLoadingResult eopts + let ncfp = toNormalizedFilePath' cfp + case eopts of + -- The cradle gave us some options so get to work turning them + -- into and HscEnv. + Right (opts, libDir, version) -> do + let compileTime = fullCompilerVersion + case reverse $ readP_to_S parseVersion version of + [] -> error $ "GHC version could not be parsed: " <> version + ((runTime, _):_) + | compileTime == runTime -> session recorder sessionShake sessionState knownTargetsVar (hieYaml, ncfp, opts, libDir) + | otherwise -> handleSingleFileProcessingError' sessionState hieYaml cfp (GhcVersionMismatch{..}) + -- Failure case, either a cradle error or the none cradle + Left err -> do + -- what if the error to load file is one of old_files ? + let attemptToLoadFiles = Set.delete cfp $ Set.fromList $ concatMap cradleErrorLoadingFiles err + old_files <- liftIO $ readVar (loadedFiles sessionState) + let errorToLoadNewFiles = cfp : Set.toList (attemptToLoadFiles `Set.difference` old_files) + if length errorToLoadNewFiles > 1 + then do + -- We tried loading multiple files, but some failed to load! + -- Unfortunately, 'hie-bios' is an all-or-nothing kind of deal, + -- and we don't know whether some of the files could have been loaded, + -- or none of them have been! + -- To work around this, we try to remove the failing targets from the set of extra targets, + -- to still get a fast reload. + -- + -- How do we do this? We mark all of the extra target files as files that failed to + -- to load and retry to load the original target. + -- We decide the extra targets in 'getExtraFilesToLoad', which takes the + -- set of failed targets into account. + liftIO $ handleBatchLoadFailure sessionState errorToLoadNewFiles + -- retry without other files + logWith recorder Info $ LogSessionReloadOnError cfp (Set.toList attemptToLoadFiles) + consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml cfp + else do + -- We are only loading this file and it failed, so we definitely know, + -- we can't load it. + -- Add it to the list of permanently failed to load targets and do not retry! + let res = map (\err' -> renderCradleError err' cradle ncfp) err + handleSingleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err + +-- | Set up the GHC session for the new 'ComponentOptions' we have discovered. +-- +-- The units found in these 'ComponentOptions' are merged with the set of existing home units, +-- replacing the older home unit with the new ones. +-- We update the GHC session to use a multiple home unit session, and restart the shake session accordingly. +session :: + Recorder (WithPriority Log) -> + SessionShake -> + SessionState -> + TVar (Hashed KnownTargets) -> + (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) -> + SessionM () +session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, libDir) = do + let initEmptyHscEnv = emptyHscEnvM libDir + (new_components_info, old_components_info) <- packageSetup recorder sessionState initEmptyHscEnv (hieYaml, cfp, opts) + + -- For each component, now make a new HscEnvEq which contains the + -- HscEnv for the hie.yaml file but the DynFlags for that component + -- For GHC's supporting multi component sessions, we create a shared + -- HscEnv but set the active component accordingly + hscEnv <- initEmptyHscEnv + ideOptions <- asks sessionIdeOptions + let new_cache = newComponentCache (cmapWithPrio LogSessionGhc recorder) (optExtensions ideOptions) cfp hscEnv + all_target_details <- liftIO $ new_cache old_components_info new_components_info + (all_targets, this_flags_map) <- liftIO $ addErrorTargetIfUnknown all_target_details hieYaml cfp + -- The VFS doesn't change on cradle edits, re-use the old one. + -- Invalidate all the existing GhcSession build nodes by restarting the Shake session + liftIO $ do + checkProject <- optCheckProject ideOptions + restartSession sessionShake VFSUnmodified "new component" [] $ do + -- It is necessary to call 'handleBatchLoadSuccess' in restartSession + -- to ensure the GhcSession rule does not return before a new session is started. + -- Otherwise, invalid compilation results may propagate to downstream rules, + -- potentially resulting in lost diagnostics and other issues. + handleBatchLoadSuccess recorder sessionState hieYaml this_flags_map all_targets + keys2 <- invalidateCache sessionShake + keys1 <- extendKnownTargets recorder knownTargetsVar all_targets + -- Typecheck all files in the project on startup + unless (null new_components_info || not checkProject) $ do + cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations all_targets) + void $ enqueueActions sessionShake $ mkDelayedAction "InitialLoad" Debug $ void $ do + mmt <- uses GetModificationTime cfps' + let cs_exist = catMaybes (zipWith (<$) cfps' mmt) + modIfaces <- uses GetModIface cs_exist + -- update exports map + shakeExtras <- getShakeExtras + let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces + liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) + return [keys1, keys2] + +-- | Create a new HscEnv from a hieYaml root and a set of options +packageSetup :: Recorder (WithPriority Log) -> SessionState -> SessionM HscEnv -> (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> SessionM ([ComponentInfo], [ComponentInfo]) +packageSetup recorder sessionState newEmptyHscEnv (hieYaml, cfp, opts) = do + getCacheDirs <- asks (getCacheDirs . sessionLoadingOptions) + haddockparse <- asks (optHaddockParse . sessionIdeOptions) + rootDir <- asks sessionRootDir + -- Parse DynFlags for the newly discovered component + hscEnv <- newEmptyHscEnv + newTargetDfs <- liftIO $ evalGhcEnv hscEnv $ setOptions haddockparse cfp opts (hsc_dflags hscEnv) rootDir + let deps = componentDependencies opts ++ maybeToList hieYaml + dep_info <- liftIO $ getDependencyInfo (fmap (toAbsolute rootDir) deps) + -- Now lookup to see whether we are combining with an existing HscEnv + -- or making a new one. The lookup returns the HscEnv and a list of + -- information about other components loaded into the HscEnv + -- (unitId, DynFlag, Targets) + liftIO $ modifyVar (hscEnvs sessionState) $ + addComponentInfo (cmapWithPrio LogSessionGhc recorder) getCacheDirs dep_info newTargetDfs (hieYaml, cfp, opts) + +addErrorTargetIfUnknown :: Foldable t => t [TargetDetails] -> Maybe FilePath -> NormalizedFilePath -> IO ([TargetDetails], HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) +addErrorTargetIfUnknown all_target_details hieYaml cfp = do + let flags_map' = HM.fromList (concatMap toFlagsMap all_targets') + all_targets' = concat all_target_details + this_dep_info <- getDependencyInfo $ maybeToList hieYaml + let (all_targets, this_flags_map) = case HM.lookup cfp flags_map' of + Just _ -> (all_targets', flags_map') + Nothing -> (this_target_details : all_targets', HM.insert cfp this_flags flags_map') + where + this_target_details = TargetDetails (TargetFile cfp) this_error_env this_dep_info [cfp] + this_flags = (this_error_env, this_dep_info) + this_error_env = ([this_error], Nothing) + this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) cfp + (T.unlines + [ "No cradle target found. Is this file listed in the targets of your cradle?" + , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section" + ]) + Nothing + pure (all_targets, this_flags_map) + +-- | Populate the knownTargetsVar with all the +-- files in the project so that `knownFiles` can learn about them and +-- we can generate a complete module graph +extendKnownTargets :: Recorder (WithPriority Log) -> TVar (Hashed KnownTargets) -> [TargetDetails] -> IO Key +extendKnownTargets recorder knownTargetsVar newTargets = do + knownTargets <- concatForM newTargets $ \TargetDetails{..} -> + case targetTarget of + TargetFile f -> do + -- If a target file has multiple possible locations, then we + -- assume they are all separate file targets. + -- This happens with '.hs-boot' files if they are in the root directory of the project. + -- GHC reports options such as '-i. A' as 'TargetFile A.hs' instead of 'TargetModule A'. + -- In 'fromTargetId', we dutifully look for '.hs-boot' files and add them to the + -- targetLocations of the TargetDetails. Then we add everything to the 'knownTargetsVar'. + -- However, when we look for a 'Foo.hs-boot' file in 'FindImports.hs', we look for either + -- + -- * TargetFile Foo.hs-boot + -- * TargetModule Foo + -- + -- If we don't generate a TargetFile for each potential location, we will only have + -- 'TargetFile Foo.hs' in the 'knownTargetsVar', thus not find 'TargetFile Foo.hs-boot' + -- and also not find 'TargetModule Foo'. + fs <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations + pure $ map (\fp -> (TargetFile fp, Set.singleton fp)) (nubOrd (f:fs)) + TargetModule _ -> do + found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations + return [(targetTarget, Set.fromList found)] + hasUpdate <- atomically $ do + known <- readTVar knownTargetsVar + let known' = flip mapHashed known $ \k -> unionKnownTargets k (mkKnownTargets knownTargets) + hasUpdate = if known /= known' then Just (unhashed known') else Nothing + writeTVar knownTargetsVar known' + pure hasUpdate + for_ hasUpdate $ \x -> + logWith recorder Debug $ LogKnownFilesUpdated (targetMap x) + return $ toNoFileKey GetKnownTargets + + +loadCradleWithNotifications :: + Recorder (WithPriority Log) -> + SessionState -> + Maybe FilePath -> + FilePath -> + SessionM (Cradle Void, Either [CradleError] (ComponentOptions, FilePath, String)) +loadCradleWithNotifications recorder sessionState hieYaml cfp = do + rootDir <- asks sessionRootDir + let lfpLog = makeRelative rootDir cfp + logWith recorder Info $ LogCradlePath lfpLog + when (isNothing hieYaml) $ + logWith recorder Warning $ LogCradleNotFound lfpLog + + -- Find the 'Cradle' for the target + loadingOptions <- asks sessionLoadingOptions + cradle <- liftIO $ loadCradle loadingOptions recorder hieYaml rootDir + + -- Test notification for better observability. + IdeTesting isTesting <- asks (optTesting . sessionIdeOptions) + lspEnv <- asks sessionLspContext + when isTesting $ mRunLspT lspEnv $ + sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp) + + -- Display a user friendly progress message here: They probably don't know what a cradle is + let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) + <> " (for " <> T.pack lfpLog <> ")" + + sessionPref <- asks (sessionLoading . sessionClientConfig) + extraToLoads <- liftIO $ getExtraFilesToLoad sessionState cfp + -- Start loading the file! + eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ + withTrace "Load cradle" $ \addTag -> do + addTag "file" lfpLog + res <- liftIO $ cradleToOptsAndLibDir recorder sessionPref cradle cfp extraToLoads + addTag "result" (show res) + return res + pure (cradle, eopts) + + +-- | Run the specific cradle on a specific FilePath via hie-bios. +-- This then builds dependencies or whatever based on the cradle, gets the +-- GHC options/dynflags needed for the session and the GHC library directory +cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> SessionLoadingPreferenceConfig -> Cradle Void -> FilePath -> [FilePath] + -> IO (Either [CradleError] (ComponentOptions, FilePath, String)) +cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do + -- let noneCradleFoundMessage :: FilePath -> T.Text + -- noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file" + -- Start off by getting the session options + logWith recorder Debug $ LogCradle cradle + cradleRes <- HieBios.getCompilerOptions file loadStyle cradle + case cradleRes of + CradleSuccess r -> do + -- Now get the GHC lib dir + libDirRes <- getRuntimeGhcLibDir cradle + versionRes <- getRuntimeGhcVersion cradle + case liftA2 (,) libDirRes versionRes of + -- This is the successful path + (CradleSuccess (libDir, version)) -> pure (Right (r, libDir, version)) + CradleFail err -> return (Left [err]) + CradleNone -> do + logWith recorder Info $ LogNoneCradleFound file + return (Left []) + + CradleFail err -> return (Left [err]) + CradleNone -> do + logWith recorder Info $ LogNoneCradleFound file + return (Left []) + + where + loadStyle = case loadConfig of + PreferSingleComponentLoading -> LoadFile + PreferMultiComponentLoading -> LoadWithContext old_fps + +-- ---------------------------------------------------------------------------- +-- Utilities +-- ---------------------------------------------------------------------------- + +emptyHscEnvM :: FilePath -> SessionM HscEnv +emptyHscEnvM libDir = do + nc <- asks sessionSharedNameCache + liftIO $ Ghc.emptyHscEnv nc libDir + +toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))] +toFlagsMap TargetDetails{..} = + [ (l, (targetEnv, targetDepends)) | l <- targetLocations] + +-- | Mapping from @hie.yaml@ to all components that have been loaded +-- from this @hie.yaml@ location. +-- +-- See Note [Multi Cradle Dependency Info] +type HieMap = Map.Map (Maybe FilePath) [RawComponentInfo] + +-- | Maps a @hie.yaml@ location to all its Target Filepaths and options. +-- Reverse of 'FilesMap'. +type FlagsMap = STM.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo)) +-- | Maps a Filepath to its respective @hie.yaml@ location. +-- It aims to be the reverse of 'FlagsMap'. +type FilesMap = STM.Map NormalizedFilePath (Maybe FilePath) + +-- | Memoize an IO function, with the characteristics: +-- +-- * If multiple people ask for a result simultaneously, make sure you only compute it once. +-- +-- * If there are exceptions, repeatedly reraise them. +-- +-- * If the caller is aborted (async exception) finish computing it anyway. +memoIO :: Ord a => (a -> IO b) -> IO (a -> IO b) +memoIO op = do + ref <- newVar Map.empty + return $ \k -> join $ mask_ $ modifyVar ref $ \mp -> + case Map.lookup k mp of + Nothing -> do + res <- onceFork $ op k + return (Map.insert k res mp, res) + Just res -> return (mp, res) + +---------------------------------------------------------------------------------------------------- + +data PackageSetupException + = PackageSetupException + { message :: !String + } + | GhcVersionMismatch + { compileTime :: !Version + , runTime :: !Version + } + deriving (Eq, Show, Typeable) + +instance Exception PackageSetupException + +showPackageSetupException :: PackageSetupException -> String +showPackageSetupException GhcVersionMismatch{..} = unwords + ["ghcide compiled against GHC" + ,showVersion compileTime + ,"but currently using" + ,showVersion runTime + ,"\nThis is unsupported, ghcide must be compiled with the same GHC version as the project." + ] +showPackageSetupException PackageSetupException{..} = unwords + [ "ghcide compiled by GHC", showVersion fullCompilerVersion + , "failed to load packages:", message <> "." + , "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."] + +renderPackageSetupException :: FilePath -> PackageSetupException -> FileDiagnostic +renderPackageSetupException fp e = + ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) Nothing diff --git a/session-loader/Development/IDE/Session/Dependency.hs b/session-loader/Development/IDE/Session/Dependency.hs new file mode 100644 --- /dev/null +++ b/session-loader/Development/IDE/Session/Dependency.hs @@ -0,0 +1,35 @@ +module Development.IDE.Session.Dependency where + +import Control.Exception.Safe as Safe +import Data.Either.Extra +import qualified Data.Map.Strict as Map +import Data.Time.Clock +import System.Directory + +type DependencyInfo = Map.Map FilePath (Maybe UTCTime) + +-- | Check if any dependency has been modified lately. +checkDependencyInfo :: DependencyInfo -> IO Bool +checkDependencyInfo old_di = do + di <- getDependencyInfo (Map.keys old_di) + return (di == old_di) + +-- Note [Multi Cradle Dependency Info] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Why do we implement our own file modification tracking here? +-- The primary reason is that the custom caching logic is quite complicated and going into shake +-- adds even more complexity and more indirection. I did try for about 5 hours to work out how to +-- use shake rules rather than IO but eventually gave up. + +-- | Computes a mapping from a filepath to its latest modification date. +-- See Note [Multi Cradle Dependency Info] why we do this ourselves instead +-- of letting shake take care of it. +getDependencyInfo :: [FilePath] -> IO DependencyInfo +getDependencyInfo fs = Map.fromList <$> mapM do_one fs + + where + safeTryIO :: IO a -> IO (Either IOException a) + safeTryIO = Safe.try + + do_one :: FilePath -> IO (FilePath, Maybe UTCTime) + do_one fp = (fp,) . eitherToMaybe <$> safeTryIO (getModificationTime fp) diff --git a/session-loader/Development/IDE/Session/Diagnostics.hs b/session-loader/Development/IDE/Session/Diagnostics.hs new file mode 100644 --- /dev/null +++ b/session-loader/Development/IDE/Session/Diagnostics.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Development.IDE.Session.Diagnostics where +import Control.Applicative +import Control.Lens +import Control.Monad +import qualified Data.Aeson as Aeson +import Data.List +import Data.List.Extra (split) +import Data.Maybe +import qualified Data.Text as T +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.Location +import GHC.Generics +import qualified HIE.Bios.Cradle as HieBios +import HIE.Bios.Types hiding (Log) +import System.FilePath + +data CradleErrorDetails = + CradleErrorDetails + { cradleDependencies :: [FilePath] + -- ^ files related to the cradle error + -- i.e. .cabal, cabal.project, etc. + , structuredCradleError :: Maybe StructuredCradleError + -- ^ structured information about the cradle error + -- i.e. unknownModules error + } deriving (Show, Eq, Ord, Read, Generic, Aeson.ToJSON, Aeson.FromJSON) + +data StructuredCradleError + = UnknownModuleError UnknownModuleDetails + deriving (Show, Eq, Ord, Read, Generic, Aeson.ToJSON, Aeson.FromJSON) + +data UnknownModuleDetails = + UnknownModuleDetails + { moduleFilePath :: FilePath + , suggestedModuleName :: String + } deriving (Show, Eq, Ord, Read, Generic, Aeson.ToJSON, Aeson.FromJSON) + +{- | Takes a cradle error, the corresponding cradle and the file path where + the cradle error occurred (of the file we attempted to load). + Depicts the cradle error in a user-friendly way. +-} +renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic +renderCradleError cradleError cradle nfp = + let noDetails = + ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines $ map T.pack userFriendlyMessage) Nothing + in + if HieBios.isCabalCradle cradle + then noDetails & fdLspDiagnosticL %~ \diag -> diag + { _data_ = Just $ Aeson.toJSON CradleErrorDetails + { cradleDependencies = absDeps + , structuredCradleError = fmap UnknownModuleError mkUnknownModuleDetails + } + } + else noDetails + where + ms = cradleErrorStderr cradleError + + absDeps = fmap (cradleRootDir cradle ) (cradleErrorDependencies cradleError) + userFriendlyMessage :: [String] + userFriendlyMessage + | HieBios.isCabalCradle cradle = fromMaybe ms $ fileMissingMessage <|> (unknownModuleMessage (fromNormalizedFilePath nfp) <$ mkUnknownModuleDetails) + | otherwise = ms + + -- Produce structured details when unknown module error is detected + mkUnknownModuleDetails :: Maybe UnknownModuleDetails + mkUnknownModuleDetails + | any (isInfixOf "Failed extracting script block:") ms = + let fp = fromNormalizedFilePath nfp + in Just UnknownModuleDetails + { moduleFilePath = fp + , suggestedModuleName = dropExtension (takeFileName fp) + } + | otherwise = Nothing + + fileMissingMessage :: Maybe [String] + fileMissingMessage = + multiCradleErrMessage <$> parseMultiCradleErr ms + +-- | Information included in Multi Cradle error messages +data MultiCradleErr = MultiCradleErr + { mcPwd :: FilePath + , mcFilePath :: FilePath + , mcPrefixes :: [(FilePath, String)] + } deriving (Show) + +-- | Attempt to parse a multi-cradle message +parseMultiCradleErr :: [String] -> Maybe MultiCradleErr +parseMultiCradleErr ms = do + _ <- lineAfter "Multi Cradle: " + wd <- lineAfter "pwd: " + fp <- lineAfter "filepath: " + ps <- prefixes + pure $ MultiCradleErr wd fp ps + + where + lineAfter :: String -> Maybe String + lineAfter pre = listToMaybe $ mapMaybe (stripPrefix pre) ms + + prefixes :: Maybe [(FilePath, String)] + prefixes = do + pure $ mapMaybe tuple ms + + tuple :: String -> Maybe (String, String) + tuple line = do + line' <- surround '(' line ')' + [f, s] <- pure $ split (==',') line' + pure (f, s) + + -- extracts the string surrounded by required characters + surround :: Char -> String -> Char -> Maybe String + surround start s end = do + guard (listToMaybe s == Just start) + guard (listToMaybe (reverse s) == Just end) + pure $ drop 1 $ take (length s - 1) s + +multiCradleErrMessage :: MultiCradleErr -> [String] +multiCradleErrMessage e = + unknownModuleMessage (mcFilePath e) + <> [""] + <> map prefix (mcPrefixes e) + where + prefix (f, r) = f <> " - " <> r + +unknownModuleMessage :: String -> [String] +unknownModuleMessage moduleFileName = + [ "Loading the module '" <> moduleFileName <> "' failed." + , "" + , "It may not be listed in your .cabal file!" + , "Perhaps you need to add `"<> dropExtension (takeFileName moduleFileName) <> "` to other-modules or exposed-modules." + , "" + , "For more information, visit: https://cabal.readthedocs.io/en/3.4/developing-packages.html#modules-included-in-the-package" + ] diff --git a/session-loader/Development/IDE/Session/Ghc.hs b/session-loader/Development/IDE/Session/Ghc.hs new file mode 100644 --- /dev/null +++ b/session-loader/Development/IDE/Session/Ghc.hs @@ -0,0 +1,578 @@ +{-# LANGUAGE CPP #-} +module Development.IDE.Session.Ghc where + +import Control.Monad +import Control.Monad.Extra as Extra +import Control.Monad.IO.Class +import qualified Crypto.Hash.SHA1 as H +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Char8 as B +import Data.Function +import Data.List +import Data.List.Extra as L +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Text as T +import Development.IDE.Core.Shake hiding (Log, knownTargets, + withHieDb) +import qualified Development.IDE.GHC.Compat as Compat +import Development.IDE.GHC.Compat.CmdLine +import Development.IDE.GHC.Compat.Core hiding (Target, TargetFile, + TargetModule, Var, Warning, + getOptions) +import qualified Development.IDE.GHC.Compat.Core as GHC +import Development.IDE.GHC.Compat.Env hiding (Logger) +import Development.IDE.GHC.Compat.Units (UnitId) +import Development.IDE.GHC.Util +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq) +import Development.IDE.Types.Location +import GHC.ResponseFile +import qualified HIE.Bios.Cradle.Utils as HieBios +import HIE.Bios.Environment hiding (getCacheDir) +import HIE.Bios.Types hiding (Log) +import Ide.Logger (Pretty (pretty), + Priority (Debug, Error, Info), + Recorder, WithPriority, + logWith, viaShow, (<+>)) +import System.Directory +import System.FilePath +import System.Info + + +import Control.DeepSeq +import Control.Exception (evaluate) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import qualified Data.Set as OS +import qualified Development.IDE.GHC.Compat.Util as Compat +import Development.IDE.Session.Dependency +import Development.IDE.Types.Options +import GHC.Data.Graph.Directed +import Ide.PluginUtils (toAbsolute) + +import GHC.Driver.Env (hsc_all_home_unit_ids) +import GHC.Driver.Errors.Types +import GHC.Types.Error (errMsgDiagnostic, + singleMessage) +import GHC.Unit.State + + +#if MIN_VERSION_ghc(9,13,0) +import GHC.Driver.Make (checkHomeUnitsClosed) +#endif + +data Log + = LogInterfaceFilesCacheDir !FilePath + | LogMakingNewHscEnv ![UnitId] + | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo) + | LogDLLLoadError !String +deriving instance Show Log + +instance Pretty Log where + pretty = \case + LogInterfaceFilesCacheDir path -> + "Interface files cache directory:" <+> pretty path + LogMakingNewHscEnv inPlaceUnitIds -> + "Making new HscEnv. In-place unit ids:" <+> pretty (map show inPlaceUnitIds) + LogNewComponentCache componentCache -> + "New component cache HscEnvEq:" <+> viaShow componentCache + LogDLLLoadError errorString -> + "Error dynamically loading libm.so.6:" <+> pretty errorString +-- | Configuration info for a particular home unit. +data HomeUnitConfig = HomeUnitConfig + { + -- | The dynamic flags to compile this specific unit. + homeUnitDynFlags :: DynFlags + -- | All the targets for this unit. + , homeUnitTargets :: [GHC.Target] + -- | Optional hash seed to differentiate home units + -- with same `-this-unit-id`. Used when `-this-unit-id` is "main", + -- which is common when loading a single target. + , homeUnitHash :: Maybe B.ByteString + } +-- This is pristine information about a component +data RawComponentInfo = RawComponentInfo + { rawComponentUnitId :: UnitId + -- | Unprocessed DynFlags. Contains inplace packages such as libraries. + -- We do not want to use them unprocessed. + , rawComponentDynFlags :: DynFlags + -- | All targets of this components. + , rawComponentTargets :: [GHC.Target] + -- | Filepath which caused the creation of this component + , rawComponentFP :: NormalizedFilePath + -- | Component Options used to load the component. + , rawComponentCOptions :: ComponentOptions + -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file + -- to last modification time. See Note [Multi Cradle Dependency Info]. + , rawComponentDependencyInfo :: DependencyInfo + -- | An optional hash seed generated in 'setOptions' for the unit id "main". + , rawComponentHash :: Maybe B.ByteString + } + +-- This is processed information about the component, in particular the dynflags will be modified. +data ComponentInfo = ComponentInfo + { componentUnitId :: UnitId + -- | Processed DynFlags. Does not contain inplace packages such as local + -- libraries. Can be used to actually load this Component. + , componentDynFlags :: DynFlags + -- | All targets of this components. + , componentTargets :: [GHC.Target] + -- | Filepath which caused the creation of this component + , componentFP :: NormalizedFilePath + -- | Component Options used to load the component. + , componentCOptions :: ComponentOptions + -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file + -- to last modification time. See Note [Multi Cradle Dependency Info] + , componentDependencyInfo :: DependencyInfo + } + + +unit_flags :: [Flag (CmdLineP [String])] +unit_flags = [defFlag "unit" (SepArg addUnit)] + +addUnit :: String -> EwM (CmdLineP [String]) () +addUnit unit_str = liftEwM $ do + units <- getCmdLineState + putCmdLineState (unit_str : units) + + +-- | Create a mapping from FilePaths to HscEnvEqs +-- This combines all the components we know about into +-- an appropriate session, which is a multi component +-- session on GHC 9.4+ +newComponentCache + :: Recorder (WithPriority Log) + -> [String] -- ^ File extensions to consider + -> NormalizedFilePath -- ^ Path to file that caused the creation of this component + -> HscEnv -- ^ An empty HscEnv + -> [ComponentInfo] -- ^ New components to be loaded + -> [ComponentInfo] -- ^ old, already existing components + -> IO [ [TargetDetails] ] +newComponentCache recorder exts _cfp hsc_env old_cis new_cis = do + let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis) + -- When we have multiple components with the same uid, + -- prefer the new one over the old. + -- However, we might have added some targets to the old unit + -- (see special target), so preserve those + unionCIs new_ci old_ci = new_ci { componentTargets = componentTargets new_ci ++ componentTargets old_ci } + mkMap = Map.fromListWith unionCIs . map (\ci -> (componentUnitId ci, ci)) + let dfs = map componentDynFlags $ Map.elems cis + uids = Map.keys cis + logWith recorder Info $ LogMakingNewHscEnv uids + hscEnv' <- -- Set up a multi component session with the other units on GHC 9.4 + Compat.initUnits dfs hsc_env + +#if MIN_VERSION_ghc(9,13,0) + let closure_errs_raw = checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') + closure_errs = concatMap (Compat.bagToList . Compat.getMessages) closure_errs_raw +#else + let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv') +#endif + closure_err_to_multi_err err = + ideErrorWithSource + (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp + (T.pack (Compat.printWithoutUniques (singleMessage err))) + (Just (fmap GhcDriverMessage err)) + multi_errs = map closure_err_to_multi_err closure_errs + bad_units = OS.fromList $ concat $ do + x <- map errMsgDiagnostic closure_errs + DriverHomePackagesNotClosed us <- pure x + pure us + isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units + -- Whenever we spin up a session on Linux, dynamically load libm.so.6 + -- in. We need this in case the binary is statically linked, in which + -- case the interactive session will fail when trying to load + -- ghc-prim, which happens whenever Template Haskell is being + -- evaluated or haskell-language-server's eval plugin tries to run + -- some code. If the binary is dynamically linked, then this will have + -- no effect. + -- See https://github.com/haskell/haskell-language-server/issues/221 + -- We need to do this after the call to setSessionDynFlags initialises + -- the loader + when (os == "linux") $ do + initObjLinker hscEnv' + res <- loadDLL hscEnv' "libm.so.6" + case res of + Nothing -> pure () + Just err -> logWith recorder Error $ LogDLLLoadError err + + forM (Map.elems cis) $ \ci -> do + let df = componentDynFlags ci + thisEnv <- do + -- In GHC 9.4 we have multi component support, and we have initialised all the units + -- above. + -- We just need to set the current unit here + pure $ hscSetActiveUnitId (homeUnitId_ df) hscEnv' + henv <- newHscEnvEq thisEnv + let targetEnv = (if isBad ci then multi_errs else [], Just henv) + targetDepends = componentDependencyInfo ci + logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends) + evaluate $ liftRnf rwhnf $ componentTargets ci + + let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends + ctargets <- concatMapM mk (componentTargets ci) + + return (L.nubOrdOn targetTarget ctargets) + +-- | Throws if package flags are unsatisfiable +setOptions :: GhcMonad m + => OptHaddockParse + -> NormalizedFilePath + -> ComponentOptions + -> DynFlags + -> FilePath -- ^ root dir, see Note [Root Directory] + -> m (NonEmpty HomeUnitConfig) +setOptions haddockOpt cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do + ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts) + case NE.nonEmpty units of + Just us -> initMulti us + Nothing -> do + (HomeUnitConfig df targets mHash) <- initOne (map unLoc theOpts') + -- A special target for the file which caused this wonderful + -- component to be created. In case the cradle doesn't list all the targets for + -- the component, in which case things will be horribly broken anyway. + -- + -- When we have a singleComponent that is caused to be loaded due to a + -- file, we assume the file is part of that component. This is useful + -- for bare GHC sessions, such as many of the ones used in the testsuite + -- + -- We don't do this when we have multiple components, because each + -- component better list all targets or there will be anarchy. + -- It is difficult to know which component to add our file to in + -- that case. + -- Multi unit arguments are likely to come from cabal, which + -- does list all targets. + -- + -- If we don't end up with a target for the current file in the end, then + -- we will report it as an error for that file + let abs_fp = toAbsolute rootDir (fromNormalizedFilePath cfp) + let special_target = Compat.mkSimpleTarget df abs_fp + pure $ HomeUnitConfig df (special_target : targets) mHash :| [] + where + initMulti unitArgFiles = + forM unitArgFiles $ \f -> do + args <- liftIO $ expandResponse [f] + -- The reponse files may contain arguments like "+RTS", + -- and hie-bios doesn't expand the response files of @-unit@ arguments. + -- Thus, we need to do the stripping here. + initOne $ HieBios.removeRTS $ HieBios.removeVerbosityOpts args + initOne this_opts = do + (dflags', targets') <- addCmdOpts this_opts dflags + let (dflags'',mHash) = + case unitIdString (homeUnitId_ dflags') of + -- cabal uses main for the unit id of all executable packages + -- This makes multi-component sessions confused about what + -- options to use for that component. + -- Solution: hash the options and use that as part of the unit id + -- This works because there won't be any dependencies on the + -- executable unit. + "main" -> + let hashBytes =H.finalize $ H.updates H.init (map B.pack this_opts) + hash = B.unpack $ B16.encode hashBytes + hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash)) + in (setHomeUnitId_ hashed_uid dflags', Just hashBytes) + _ -> (dflags', Nothing) + + let targets = makeTargetsAbsolute root targets' + root = case workingDirectory dflags'' of + Nothing -> compRoot + Just wdir -> compRoot wdir + let dflags''' = + setWorkingDirectory root $ + disableWarningsAsErrors $ + -- disabled, generated directly by ghcide instead + flip gopt_unset Opt_WriteInterface $ + -- disabled, generated directly by ghcide instead + -- also, it can confuse the interface stale check + dontWriteHieFiles $ + setIgnoreInterfacePragmas $ + setBytecodeLinkerOptions $ + enableOptHaddock haddockOpt $ + disableOptimisation $ + Compat.setUpTypedHoles $ + makeDynFlagsAbsolute compRoot -- makeDynFlagsAbsolute already accounts for workingDirectory + dflags'' + return (HomeUnitConfig dflags''' targets mHash) + +addComponentInfo :: + MonadUnliftIO m => + Recorder (WithPriority Log) -> + (String -> Maybe B.ByteString -> [String] -> IO CacheDirs) -> + DependencyInfo -> + NonEmpty HomeUnitConfig-> + (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> + Map.Map (Maybe FilePath) [RawComponentInfo] -> + m (Map.Map (Maybe FilePath) [RawComponentInfo], ([ComponentInfo], [ComponentInfo])) +addComponentInfo recorder getCacheDirs dep_info newDynFlags (hieYaml, cfp, opts) m = do + -- Just deps if there's already an HscEnv + -- Nothing is it's the first time we are making an HscEnv + let oldDeps = Map.lookup hieYaml m + let -- Add the raw information about this component to the list + -- We will modify the unitId and DynFlags used for + -- compilation but these are the true source of + -- information. + new_deps = fmap (\(HomeUnitConfig df targets mHash) -> RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info mHash) newDynFlags + all_deps = new_deps `NE.appendList` fromMaybe [] oldDeps + -- Get all the unit-ids for things in this component + + all_deps' <- forM all_deps $ \RawComponentInfo{..} -> do + let prefix = show rawComponentUnitId + -- See Note [Avoiding bad interface files] + let cacheDirOpts = componentOptions opts + cacheDirs <- liftIO $ getCacheDirs prefix rawComponentHash cacheDirOpts + processed_df <- setCacheDirs recorder cacheDirs rawComponentDynFlags + -- The final component information, mostly the same but the DynFlags don't + -- contain any packages which are also loaded + -- into the same component. + pure $ ComponentInfo + { componentUnitId = rawComponentUnitId + , componentDynFlags = processed_df + , componentTargets = rawComponentTargets + , componentFP = rawComponentFP + , componentCOptions = rawComponentCOptions + , componentDependencyInfo = rawComponentDependencyInfo + } + -- Modify the map so the hieYaml now maps to the newly updated + -- ComponentInfos + -- Returns + -- . The information for the new component which caused this cache miss + -- . The modified information (without -inplace flags) for + -- existing packages + let (new,old) = NE.splitAt (NE.length new_deps) all_deps' + pure (Map.insert hieYaml (NE.toList all_deps) m, (new,old)) + +setIgnoreInterfacePragmas :: DynFlags -> DynFlags +setIgnoreInterfacePragmas df = + gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges + +disableOptimisation :: DynFlags -> DynFlags +disableOptimisation df = updOptLevel 0 df + +-- | We always compile with '-haddock' unless explicitly disabled. +-- +-- This avoids inconsistencies when doing recompilation checking which was +-- observed in https://github.com/haskell/haskell-language-server/issues/4511 +enableOptHaddock :: OptHaddockParse -> DynFlags -> DynFlags +enableOptHaddock HaddockParse d = gopt_set d Opt_Haddock +enableOptHaddock NoHaddockParse d = d + +setHiDir :: FilePath -> DynFlags -> DynFlags +setHiDir f d = + -- override user settings to avoid conflicts leading to recompilation + d { hiDir = Just f} + +setODir :: FilePath -> DynFlags -> DynFlags +setODir f d = + -- override user settings to avoid conflicts leading to recompilation + d { objectDir = Just f} + +data CacheDirs = CacheDirs + { hiCacheDir, hieCacheDir, oCacheDir :: Maybe FilePath} + +{- Note [Avoiding bad interface files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Originally, we set the cache directory for the various components once +on the first occurrence of the component. +This works fine if these components have no references to each other, +but you have components that depend on each other, the interface files are +updated for each component. +After restarting the session and only opening the component that depended +on the other, suddenly the interface files of this component are stale. +However, from the point of view of `ghcide`, they do not look stale, +thus, not regenerated and the IDE shows weird errors such as: +``` +typecheckIface +Declaration for Rep_ClientRunFlags +Axiom branches Rep_ClientRunFlags: + Failed to load interface for ‘Distribution.Simple.Flag’ + Use -v to see a list of the files searched for. +``` +and +``` +expectJust checkFamInstConsistency +CallStack (from HasCallStack): + error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes + expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst +``` + +and many more. + +To mitigate this, we set the cache directory for each component dependent +on the components of the current `HscEnv`, additionally to the component options +of the respective components. +Assume two components, c1, c2, where c2 depends on c1, and the options of the +respective components are co1, co2. +If we want to load component c2, followed by c1, we set the cache directory for +each component in this way: + + * Load component c2 + * (Cache Directory State) + - name of c2 + co2 + * Load component c1 + * (Cache Directory State) + - name of c2 + name of c1 + co2 + - name of c2 + name of c1 + co1 + +Overall, we created three cache directories. If we opened c1 first, then we +create a fourth cache directory. +This makes sure that interface files are always correctly updated. + +Since this causes a lot of recompilation, we only update the cache-directory, +if the dependencies of a component have really changed. +E.g. when you load two executables, they can not depend on each other. They +should be filtered out, such that we dont have to re-compile everything. +-} + + +-- | Set the cache-directory based on the ComponentOptions and a list of +-- internal packages. +-- For the exact reason, see Note [Avoiding bad interface files]. +setCacheDirs :: MonadUnliftIO m => Recorder (WithPriority Log) -> CacheDirs -> DynFlags -> m DynFlags +setCacheDirs recorder CacheDirs{..} dflags = do + logWith recorder Info $ LogInterfaceFilesCacheDir (fromMaybe cacheDir hiCacheDir) + pure $ dflags + & maybe id setHiDir hiCacheDir + & maybe id setHieDir hieCacheDir + & maybe id setODir oCacheDir + +-- | Append the hash to the unit id to create unique cache folders. +-- +-- This function generates a single, unified hash. +-- If an optional base hash (@mFirstHash@) is provided—which +-- is common for a single target with `-this-unit-id` as "main"- +-- we set the prefix to "main", extract the context generated +-- from the @mFirstHash@, and update the @opts@ into the same hash. +-- +-- This guarantees a unique cache folder for different GHC +-- options(avoiding incompatible interface files) while +-- keeping the path short and clean. +getCacheDirsDefault :: String -> Maybe B.ByteString -> [String] -> IO CacheDirs +getCacheDirsDefault prefix mFirstHash opts = do + dir <- Just <$> getXdgDirectory XdgCache (cacheDir prefix' ++ "-" ++ opts_hash) + return $ CacheDirs dir dir dir + where + -- Create a unique folder per set of different GHC options. + prefix' = if isJust mFirstHash then "main" else prefix + basectx = case mFirstHash of + Just h -> H.updates H.init [h] + Nothing -> H.init + opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates basectx (map B.pack opts) + +setNameCache :: NameCache -> HscEnv -> HscEnv +setNameCache nc hsc = hsc { hsc_NC = nc } + +-- | Sub directory for the cache path +cacheDir :: String +cacheDir = "ghcide" + +emptyHscEnv :: NameCache -> FilePath -> IO HscEnv +emptyHscEnv nc libDir = do + -- We call setSessionDynFlags so that the loader is initialised + -- We need to do this before we call initUnits. + env <- liftIO $ runGhc (Just libDir) $ + getSessionDynFlags >>= setSessionDynFlags >> getSession + pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) + +-- ---------------------------------------------------------------------------- +-- Target Details +-- ---------------------------------------------------------------------------- + +data TargetDetails = TargetDetails + { + targetTarget :: !Target, + targetEnv :: !(IdeResult HscEnvEq), + targetDepends :: !DependencyInfo, + targetLocations :: ![NormalizedFilePath] + } + +fromTargetId :: [FilePath] -- ^ import paths + -> [String] -- ^ extensions to consider + -> TargetId + -> IdeResult HscEnvEq + -> DependencyInfo + -> IO [TargetDetails] +-- For a target module we consider all the import paths +fromTargetId is exts (GHC.TargetModule modName) env dep = do + let fps = [i moduleNameSlashes modName -<.> ext <> boot + | ext <- exts + , i <- is + , boot <- ["", "-boot"] + ] + let locs = fmap toNormalizedFilePath' fps + return [TargetDetails (TargetModule modName) env dep locs] +-- For a 'TargetFile' we consider all the possible module names +fromTargetId _ _ (GHC.TargetFile f _) env deps = do + let nf = toNormalizedFilePath' f + let other + | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf) + | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot") + return [TargetDetails (TargetFile nf) env deps [nf, other]] + +-- ---------------------------------------------------------------------------- +-- Backwards compatibility +-- ---------------------------------------------------------------------------- + +#if MIN_VERSION_ghc(9,13,0) +-- Moved back to implementation in GHC. +checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> [DriverMessages] +checkHomeUnitsClosed' ue _ = checkHomeUnitsClosed ue +#else +-- This function checks the important property that if both p and q are home units +-- then any dependency of p, which transitively depends on q is also a home unit. +-- GHC had an implementation of this function, but it was horribly inefficient +-- We should move back to the GHC implementation on compilers where +-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12162 is included +checkHomeUnitsClosed' :: UnitEnv -> OS.Set UnitId -> Maybe (Compat.MsgEnvelope DriverMessage) +checkHomeUnitsClosed' ue home_id_set + | OS.null bad_unit_ids = Nothing + | otherwise = Just (GHC.mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (OS.toList bad_unit_ids)) + where + bad_unit_ids = upwards_closure OS.\\ home_id_set + rootLoc = mkGeneralSrcSpan (Compat.fsLit "") + + graph :: Graph (Node UnitId UnitId) + graph = graphFromEdgedVerticesUniq graphNodes + + -- downwards closure of graph + downwards_closure + = graphFromEdgedVerticesUniq [ DigraphNode uid uid (OS.toList deps) + | (uid, deps) <- Map.toList (allReachable graph node_key)] + + inverse_closure = transposeG downwards_closure + + upwards_closure = OS.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- OS.toList home_id_set] + + all_unit_direct_deps :: UniqMap UnitId (OS.Set UnitId) + all_unit_direct_deps + = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue + where + go rest this this_uis = + plusUniqMap_C OS.union + (addToUniqMap_C OS.union external_depends this (OS.fromList this_deps)) + rest + where + external_depends = mapUniqMap (OS.fromList . unitDepends) +#if !MIN_VERSION_ghc(9,7,0) + $ listToUniqMap $ Map.toList +#endif + + $ unitInfoMap this_units + this_units = homeUnitEnv_units this_uis + this_deps = [ Compat.toUnitId unit | (unit,Just _) <- explicitUnits this_units] + + graphNodes :: [Node UnitId UnitId] + graphNodes = go OS.empty home_id_set + where + go done todo + = case OS.minView todo of + Nothing -> [] + Just (uid, todo') + | OS.member uid done -> go done todo' + | otherwise -> case lookupUniqMap all_unit_direct_deps uid of + Nothing -> pprPanic "uid not found" (Compat.ppr (uid, all_unit_direct_deps)) + Just depends -> + let todo'' = (depends OS.\\ done) `OS.union` todo' + in DigraphNode uid uid (OS.toList depends) : go (OS.insert uid done) todo'' +#endif diff --git a/session-loader/Development/IDE/Session/Implicit.hs b/session-loader/Development/IDE/Session/Implicit.hs new file mode 100644 --- /dev/null +++ b/session-loader/Development/IDE/Session/Implicit.hs @@ -0,0 +1,155 @@ +module Development.IDE.Session.Implicit + ( loadImplicitCradle + ) where + + +import Control.Applicative ((<|>)) +import Control.Exception (handleJust) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe +import Data.Bifunctor +import Data.Functor ((<&>)) +import Data.Maybe +import Data.Void +import System.Directory hiding (findFile) +import System.FilePath +import System.IO.Error + +import Colog.Core (LogAction (..), WithSeverity (..)) +import HIE.Bios.Config +import HIE.Bios.Cradle (defaultCradle, getCradle) +import HIE.Bios.Types hiding (ActionName (..)) + +import Hie.Cabal.Parser +import Hie.Locate +import qualified Hie.Yaml as Implicit + +loadImplicitCradle :: Show a => LogAction IO (WithSeverity Log) -> FilePath -> IO (Cradle a) +loadImplicitCradle l wfile = do + is_dir <- doesDirectoryExist wfile + let wdir | is_dir = wfile + | otherwise = takeDirectory wfile + cfg <- runMaybeT (implicitConfig wdir) + case cfg of + Just bc -> getCradle l absurd bc + Nothing -> return $ defaultCradle l wdir + +-- | Wraps up the cradle inferred by @inferCradleTree@ as a @CradleConfig@ with no dependencies +implicitConfig :: FilePath -> MaybeT IO (CradleConfig a, FilePath) +implicitConfig = (fmap . first) (CradleConfig noDeps) . inferCradleTree + where + noDeps :: [FilePath] + noDeps = [] + + +inferCradleTree :: FilePath -> MaybeT IO (CradleTree a, FilePath) +inferCradleTree start_dir = + maybeItsBios + -- If we have both a config file (cabal.project/stack.yaml) and a work dir + -- (dist-newstyle/.stack-work), prefer that + <|> (cabalExecutable >> cabalConfigDir start_dir >>= \dir -> cabalWorkDir dir >> pure (simpleCabalCradle dir)) + <|> (stackExecutable >> stackConfigDir start_dir >>= \dir -> stackWorkDir dir >> stackCradle dir) + -- If we have a cabal.project OR we have a .cabal and dist-newstyle, prefer cabal + <|> (cabalExecutable >> (cabalConfigDir start_dir <|> cabalFileAndWorkDir) <&> simpleCabalCradle) + -- If we have a stack.yaml, use stack + <|> (stackExecutable >> stackConfigDir start_dir >>= stackCradle) + -- If we have a cabal file, use cabal + <|> (cabalExecutable >> cabalFileDir start_dir <&> simpleCabalCradle) + + where + maybeItsBios = (\wdir -> (Bios (Program $ wdir ".hie-bios") Nothing Nothing, wdir)) <$> biosWorkDir start_dir + + cabalFileAndWorkDir = cabalFileDir start_dir >>= (\dir -> cabalWorkDir dir >> pure dir) + +-- | Generate a stack cradle given a filepath. +-- +-- Since we assume there was proof that this file belongs to a stack cradle +-- we look immediately for the relevant @*.cabal@ and @stack.yaml@ files. +-- We do not look for package.yaml, as we assume the corresponding .cabal has +-- been generated already. +-- +-- We parse the @stack.yaml@ to find relevant @*.cabal@ file locations, then +-- we parse the @*.cabal@ files to generate a mapping from @hs-source-dirs@ to +-- component names. +stackCradle :: FilePath -> MaybeT IO (CradleTree a, FilePath) +stackCradle fp = do + pkgs <- stackYamlPkgs fp + pkgsWithComps <- liftIO $ catMaybes <$> mapM (nestedPkg fp) pkgs + let yaml = fp "stack.yaml" + pure $ (,fp) $ case pkgsWithComps of + [] -> Stack (StackType Nothing (Just yaml)) + ps -> StackMulti mempty $ do + Package n cs <- ps + c <- cs + let (prefix, comp) = Implicit.stackComponent n c + pure (prefix, StackType (Just comp) (Just yaml)) + +-- | By default, we generate a simple cabal cradle which is equivalent to the +-- following hie.yaml: +-- +-- @ +-- cradle: +-- cabal: +-- @ +-- +-- Note, this only works reliable for reasonably modern cabal versions >= 3.2. +simpleCabalCradle :: FilePath -> (CradleTree a, FilePath) +simpleCabalCradle fp = (Cabal $ CabalType Nothing Nothing, fp) + +cabalExecutable :: MaybeT IO FilePath +cabalExecutable = MaybeT $ findExecutable "cabal" + +stackExecutable :: MaybeT IO FilePath +stackExecutable = MaybeT $ findExecutable "stack" + +biosWorkDir :: FilePath -> MaybeT IO FilePath +biosWorkDir = findFileUpwards (".hie-bios" ==) + +cabalWorkDir :: FilePath -> MaybeT IO () +cabalWorkDir wdir = do + check <- liftIO $ doesDirectoryExist (wdir "dist-newstyle") + unless check $ fail "No dist-newstyle" + +stackWorkDir :: FilePath -> MaybeT IO () +stackWorkDir wdir = do + check <- liftIO $ doesDirectoryExist (wdir ".stack-work") + unless check $ fail "No .stack-work" + +cabalConfigDir :: FilePath -> MaybeT IO FilePath +cabalConfigDir = findFileUpwards (\fp -> fp == "cabal.project" || fp == "cabal.project.local") + +cabalFileDir :: FilePath -> MaybeT IO FilePath +cabalFileDir = findFileUpwards (\fp -> takeExtension fp == ".cabal") + +stackConfigDir :: FilePath -> MaybeT IO FilePath +stackConfigDir = findFileUpwards isStack + where + isStack name = name == "stack.yaml" + +-- | Searches upwards for the first directory containing a file to match +-- the predicate. +findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath +findFileUpwards p dir = do + cnts <- + liftIO + $ handleJust + -- Catch permission errors + (\(e :: IOError) -> if isPermissionError e then Just [] else Nothing) + pure + (findFile p dir) + + case cnts of + [] | dir' == dir -> fail "No cabal files" + | otherwise -> findFileUpwards p dir' + _ : _ -> return dir + where dir' = takeDirectory dir + +-- | Sees if any file in the directory matches the predicate +findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath] +findFile p dir = do + b <- doesDirectoryExist dir + if b then getFiles >>= filterM doesPredFileExist else return [] + where + getFiles = filter p <$> getDirectoryContents dir + doesPredFileExist file = doesFileExist $ dir file diff --git a/session-loader/Development/IDE/Session/OrderedSet.hs b/session-loader/Development/IDE/Session/OrderedSet.hs new file mode 100644 --- /dev/null +++ b/session-loader/Development/IDE/Session/OrderedSet.hs @@ -0,0 +1,54 @@ +module Development.IDE.Session.OrderedSet where + +import Control.Concurrent.STM (STM, TQueue, newTQueueIO) +import Control.Concurrent.STM.TQueue (readTQueue, writeTQueue) +import Control.Monad (when) +import Data.Hashable (Hashable) +import qualified Data.HashSet +import qualified Focus +import qualified ListT as LT +import qualified StmContainers.Set as S +import StmContainers.Set (Set) + + +data OrderedSet a = OrderedSet + { insertionOrder :: TQueue a + , elements :: Set a + } + +-- | Insert an element into the ordered set. +-- If the element is not already present, it is added to both the queue and set. +-- If the element already exists, ignore it +insert :: Hashable a => a -> OrderedSet a -> STM () +insert a (OrderedSet que s) = do + (_, inserted) <- S.focus (Focus.testingIfInserts $ Focus.insert ()) a s + -- if already in the set + when inserted $ writeTQueue que a + +newIO :: Hashable a => IO (OrderedSet a) +newIO = do + que <- newTQueueIO + s <- S.newIO + return (OrderedSet que s) + +-- | Read the first element from the queue. +-- If an element is not in the set, it means it has been deleted, +-- so we retry until we find a valid element that exists in the set. +readQueue :: Hashable a => OrderedSet a -> STM a +readQueue rs@(OrderedSet que s) = do + f <- readTQueue que + b <- S.lookup f s + -- retry if no files are left in the queue + if b then return f else readQueue rs + +lookup :: Hashable a => a -> OrderedSet a -> STM Bool +lookup a (OrderedSet _ s) = S.lookup a s + +-- | Delete an element from the set. +-- The queue is not modified directly; stale entries are filtered out lazily +-- during reading operations (see 'readQueue'). +delete :: Hashable a => a -> OrderedSet a -> STM () +delete a (OrderedSet _ s) = S.delete a s + +toHashSet :: Hashable a => OrderedSet a -> STM (Data.HashSet.HashSet a) +toHashSet (OrderedSet _ s) = Data.HashSet.fromList <$> LT.toList (S.listT s) diff --git a/session-loader/Development/IDE/Session/VersionCheck.hs b/session-loader/Development/IDE/Session/VersionCheck.hs deleted file mode 100644 --- a/session-loader/Development/IDE/Session/VersionCheck.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - --- | This module exists to circumvent a compile time exception on Windows with --- Stack and GHC 8.10.1. It's just been pulled out from Development.IDE.Session. --- See https://github.com/haskell/ghcide/pull/697 -module Development.IDE.Session.VersionCheck (ghcVersionChecker) where - -import GHC.Check --- Only use this for checking against the compile time GHC libDir! --- Use getRuntimeGhcLibDir from hie-bios instead for everything else --- otherwise binaries will not be distributable since paths will be baked into them -import qualified GHC.Paths - -ghcVersionChecker :: GhcVersionChecker -ghcVersionChecker = $$(makeGhcVersionChecker (return GHC.Paths.libdir)) diff --git a/src/Development/IDE.hs b/src/Development/IDE.hs --- a/src/Development/IDE.hs +++ b/src/Development/IDE.hs @@ -8,11 +8,11 @@ import Development.IDE.Core.Actions as X (getAtPoint, getDefinition, - getTypeDefinition, - useE, useNoFileE, - usesE) + getTypeDefinition) import Development.IDE.Core.FileExists as X (getFileExists) -import Development.IDE.Core.FileStore as X (getFileContents) +import Development.IDE.Core.FileStore as X (getFileContents, + getFileModTimeContents, + getUriContents) import Development.IDE.Core.IdeConfiguration as X (IdeConfiguration (..), isWorkspaceFile) import Development.IDE.Core.OfInterest as X (getFilesOfInterestUntracked) @@ -33,7 +33,7 @@ defineNoDiagnostics, getClientConfig, getPluginConfigAction, - ideLogger, + ideLogger, rootDir, runIdeAction, shakeExtras, use, useNoFile, @@ -52,7 +52,6 @@ import Development.IDE.Plugin as X import Development.IDE.Types.Diagnostics as X import Development.IDE.Types.HscEnvEq as X (HscEnvEq (..), - hscEnv, - hscEnvWithImportPaths) + hscEnv) import Development.IDE.Types.Location as X -import Development.IDE.Types.Logger as X +import Ide.Logger as X diff --git a/src/Development/IDE/Core/Actions.hs b/src/Development/IDE/Core/Actions.hs --- a/src/Development/IDE/Core/Actions.hs +++ b/src/Development/IDE/Core/Actions.hs @@ -1,51 +1,43 @@ -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} module Development.IDE.Core.Actions ( getAtPoint , getDefinition , getTypeDefinition +, getImplementationDefinition , highlightAtPoint , refsAtPoint -, useE -, useNoFileE -, usesE , workspaceSymbols +, lookupMod ) where +import Control.Monad.Extra (mapMaybeM) import Control.Monad.Reader import Control.Monad.Trans.Maybe import qualified Data.HashMap.Strict as HM import Data.Maybe import qualified Data.Text as T import Data.Tuple.Extra +import Development.IDE.Core.LookupMod (lookupMod) import Development.IDE.Core.OfInterest +import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat hiding (writeHieFile) +import Development.IDE.GHC.Compat (DynFlags (..), + ms_hspp_opts) import Development.IDE.Graph import qualified Development.IDE.Spans.AtPoint as AtPoint import Development.IDE.Types.HscEnvEq (hscEnv) import Development.IDE.Types.Location +import GHC.Iface.Ext.Types (Identifier) import qualified HieDb -import Language.LSP.Types (DocumentHighlight (..), - SymbolInformation (..)) - - --- | Eventually this will lookup/generate URIs for files in dependencies, but not in the --- project. Right now, this is just a stub. -lookupMod - :: HieDbWriter -- ^ access the database - -> FilePath -- ^ The `.hie` file we got from the database - -> ModuleName - -> Unit - -> Bool -- ^ Is this file a boot file? - -> MaybeT IdeAction Uri -lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing - +import Language.LSP.Protocol.Types (DocumentHighlight (..), + SymbolInformation (..), + normalizedFilePathToUri, + uriToNormalizedFilePath) --- IMPORTANT NOTE : make sure all rules `useE`d by these have a "Persistent Stale" rule defined, +-- IMPORTANT NOTE : make sure all rules `useWithStaleFastMT`d by these have a "Persistent Stale" rule defined, -- so we can quickly answer as soon as the IDE is opened -- Even if we don't have persistent information on disk for these rules, the persistent rule -- should just return an empty result @@ -58,50 +50,85 @@ ide <- ask opts <- liftIO $ getIdeOptionsIO ide - (hf, mapping) <- useE GetHieAst file - env <- hscEnv . fst <$> useE GhcSession file - dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useE GetDocMap file) - - !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap env pos' + (hf, mapping) <- useWithStaleFastMT GetHieAst file + shakeExtras <- lift askShake -toCurrentLocations :: PositionMapping -> [Location] -> [Location] -toCurrentLocations mapping = mapMaybe go - where - go (Location uri range) = Location uri <$> toCurrentRange mapping range + env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file + modSummary <- fst <$> useWithStaleFastMT GetModSummary file + dkMap <- lift $ maybe (DKMap mempty mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file) + let enabledExtensions = extensionFlags (ms_hspp_opts (msrModSummary modSummary)) --- | useE is useful to implement functions that aren’t rules but need shortcircuiting --- e.g. getDefinition. -useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping) -useE k = MaybeT . useWithStaleFast k + !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) -useNoFileE :: IdeRule k v => IdeState -> k -> MaybeT IdeAction v -useNoFileE _ide k = fst <$> useE k emptyFilePath + MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> + AtPoint.atPoint opts shakeExtras hf dkMap env pos' enabledExtensions -usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT IdeAction [(v,PositionMapping)] -usesE k = MaybeT . fmap sequence . mapM (useWithStaleFast k) +-- | Converts locations in the source code to their current positions, +-- taking into account changes that may have occurred due to edits. +toCurrentLocation + :: PositionMapping + -> NormalizedFilePath + -> Location + -> IdeAction (Maybe Location) +toCurrentLocation mapping file (Location uri range) = + -- The Location we are going to might be in a different + -- file than the one we are calling gotoDefinition from. + -- So we check that the location file matches the file + -- we are in. + if nUri == normalizedFilePathToUri file + -- The Location matches the file, so use the PositionMapping + -- we have. + then pure $ Location uri <$> toCurrentRange mapping range + -- The Location does not match the file, so get the correct + -- PositionMapping and use that instead. + else do + otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do + otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri + useWithStaleFastMT GetHieAst otherLocationFile + pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping) + where + nUri :: NormalizedUri + nUri = toNormalizedUri uri -- | Goto Definition. -getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) +getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)]) getDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide - (HAR _ hf _ _ _, mapping) <- useE GetHieAst file - (ImportMap imports, _) <- useE GetImportMap file + (hf, mapping) <- useWithStaleFastMT GetHieAst file + (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) - toCurrentLocations mapping <$> AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' + locationsWithIdentifier <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' + mapMaybeM (\(location, identifier) -> do + fixedLocation <- MaybeT $ toCurrentLocation mapping file location + pure $ Just (fixedLocation, identifier) + ) locationsWithIdentifier -getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) + +getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, Identifier)]) getTypeDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide - (hf, mapping) <- useE GetHieAst file + (hf, mapping) <- useWithStaleFastMT GetHieAst file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - toCurrentLocations mapping <$> AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos' + locationsWithIdentifier <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos' + mapMaybeM (\(location, identifier) -> do + fixedLocation <- MaybeT $ toCurrentLocation mapping file location + pure $ Just (fixedLocation, identifier) + ) locationsWithIdentifier +getImplementationDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) +getImplementationDefinition file pos = runMaybeT $ do + ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask + opts <- liftIO $ getIdeOptionsIO ide + (hf, mapping) <- useWithStaleFastMT GetHieAst file + !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) + locs <- AtPoint.gotoImplementation withHieDb (lookupMod hiedbWriter) opts hf pos' + traverse (MaybeT . toCurrentLocation mapping file) locs + highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) highlightAtPoint file pos = runMaybeT $ do - (HAR _ hf rf _ _,mapping) <- useE GetHieAst file + (HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) let toCurrentHighlight (DocumentHighlight range t) = flip DocumentHighlight t <$> toCurrentRange mapping range mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos' diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -1,1703 +1,1800 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} - --- | Based on https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/API. --- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values. -module Development.IDE.Core.Compile - ( TcModuleResult(..) - , RunSimplifier(..) - , compileModule - , parseModule - , typecheckModule - , computePackageDeps - , addRelativeImport - , mkHiFileResultCompile - , mkHiFileResultNoCompile - , generateObjectCode - , generateByteCode - , generateHieAsts - , writeAndIndexHieFile - , indexHieFile - , writeHiFile - , getModSummaryFromImports - , loadHieFile - , loadInterface - , RecompilationInfo(..) - , loadModulesHome - , getDocsBatch - , lookupName - , mergeEnvs - , ml_core_file - , coreFileToLinkable - , TypecheckHelpers(..) - ) where - -import Control.Concurrent.Extra -import Control.Concurrent.STM.Stats hiding (orElse) -import Control.DeepSeq (NFData (..), force, liftRnf, - rnf, rwhnf) -import Control.Exception (evaluate) -import Control.Exception.Safe -import Control.Lens hiding (List, (<.>)) -import Control.Monad.Except -import Control.Monad.Extra -import Control.Monad.Trans.Except -import qualified Control.Monad.Trans.State.Strict as S -import Data.Aeson (toJSON) -import Data.Bifunctor (first, second) -import Data.Binary -import qualified Data.ByteString as BS -import Data.Coerce -import qualified Data.DList as DL -import Data.Functor -import Data.Generics.Aliases -import Data.Generics.Schemes -import qualified Data.HashMap.Strict as HashMap -import Data.IntMap (IntMap) -import qualified Data.IntMap.Strict as IntMap -import Data.IORef -import Data.List.Extra -import Data.Map (Map) -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import Data.Maybe -import qualified Data.Text as T -import Data.Time (UTCTime (..)) -import Data.Tuple.Extra (dupe) -import Data.Unique as Unique -import Debug.Trace -import Development.IDE.Core.FileStore (resetInterfaceStore, shareFilePath) -import Development.IDE.Core.Preprocessor -import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Shake -import Development.IDE.Core.Tracing (withTrace) -import Development.IDE.GHC.Compat hiding (loadInterface, - parseHeader, parseModule, - tcRnModule, writeHieFile) -import qualified Development.IDE.GHC.Compat as Compat -import qualified Development.IDE.GHC.Compat as GHC -import qualified Development.IDE.GHC.Compat.Util as Util -import Development.IDE.GHC.CoreFile -import Development.IDE.GHC.Error -import Development.IDE.GHC.Orphans () -import Development.IDE.GHC.Util -import Development.IDE.GHC.Warnings -import Development.IDE.Types.Diagnostics -import Development.IDE.Types.Location -import Development.IDE.Types.Options -import GHC (ForeignHValue, - GetDocsFailure (..), - GhcException (..), - parsedSource) -import qualified GHC.LanguageExtensions as LangExt -import GHC.Serialized -import HieDb -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (DiagnosticTag (..)) -import qualified Language.LSP.Types as LSP -import System.Directory -import System.FilePath -import System.IO.Extra (fixIO, newTempFileWithin) -import Unsafe.Coerce - -#if MIN_VERSION_ghc(9,0,1) -import GHC.Tc.Gen.Splice - -#if MIN_VERSION_ghc(9,2,1) -import GHC.Types.ForeignStubs -import GHC.Types.HpcInfo -import GHC.Types.TypeEnv -#else -import GHC.Driver.Types -#endif - -#else -import HscTypes -import TcSplice -#endif - -#if MIN_VERSION_ghc(9,2,0) -import GHC (Anchor (anchor), - EpaComment (EpaComment), - EpaCommentTok (EpaBlockComment, EpaLineComment), - ModuleGraph, epAnnComments, - mgLookupModule, - mgModSummaries, - priorComments) -import qualified GHC as G -import GHC.Hs (LEpaComment) -import qualified GHC.Types.Error as Error -#endif - --- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. -parseModule - :: IdeOptions - -> HscEnv - -> FilePath - -> ModSummary - -> IO (IdeResult ParsedModule) -parseModule IdeOptions{..} env filename ms = - fmap (either (, Nothing) id) $ - runExceptT $ do - (diag, modu) <- parseFileContents env optPreprocessor filename ms - return (diag, Just modu) - - --- | Given a package identifier, what packages does it depend on -computePackageDeps - :: HscEnv - -> Unit - -> IO (Either [FileDiagnostic] [UnitId]) -computePackageDeps env pkg = do - case lookupUnit env pkg of - Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $ - T.pack $ "unknown package: " ++ show pkg] - Just pkgInfo -> return $ Right $ unitDepends pkgInfo - -newtype TypecheckHelpers - = TypecheckHelpers - { getLinkables :: ([NormalizedFilePath] -> IO [LinkableResult]) -- ^ hls-graph action to get linkables for files - } - -typecheckModule :: IdeDefer - -> HscEnv - -> TypecheckHelpers - -> ParsedModule - -> IO (IdeResult TcModuleResult) -typecheckModule (IdeDefer defer) hsc tc_helpers pm = do - let modSummary = pm_mod_summary pm - dflags = ms_hspp_opts modSummary - initialized <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)" - (initPlugins hsc modSummary) - case initialized of - Left errs -> return (errs, Nothing) - Right (modSummary', hsc) -> do - (warnings, etcm) <- withWarnings "typecheck" $ \tweak -> - let - session = tweak (hscSetFlags dflags hsc) - -- TODO: maybe settings ms_hspp_opts is unnecessary? - mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session} - in - catchSrcErrors (hsc_dflags hsc) "typecheck" $ do - tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''} - let errorPipeline = unDefer . hideDiag dflags . tagDiag - diags = map errorPipeline warnings - deferredError = any fst diags - case etcm of - Left errs -> return (map snd diags ++ errs, Nothing) - Right tcm -> return (map snd diags, Just $ tcm{tmrDeferredError = deferredError}) - where - demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id - --- | Install hooks to capture the splices as well as the runtime module dependencies -captureSplicesAndDeps :: TypecheckHelpers -> HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, ModuleEnv BS.ByteString) -captureSplicesAndDeps TypecheckHelpers{..} env k = do - splice_ref <- newIORef mempty - dep_ref <- newIORef emptyModuleEnv - res <- k (hscSetHooks (addSpliceHook splice_ref . addLinkableDepHook dep_ref $ hsc_hooks env) env) - splices <- readIORef splice_ref - needed_mods <- readIORef dep_ref - return (res, splices, needed_mods) - where - addLinkableDepHook :: IORef (ModuleEnv BS.ByteString) -> Hooks -> Hooks - addLinkableDepHook var h = h { hscCompileCoreExprHook = Just (compile_bco_hook var) } - - -- We want to record exactly which linkables/modules the typechecker needed at runtime - -- This is useful for recompilation checking. - -- See Note [Recompilation avoidance in the presence of TH] - -- - -- From hscCompileCoreExpr' in GHC - -- To update, copy hscCompileCoreExpr' (the implementation of - -- hscCompileCoreExprHook) verbatim, and add code to extract all the free - -- names in the compiled bytecode, recording the modules that those names - -- come from in the IORef,, as these are the modules on whose implementation - -- we depend. - compile_bco_hook :: IORef (ModuleEnv BS.ByteString) -> HscEnv -> SrcSpan -> CoreExpr -#if MIN_VERSION_ghc(9,3,0) - -> IO (ForeignHValue, [Linkable], PkgsLoaded) -#else - -> IO ForeignHValue -#endif - compile_bco_hook var hsc_env srcspan ds_expr - = do { let dflags = hsc_dflags hsc_env - - {- Simplify it -} - ; simpl_expr <- simplifyExpr dflags hsc_env ds_expr - - {- Tidy it (temporary, until coreSat does cloning) -} - ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr - - {- Prepare for codegen -} - ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr - - {- Lint if necessary -} - ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr - - -#if MIN_VERSION_ghc(9,2,0) - ; let iNTERACTIVELoc = G.ModLocation{ ml_hs_file = Nothing, - ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file", - ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file", -#if MIN_VERSION_ghc(9,3,0) - ml_dyn_obj_file = panic "hscCompileCoreExpr':ml_dyn_obj_file", - ml_dyn_hi_file = panic "hscCompileCoreExpr':ml_dyn_hi_file", -#endif - ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" - } - ; let ictxt = hsc_IC hsc_env - - ; (binding_id, stg_expr, _, _) <- - myCoreToStgExpr (hsc_logger hsc_env) - (hsc_dflags hsc_env) - ictxt -#if MIN_VERSION_ghc(9,3,0) - True -- for bytecode -#endif - (icInteractiveModule ictxt) - iNTERACTIVELoc - prepd_expr - - {- Convert to BCOs -} - ; bcos <- byteCodeGen hsc_env - (icInteractiveModule ictxt) - stg_expr - [] Nothing -#else - {- Convert to BCOs -} - ; bcos <- coreExprToBCOs hsc_env - (icInteractiveModule (hsc_IC hsc_env)) prepd_expr -#endif - - -- Exclude wired-in names because we may not have read - -- their interface files, so getLinkDeps will fail - -- All wired-in names are in the base package, which we link - -- by default, so we can safely ignore them here. - - -- Find the linkables for the modules we need - ; let needed_mods = mkUniqSet [ -#if MIN_VERSION_ghc(9,3,0) - mod -- We need the whole module for 9.4 because of multiple home units modules may have different unit ids -#else - moduleName mod -- On <= 9.2, just the name is enough because all unit ids will be the same -#endif - -#if MIN_VERSION_ghc(9,2,0) - | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos -#else - | n <- uniqDSetToList (bcoFreeNames bcos) -#endif - , Just mod <- [nameModule_maybe n] -- Names from other modules - , not (isWiredInName n) -- Exclude wired-in names - , moduleUnitId mod `elem` home_unit_ids -- Only care about stuff from the home package set - ] - home_unit_ids = -#if MIN_VERSION_ghc(9,3,0) - map fst (hugElts $ hsc_HUG hsc_env) -#else - [homeUnitId_ dflags] -#endif - mods_transitive = getTransitiveMods hsc_env needed_mods - - -- If we don't support multiple home units, ModuleNames are sufficient because all the units will be the same - mods_transitive_list = -#if MIN_VERSION_ghc(9,3,0) - mapMaybe nodeKeyToInstalledModule $ Set.toList mods_transitive -#else - -- Non det OK as we will put it into maps later anyway - map (Compat.installedModule (homeUnitId_ dflags)) $ nonDetEltsUniqSet mods_transitive -#endif - -#if MIN_VERSION_ghc(9,3,0) - ; moduleLocs <- readIORef (fcModuleCache $ hsc_FC hsc_env) -#else - ; moduleLocs <- readIORef (hsc_FC hsc_env) -#endif - ; lbs <- getLinkables [toNormalizedFilePath' file - | mod <- mods_transitive_list - , let ifr = fromJust $ lookupInstalledModuleEnv moduleLocs mod - file = case ifr of - InstalledFound loc _ -> - fromJust $ ml_hs_file loc - _ -> panic "hscCompileCoreExprHook: module not found" - ] - ; let hsc_env' = loadModulesHome (map linkableHomeMod lbs) hsc_env - -#if MIN_VERSION_ghc(9,3,0) - {- load it -} - ; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos - ; let hval = ((expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs), lbss, pkgs) -#elif MIN_VERSION_ghc(9,2,0) - {- load it -} - ; fv_hvs <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos - ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs) -#else - {- link it -} - ; hval <- linkExpr hsc_env' srcspan bcos -#endif - - ; modifyIORef' var (flip extendModuleEnvList [(mi_module $ hm_iface hm, linkableHash lb) | lb <- lbs, let hm = linkableHomeMod lb]) - ; return hval } - -#if MIN_VERSION_ghc(9,3,0) - -- TODO: support backpack - nodeKeyToInstalledModule :: NodeKey -> Maybe InstalledModule - nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB mod _) uid)) = Just $ mkModule uid mod - nodeKeyToInstalledModule _ = Nothing - moduleToNodeKey :: Module -> NodeKey - moduleToNodeKey mod = NodeKey_Module $ ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod) -#endif - - -- Compute the transitive set of linkables required - getTransitiveMods hsc_env needed_mods -#if MIN_VERSION_ghc(9,3,0) - = Set.unions (Set.fromList (map moduleToNodeKey mods) : [ dep | m <- mods - , Just dep <- [Map.lookup (moduleToNodeKey m) (mgTransDeps (hsc_mod_graph hsc_env))] - ]) - where mods = nonDetEltsUniqSet needed_mods -- OK because we put them into a set immediately after -#else - = go emptyUniqSet needed_mods - where - hpt = hsc_HPT hsc_env - go seen new - | isEmptyUniqSet new = seen - | otherwise = go seen' new' - where - seen' = seen `unionUniqSets` new - new' = new_deps `minusUniqSet` seen' - new_deps = unionManyUniqSets [ mkUniqSet $ getDependentMods $ hm_iface mod_info - | mod_info <- eltsUDFM $ udfmIntersectUFM hpt (getUniqSet new)] -#endif - - -- | Add a Hook to the DynFlags which captures and returns the - -- typechecked splices before they are run. This information - -- is used for hover. - addSpliceHook :: IORef Splices -> Hooks -> Hooks - addSpliceHook var h = h { runMetaHook = Just (splice_hook (runMetaHook h) var) } - - splice_hook :: Maybe (MetaHook TcM) -> IORef Splices -> MetaHook TcM - splice_hook (fromMaybe defaultRunMeta -> hook) var metaReq e = case metaReq of - (MetaE f) -> do - expr' <- metaRequestE hook e - liftIO $ modifyIORef' var $ exprSplicesL %~ ((e, expr') :) - pure $ f expr' - (MetaP f) -> do - pat' <- metaRequestP hook e - liftIO $ modifyIORef' var $ patSplicesL %~ ((e, pat') :) - pure $ f pat' - (MetaT f) -> do - type' <- metaRequestT hook e - liftIO $ modifyIORef' var $ typeSplicesL %~ ((e, type') :) - pure $ f type' - (MetaD f) -> do - decl' <- metaRequestD hook e - liftIO $ modifyIORef' var $ declSplicesL %~ ((e, decl') :) - pure $ f decl' - (MetaAW f) -> do - aw' <- metaRequestAW hook e - liftIO $ modifyIORef' var $ awSplicesL %~ ((e, aw') :) - pure $ f aw' - - -tcRnModule - :: HscEnv - -> TypecheckHelpers -- ^ Program linkables not to unload - -> ParsedModule - -> IO TcModuleResult -tcRnModule hsc_env tc_helpers pmod = do - let ms = pm_mod_summary pmod - hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env - - ((tc_gbl_env', mrn_info), splices, mod_env) - <- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hsc_env_tmp -> - do hscTypecheckRename hsc_env_tmp ms $ - HsParsedModule { hpm_module = parsedSource pmod, - hpm_src_files = pm_extra_src_files pmod, - hpm_annotations = pm_annotations pmod } - let rn_info = case mrn_info of - Just x -> x - Nothing -> error "no renamed info tcRnModule" - - -- Serialize mod_env so we can read it from the interface - mod_env_anns = map (\(mod, hash) -> Annotation (ModuleTarget mod) $ toSerialized BS.unpack hash) - (moduleEnvToList mod_env) - tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns } - pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env) - - --- Note [Clearing mi_globals after generating an iface] --- GHC populates the mi_global field in interfaces for GHCi if we are using the bytecode --- interpreter. --- However, this field is expensive in terms of heap usage, and we don't use it in HLS --- anywhere. So we zero it out. --- The field is not serialized or deserialised from disk, so we don't need to remove it --- while reading an iface from disk, only if we just generated an iface in memory --- - - - --- | See https://github.com/haskell/haskell-language-server/issues/3450 --- GHC's recompilation avoidance in the presense of TH is less precise than --- HLS. To avoid GHC from pessimising HLS, we filter out certain dependency information --- that we track ourselves. See also Note [Recompilation avoidance in the presence of TH] -filterUsages :: [Usage] -> [Usage] -#if MIN_VERSION_ghc(9,3,0) -filterUsages = filter $ \case UsageHomeModuleInterface{} -> False - _ -> True -#else -filterUsages = id -#endif - --- | Mitigation for https://gitlab.haskell.org/ghc/ghc/-/issues/22744 -shareUsages :: ModIface -> ModIface -shareUsages iface = iface {mi_usages = usages} - where usages = map go (mi_usages iface) - go usg@UsageFile{} = usg {usg_file_path = fp} - where !fp = shareFilePath (usg_file_path usg) - go usg = usg - - -mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult -mkHiFileResultNoCompile session tcm = do - let hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) session - ms = pm_mod_summary $ tmrParsed tcm - tcGblEnv = tmrTypechecked tcm - details <- makeSimpleDetails hsc_env_tmp tcGblEnv - sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv - iface' <- mkIfaceTc hsc_env_tmp sf details ms tcGblEnv - let iface = iface' { mi_globals = Nothing, mi_usages = filterUsages (mi_usages iface') } -- See Note [Clearing mi_globals after generating an iface] - pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing - -mkHiFileResultCompile - :: ShakeExtras - -> HscEnv - -> TcModuleResult - -> ModGuts - -> IO (IdeResult HiFileResult) -mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do - let session = hscSetFlags (ms_hspp_opts ms) session' - ms = pm_mod_summary $ tmrParsed tcm - tcGblEnv = tmrTypechecked tcm - - (details, mguts) <- - if mg_hsc_src simplified_guts == HsBootFile - then do - details <- mkBootModDetailsTc session tcGblEnv - pure (details, Nothing) - else do - -- write core file - -- give variables unique OccNames - tidy_opts <- initTidyOpts session - (guts, details) <- tidyProgram tidy_opts simplified_guts - pure (details, Just guts) - -#if MIN_VERSION_ghc(9,0,1) - let !partial_iface = force $ mkPartialIface session details -#if MIN_VERSION_ghc(9,3,0) - ms -#endif - simplified_guts - - final_iface' <- mkFullIface session partial_iface Nothing -#if MIN_VERSION_ghc(9,4,2) - Nothing -#endif - -#else - let !partial_iface = force (mkPartialIface session details simplified_guts) - final_iface' <- mkFullIface session partial_iface -#endif - let final_iface = final_iface' {mi_globals = Nothing, mi_usages = filterUsages (mi_usages final_iface')} -- See Note [Clearing mi_globals after generating an iface] - - -- Write the core file now - core_file <- case mguts of - Nothing -> pure Nothing -- no guts, likely boot file - Just guts -> do - let core_fp = ml_core_file $ ms_location ms - core_file = codeGutsToCoreFile iface_hash guts - iface_hash = getModuleHash final_iface - core_hash1 <- atomicFileWrite se core_fp $ \fp -> - writeBinCoreFile fp core_file - -- We want to drop references to guts and read in a serialized, compact version - -- of the core file from disk (as it is deserialised lazily) - -- This is because we don't want to keep the guts in memory for every file in - -- the project as it becomes prohibitively expensive - -- The serialized file however is much more compact and only requires a few - -- hundred megabytes of memory total even in a large project with 1000s of - -- modules - (core_file, !core_hash2) <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp - pure $ assert (core_hash1 == core_hash2) - $ Just (core_file, fingerprintToBS core_hash2) - - -- Verify core file by roundtrip testing and comparison - IdeOptions{optVerifyCoreFile} <- getIdeOptionsIO se - case core_file of - Just (core, _) | optVerifyCoreFile -> do - let core_fp = ml_core_file $ ms_location ms - traceIO $ "Verifying " ++ core_fp - let CgGuts{cg_binds = unprep_binds, cg_tycons = tycons } = case mguts of - Nothing -> error "invariant optVerifyCoreFile: guts must exist if linkable exists" - Just g -> g - mod = ms_mod ms - data_tycons = filter isDataTyCon tycons - CgGuts{cg_binds = unprep_binds'} <- coreFileToCgGuts session final_iface details core - - -- Run corePrep first as we want to test the final version of the program that will - -- get translated to STG/Bytecode -#if MIN_VERSION_ghc(9,3,0) - prepd_binds -#else - (prepd_binds , _) -#endif - <- corePrepPgm session mod (ms_location ms) unprep_binds data_tycons -#if MIN_VERSION_ghc(9,3,0) - prepd_binds' -#else - (prepd_binds', _) -#endif - <- corePrepPgm session mod (ms_location ms) unprep_binds' data_tycons - let binds = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds - binds' = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds' - - -- diffBinds is unreliable, sometimes it goes down the wrong track. - -- This fixes the order of the bindings so that it is less likely to do so. - diffs2 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go binds binds' - -- diffs1 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go (map (:[]) $ concat binds) (map (:[]) $ concat binds') - -- diffs3 = flip S.evalState (mkRnEnv2 emptyInScopeSet) $ go (concat binds) (concat binds') - - diffs = diffs2 - go x y = S.state $ \s -> diffBinds True s x y - - -- The roundtrip doesn't preserver OtherUnfolding or occInfo, but neither are of these - -- are used for generate core or bytecode, so we can safely ignore them - -- SYB is slow but fine given that this is only used for testing - noUnfoldings = everywhere $ mkT $ \v -> if isId v - then - let v' = if isOtherUnfolding (realIdUnfolding v) then (setIdUnfolding v noUnfolding) else v - in setIdOccInfo v' noOccInfo - else v - isOtherUnfolding (OtherCon _) = True - isOtherUnfolding _ = False - - - when (not $ null diffs) $ - panicDoc "verify core failed!" (vcat $ punctuate (text "\n\n") diffs) -- ++ [ppr binds , ppr binds'])) - _ -> pure () - - pure ([], Just $! mkHiFileResult ms final_iface details (tmrRuntimeModules tcm) core_file) - - where - dflags = hsc_dflags session' - source = "compile" - catchErrs x = x `catches` - [ Handler $ return . (,Nothing) . diagFromGhcException source dflags - , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "") - . (("Error during " ++ T.unpack source) ++) . show @SomeException - ] - --- | Whether we should run the -O0 simplifier when generating core. --- --- This is required for template Haskell to work but we disable this in DAML. --- See #256 -newtype RunSimplifier = RunSimplifier Bool - --- | Compile a single type-checked module to a 'CoreModule' value, or --- provide errors. -compileModule - :: RunSimplifier - -> HscEnv - -> ModSummary - -> TcGblEnv - -> IO (IdeResult ModGuts) -compileModule (RunSimplifier simplify) session ms tcg = - fmap (either (, Nothing) (second Just)) $ - catchSrcErrors (hsc_dflags session) "compile" $ do - (warnings,desugared_guts) <- withWarnings "compile" $ \tweak -> do - let session' = tweak (hscSetFlags (ms_hspp_opts ms) session) - -- TODO: maybe settings ms_hspp_opts is unnecessary? - -- MP: the flags in ModSummary should be right, if they are wrong then - -- the correct place to fix this is when the ModSummary is created. - desugar <- hscDesugar session' (ms { ms_hspp_opts = hsc_dflags session' }) tcg - if simplify - then do - plugins <- readIORef (tcg_th_coreplugins tcg) - hscSimplify session' plugins desugar - else pure desugar - return (map snd warnings, desugared_guts) - -generateObjectCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) -generateObjectCode session summary guts = do - fmap (either (, Nothing) (second Just)) $ - catchSrcErrors (hsc_dflags session) "object" $ do - let dot_o = ml_obj_file (ms_location summary) - mod = ms_mod summary - fp = replaceExtension dot_o "s" - createDirectoryIfMissing True (takeDirectory fp) - (warnings, dot_o_fp) <- - withWarnings "object" $ \tweak -> do - let env' = tweak (hscSetFlags (ms_hspp_opts summary) session) - target = platformDefaultBackend (hsc_dflags env') - newFlags = setBackend target $ updOptLevel 0 $ setOutputFile -#if MIN_VERSION_ghc(9,3,0) - (Just dot_o) -#else - dot_o -#endif - $ hsc_dflags env' - session' = hscSetFlags newFlags session -#if MIN_VERSION_ghc(9,4,2) - (outputFilename, _mStub, _foreign_files, _cinfos, _stgcinfos) <- hscGenHardCode session' guts -#elif MIN_VERSION_ghc(9,0,1) - (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts -#else - (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts -#endif - (ms_location summary) - fp - obj <- compileFile session' driverNoStop (outputFilename, Just (As False)) -#if MIN_VERSION_ghc(9,3,0) - case obj of - Nothing -> throwGhcExceptionIO $ Panic "compileFile didn't generate object code" - Just x -> pure x -#else - return obj -#endif - let unlinked = DotO dot_o_fp - -- Need time to be the modification time for recompilation checking - t <- liftIO $ getModificationTime dot_o_fp - let linkable = LM t mod [unlinked] - - pure (map snd warnings, linkable) - -newtype CoreFileTime = CoreFileTime UTCTime - -generateByteCode :: CoreFileTime -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) -generateByteCode (CoreFileTime time) hscEnv summary guts = do - fmap (either (, Nothing) (second Just)) $ - catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do - (warnings, (_, bytecode, sptEntries)) <- - withWarnings "bytecode" $ \_tweak -> do - let session = _tweak (hscSetFlags (ms_hspp_opts summary) hscEnv) - -- TODO: maybe settings ms_hspp_opts is unnecessary? - summary' = summary { ms_hspp_opts = hsc_dflags session } - hscInteractive session guts - (ms_location summary') - let unlinked = BCOs bytecode sptEntries - let linkable = LM time (ms_mod summary) [unlinked] - pure (map snd warnings, linkable) - -demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule -demoteTypeErrorsToWarnings = - (update_pm_mod_summary . update_hspp_opts) demoteTEsToWarns where - - demoteTEsToWarns :: DynFlags -> DynFlags - -- convert the errors into warnings, and also check the warnings are enabled - demoteTEsToWarns = (`wopt_set` Opt_WarnDeferredTypeErrors) - . (`wopt_set` Opt_WarnTypedHoles) - . (`wopt_set` Opt_WarnDeferredOutOfScopeVariables) - . (`gopt_set` Opt_DeferTypeErrors) - . (`gopt_set` Opt_DeferTypedHoles) - . (`gopt_set` Opt_DeferOutOfScopeVariables) - -update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary -update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms} - -update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule -update_pm_mod_summary up pm = - pm{pm_mod_summary = up $ pm_mod_summary pm} - -#if MIN_VERSION_ghc(9,3,0) -unDefer :: (Maybe DiagnosticReason, FileDiagnostic) -> (Bool, FileDiagnostic) -unDefer (Just (WarningWithFlag Opt_WarnDeferredTypeErrors) , fd) = (True, upgradeWarningToError fd) -unDefer (Just (WarningWithFlag Opt_WarnTypedHoles) , fd) = (True, upgradeWarningToError fd) -unDefer (Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables), fd) = (True, upgradeWarningToError fd) -#else -unDefer :: (WarnReason, FileDiagnostic) -> (Bool, FileDiagnostic) -unDefer (Reason Opt_WarnDeferredTypeErrors , fd) = (True, upgradeWarningToError fd) -unDefer (Reason Opt_WarnTypedHoles , fd) = (True, upgradeWarningToError fd) -unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarningToError fd) -#endif -unDefer ( _ , fd) = (False, fd) - -upgradeWarningToError :: FileDiagnostic -> FileDiagnostic -upgradeWarningToError (nfp, sh, fd) = - (nfp, sh, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where - warn2err :: T.Text -> T.Text - warn2err = T.intercalate ": error:" . T.splitOn ": warning:" - -#if MIN_VERSION_ghc(9,3,0) -hideDiag :: DynFlags -> (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic) -hideDiag originalFlags (w@(Just (WarningWithFlag warning)), (nfp, _sh, fd)) -#else -hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) -hideDiag originalFlags (w@(Reason warning), (nfp, _sh, fd)) -#endif - | not (wopt warning originalFlags) - = (w, (nfp, HideDiag, fd)) -hideDiag _originalFlags t = t - --- | Warnings which lead to a diagnostic tag -unnecessaryDeprecationWarningFlags :: [WarningFlag] -unnecessaryDeprecationWarningFlags - = [ Opt_WarnUnusedTopBinds - , Opt_WarnUnusedLocalBinds - , Opt_WarnUnusedPatternBinds - , Opt_WarnUnusedImports - , Opt_WarnUnusedMatches - , Opt_WarnUnusedTypePatterns - , Opt_WarnUnusedForalls - , Opt_WarnUnusedRecordWildcards - , Opt_WarnInaccessibleCode - , Opt_WarnWarningsDeprecations - ] - --- | Add a unnecessary/deprecated tag to the required diagnostics. -#if MIN_VERSION_ghc(9,3,0) -tagDiag :: (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic) -tagDiag (w@(Just (WarningWithFlag warning)), (nfp, sh, fd)) -#else -tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) -tagDiag (w@(Reason warning), (nfp, sh, fd)) -#endif - | Just tag <- requiresTag warning - = (w, (nfp, sh, fd { _tags = addTag tag (_tags fd) })) - where - requiresTag :: WarningFlag -> Maybe DiagnosticTag - requiresTag Opt_WarnWarningsDeprecations - = Just DtDeprecated - requiresTag wflag -- deprecation was already considered above - | wflag `elem` unnecessaryDeprecationWarningFlags - = Just DtUnnecessary - requiresTag _ = Nothing - addTag :: DiagnosticTag -> Maybe (List DiagnosticTag) -> Maybe (List DiagnosticTag) - addTag t Nothing = Just (List [t]) - addTag t (Just (List ts)) = Just (List (t : ts)) --- other diagnostics are left unaffected -tagDiag t = t - -addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags -addRelativeImport fp modu dflags = dflags - {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags} - --- | Also resets the interface store -atomicFileWrite :: ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a -atomicFileWrite se targetPath write = do - let dir = takeDirectory targetPath - createDirectoryIfMissing True dir - (tempFilePath, cleanUp) <- newTempFileWithin dir - (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x) - `onException` cleanUp - -generateHieAsts :: HscEnv -> TcModuleResult -> IO ([FileDiagnostic], Maybe (HieASTs Type)) -generateHieAsts hscEnv tcm = - handleGenerationErrors' dflags "extended interface generation" $ runHsc hscEnv $ do - -- These varBinds use unitDataConId but it could be anything as the id name is not used - -- during the hie file generation process. It's a workaround for the fact that the hie modules - -- don't export an interface which allows for additional information to be added to hie files. - let fake_splice_binds = Util.listToBag (map (mkVarBind unitDataConId) (spliceExpressions $ tmrTopLevelSplices tcm)) - real_binds = tcg_binds $ tmrTypechecked tcm -#if MIN_VERSION_ghc(9,0,1) - ts = tmrTypechecked tcm :: TcGblEnv - top_ev_binds = tcg_ev_binds ts :: Util.Bag EvBind - insts = tcg_insts ts :: [ClsInst] - tcs = tcg_tcs ts :: [TyCon] - run ts $ -#if MIN_VERSION_ghc(9,3,0) - pure $ Just $ -#else - Just <$> -#endif - GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs -#else - Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) -#endif - where - dflags = hsc_dflags hscEnv -#if MIN_VERSION_ghc(9,0,0) - run ts = -#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) - fmap (join . snd) . liftIO . initDs hscEnv ts -#else - id -#endif -#endif - -spliceExpressions :: Splices -> [LHsExpr GhcTc] -spliceExpressions Splices{..} = - DL.toList $ mconcat - [ DL.fromList $ map fst exprSplices - , DL.fromList $ map fst patSplices - , DL.fromList $ map fst typeSplices - , DL.fromList $ map fst declSplices - , DL.fromList $ map fst awSplices - ] - --- | In addition to indexing the `.hie` file, this function is responsible for --- maintaining the 'IndexQueue' state and notifying the user about indexing --- progress. --- --- We maintain a record of all pending index operations in the 'indexPending' --- TVar. --- When 'indexHieFile' is called, it must check to ensure that the file hasn't --- already be queued up for indexing. If it has, then we can just skip it --- --- Otherwise, we record the current file as pending and write an indexing --- operation to the queue --- --- When the indexing operation is picked up and executed by the worker thread, --- the first thing it does is ensure that a newer index for the same file hasn't --- been scheduled by looking at 'indexPending'. If a newer index has been --- scheduled, we can safely skip this one --- --- Otherwise, we start or continue a progress reporting session, telling it --- about progress so far and the current file we are attempting to index. Then --- we can go ahead and call in to hiedb to actually do the indexing operation --- --- Once this completes, we have to update the 'IndexQueue' state. First, we --- must remove the just indexed file from 'indexPending' Then we check if --- 'indexPending' is now empty. In that case, we end the progress session and --- report the total number of file indexed. We also set the 'indexCompleted' --- TVar to 0 in order to set it up for a fresh indexing session. Otherwise, we --- can just increment the 'indexCompleted' TVar and exit. --- -indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Util.Fingerprint -> Compat.HieFile -> IO () -indexHieFile se mod_summary srcPath !hash hf = do - IdeOptions{optProgressStyle} <- getIdeOptionsIO se - atomically $ do - pending <- readTVar indexPending - case HashMap.lookup srcPath pending of - Just pendingHash | pendingHash == hash -> pure () -- An index is already scheduled - _ -> do - -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around - let !hf' = hf{hie_hs_src = mempty} - modifyTVar' indexPending $ HashMap.insert srcPath hash - writeTQueue indexQueue $ \withHieDb -> do - -- We are now in the worker thread - -- Check if a newer index of this file has been scheduled, and if so skip this one - newerScheduled <- atomically $ do - pending <- readTVar indexPending - pure $ case HashMap.lookup srcPath pending of - Nothing -> False - -- If the hash in the pending list doesn't match the current hash, then skip - Just pendingHash -> pendingHash /= hash - unless newerScheduled $ do - pre optProgressStyle - withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf') - post - where - mod_location = ms_location mod_summary - targetPath = Compat.ml_hie_file mod_location - HieDbWriter{..} = hiedbWriter se - - -- Get a progress token to report progress and update it for the current file - pre style = do - tok <- modifyVar indexProgressToken $ fmap dupe . \case - x@(Just _) -> pure x - -- Create a token if we don't already have one - Nothing -> do - case lspEnv se of - Nothing -> pure Nothing - Just env -> LSP.runLspT env $ do - u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> liftIO Unique.newUnique - -- TODO: Wait for the progress create response to use the token - _ <- LSP.sendRequest LSP.SWindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ()) - LSP.sendNotification LSP.SProgress $ LSP.ProgressParams u $ - LSP.Begin $ LSP.WorkDoneProgressBeginParams - { _title = "Indexing" - , _cancellable = Nothing - , _message = Nothing - , _percentage = Nothing - } - pure (Just u) - - (!done, !remaining) <- atomically $ do - done <- readTVar indexCompleted - remaining <- HashMap.size <$> readTVar indexPending - pure (done, remaining) - let - progressFrac :: Double - progressFrac = fromIntegral done / fromIntegral (done + remaining) - progressPct :: LSP.UInt - progressPct = floor $ 100 * progressFrac - - whenJust (lspEnv se) $ \env -> whenJust tok $ \tok -> LSP.runLspT env $ - LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $ - LSP.Report $ - case style of - Percentage -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Nothing - , _percentage = Just progressPct - } - Explicit -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Just $ - T.pack " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..." - , _percentage = Nothing - } - NoProgress -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Nothing - , _percentage = Nothing - } - - -- Report the progress once we are done indexing this file - post = do - mdone <- atomically $ do - -- Remove current element from pending - pending <- stateTVar indexPending $ - dupe . HashMap.update (\pendingHash -> guard (pendingHash /= hash) $> pendingHash) srcPath - modifyTVar' indexCompleted (+1) - -- If we are done, report and reset completed - whenMaybe (HashMap.null pending) $ - swapTVar indexCompleted 0 - whenJust (lspEnv se) $ \env -> LSP.runLspT env $ - when (coerce $ ideTesting se) $ - LSP.sendNotification (LSP.SCustomMethod "ghcide/reference/ready") $ - toJSON $ fromNormalizedFilePath srcPath - whenJust mdone $ \done -> - modifyVar_ indexProgressToken $ \tok -> do - whenJust (lspEnv se) $ \env -> LSP.runLspT env $ - whenJust tok $ \tok -> - LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $ - LSP.End $ LSP.WorkDoneProgressEndParams - { _message = Just $ "Finished indexing " <> T.pack (show done) <> " files" - } - -- We are done with the current indexing cycle, so destroy the token - pure Nothing - -writeAndIndexHieFile :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic] -writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source = - handleGenerationErrors dflags "extended interface write/compression" $ do - hf <- runHsc hscEnv $ - GHC.mkHieFile' mod_summary exports ast source - atomicFileWrite se targetPath $ flip GHC.writeHieFile hf - hash <- Util.getFileHash targetPath - indexHieFile se mod_summary srcPath hash hf - where - dflags = hsc_dflags hscEnv - mod_location = ms_location mod_summary - targetPath = Compat.ml_hie_file mod_location - -writeHiFile :: ShakeExtras -> HscEnv -> HiFileResult -> IO [FileDiagnostic] -writeHiFile se hscEnv tc = - handleGenerationErrors dflags "interface write" $ do - atomicFileWrite se targetPath $ \fp -> - writeIfaceFile hscEnv fp modIface - where - modIface = hirModIface tc - targetPath = ml_hi_file $ ms_location $ hirModSummary tc - dflags = hsc_dflags hscEnv - -handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic] -handleGenerationErrors dflags source action = - action >> return [] `catches` - [ Handler $ return . diagFromGhcException source dflags - , Handler $ return . diagFromString source DsError (noSpan "") - . (("Error during " ++ T.unpack source) ++) . show @SomeException - ] - -handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a) -handleGenerationErrors' dflags source action = - fmap ([],) action `catches` - [ Handler $ return . (,Nothing) . diagFromGhcException source dflags - , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "") - . (("Error during " ++ T.unpack source) ++) . show @SomeException - ] - --- | Load modules, quickly. Input doesn't need to be desugared. --- A module must be loaded before dependent modules can be typechecked. --- This variant of loadModuleHome will *never* cause recompilation, it just --- modifies the session. --- The order modules are loaded is important when there are hs-boot files. --- In particular you should make sure to load the .hs version of a file after the --- .hs-boot version. -loadModulesHome - :: [HomeModInfo] - -> HscEnv - -> HscEnv -loadModulesHome mod_infos e = -#if MIN_VERSION_ghc(9,3,0) - hscUpdateHUG (\hug -> foldl' (flip addHomeModInfoToHug) hug mod_infos) (e { hsc_type_env_vars = emptyKnotVars }) -#else - let !new_modules = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos] - in e { hsc_HPT = new_modules - , hsc_type_env_var = Nothing - } - where - mod_name = moduleName . mi_module . hm_iface -#endif - --- Merge the HPTs, module graphs and FinderCaches --- See Note [GhcSessionDeps] in Development.IDE.Core.Rules --- Add the current ModSummary to the graph, along with the --- HomeModInfo's of all direct dependencies (by induction hypothesis all --- transitive dependencies will be contained in envs) -#if MIN_VERSION_ghc(9,3,0) -mergeEnvs :: HscEnv -> (ModSummary, [NodeKey]) -> [HomeModInfo] -> [HscEnv] -> IO HscEnv -mergeEnvs env (ms, deps) extraMods envs = do - let im = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms)) - ifr = InstalledFound (ms_location ms) im - curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr - -- Very important to force this as otherwise the hsc_mod_graph field is not - -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get - -- this new one, which in turn leads to the EPS referencing the HPT. - module_graph_nodes = - nubOrdOn mkNodeKey (ModuleNode deps ms : concatMap (mgModSummaries' . hsc_mod_graph) envs) - - newFinderCache <- concatFC curFinderCache (map hsc_FC envs) - liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $ - let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in - (hscUpdateHUG (const newHug) env){ - hsc_FC = newFinderCache, - hsc_mod_graph = mkModuleGraph module_graph_nodes - }) - - where - mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b - mergeHUE a b = a { homeUnitEnv_hpt = mergeUDFM (homeUnitEnv_hpt a) (homeUnitEnv_hpt b) } - mergeUDFM = plusUDFM_C combineModules - - combineModules a b - | HsSrcFile <- mi_hsc_src (hm_iface a) = a - | otherwise = b - concatFC :: FinderCacheState -> [FinderCache] -> IO FinderCache - concatFC cur xs = do - fcModules <- mapM (readIORef . fcModuleCache) xs - fcFiles <- mapM (readIORef . fcFileCache) xs - fcModules' <- newIORef $! foldl' (plusInstalledModuleEnv const) cur fcModules - fcFiles' <- newIORef $! Map.unions fcFiles - pure $ FinderCache fcModules' fcFiles' - -#else -mergeEnvs :: HscEnv -> ModSummary -> [HomeModInfo] -> [HscEnv] -> IO HscEnv -mergeEnvs env ms extraMods envs = do - prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs - let im = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms)) - ifr = InstalledFound (ms_location ms) im - -- Very important to force this as otherwise the hsc_mod_graph field is not - -- forced and ends up retaining a reference to all the old hsc_envs we have merged to get - -- this new one, which in turn leads to the EPS referencing the HPT. - module_graph_nodes = -#if MIN_VERSION_ghc(9,2,0) - -- We don't do any instantiation for backpack at this point of time, so it is OK to use - -- 'extendModSummaryNoDeps'. - -- This may have to change in the future. - map extendModSummaryNoDeps $ -#endif - nubOrdOn ms_mod (ms : concatMap (mgModSummaries . hsc_mod_graph) envs) - - newFinderCache <- newIORef $! Compat.extendInstalledModuleEnv prevFinderCache im ifr - liftRnf rwhnf module_graph_nodes `seq` (return $ loadModulesHome extraMods $ - env{ - hsc_HPT = foldMapBy mergeUDFM emptyUDFM hsc_HPT envs, - hsc_FC = newFinderCache, - hsc_mod_graph = mkModuleGraph module_graph_nodes - }) - - where - mergeUDFM = plusUDFM_C combineModules - combineModules a b - | HsSrcFile <- mi_hsc_src (hm_iface a) = a - | otherwise = b - -- required because 'FinderCache': - -- 1) doesn't have a 'Monoid' instance, - -- 2) is abstract and doesn't export constructors - -- To work around this, we coerce to the underlying type - -- To remove this, I plan to upstream the missing Monoid instance - concatFC :: [FinderCache] -> FinderCache - concatFC = unsafeCoerce (mconcat @(Map InstalledModule InstalledFindResult)) -#endif - -withBootSuffix :: HscSource -> ModLocation -> ModLocation -withBootSuffix HsBootFile = addBootSuffixLocnOut -withBootSuffix _ = id - --- | Given a buffer, env and filepath, produce a module summary by parsing only the imports. --- Runs preprocessors as needed. -getModSummaryFromImports - :: HscEnv - -> FilePath - -> UTCTime - -> Maybe Util.StringBuffer - -> ExceptT [FileDiagnostic] IO ModSummaryResult -getModSummaryFromImports env fp modTime contents = do - - (contents, opts, env, src_hash) <- preprocessor env fp contents - - let dflags = hsc_dflags env - - -- The warns will hopefully be reported when we actually parse the module - (_warns, L main_loc hsmod) <- parseHeader dflags fp contents - - -- Copied from `HeaderInfo.getImports`, but we also need to keep the parsed imports - let mb_mod = hsmodName hsmod - imps = hsmodImports hsmod - - mod = fmap unLoc mb_mod `Util.orElse` mAIN_NAME - - (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps - - -- GHC.Prim doesn't exist physically, so don't go looking for it. - (ordinary_imps, ghc_prim_imports) - = partition ((/= moduleName gHC_PRIM) . unLoc - . ideclName . unLoc) - ord_idecls - - implicit_prelude = xopt LangExt.ImplicitPrelude dflags - implicit_imports = mkPrelImports mod main_loc - implicit_prelude imps - - - convImport (L _ i) = ( -#if !MIN_VERSION_ghc (9,3,0) - fmap sl_fs -#endif - (ideclPkgQual i) - , reLoc $ ideclName i) - - msrImports = implicit_imports ++ imps - -#if MIN_VERSION_ghc (9,3,0) - rn_pkg_qual = renameRawPkgQual (hsc_unit_env env) - rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn)) - srcImports = rn_imps $ map convImport src_idecls - textualImports = rn_imps $ map convImport (implicit_imports ++ ordinary_imps) - ghc_prim_import = not (null ghc_prim_imports) -#else - srcImports = map convImport src_idecls - textualImports = map convImport (implicit_imports ++ ordinary_imps) -#endif - - - -- Force bits that might keep the string buffer and DynFlags alive unnecessarily - liftIO $ evaluate $ rnf srcImports - liftIO $ evaluate $ rnf textualImports - - - modLoc <- liftIO $ if mod == mAIN_NAME - -- specially in tests it's common to have lots of nameless modules - -- mkHomeModLocation will map them to the same hi/hie locations - then mkHomeModLocation dflags (pathToModuleName fp) fp - else mkHomeModLocation dflags mod fp - - let modl = mkHomeModule (hscHomeUnit env) mod - sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile - msrModSummary2 = - ModSummary - { ms_mod = modl - , ms_hie_date = Nothing -#if MIN_VERSION_ghc(9,3,0) - , ms_dyn_obj_date = Nothing - , ms_ghc_prim_import = ghc_prim_import - , ms_hs_hash = src_hash - -#else - , ms_hs_date = modTime -#endif - , ms_hsc_src = sourceType - -- The contents are used by the GetModSummary rule - , ms_hspp_buf = Just contents - , ms_hspp_file = fp - , ms_hspp_opts = dflags - , ms_iface_date = Nothing - , ms_location = withBootSuffix sourceType modLoc - , ms_obj_date = Nothing - , ms_parsed_mod = Nothing - , ms_srcimps = srcImports - , ms_textual_imps = textualImports - } - - msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary2 - (msrModSummary, msrHscEnv) <- liftIO $ initPlugins env msrModSummary2 - return ModSummaryResult{..} - where - -- Compute a fingerprint from the contents of `ModSummary`, - -- eliding the timestamps, the preprocessed source and other non relevant fields - computeFingerprint opts ModSummary{..} = do - fingerPrintImports <- fingerprintFromPut $ do - put $ Util.uniq $ moduleNameFS $ moduleName ms_mod - forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do - put $ Util.uniq $ moduleNameFS $ unLoc m -#if MIN_VERSION_ghc(9,3,0) - case mb_p of - G.NoPkgQual -> pure () - G.ThisPkg uid -> put $ getKey $ getUnique uid - G.OtherPkg uid -> put $ getKey $ getUnique uid -#else - whenJust mb_p $ put . Util.uniq -#endif - return $! Util.fingerprintFingerprints $ - [ Util.fingerprintString fp - , fingerPrintImports - ] ++ map Util.fingerprintString opts - - --- | Parse only the module header -parseHeader - :: Monad m - => DynFlags -- ^ flags to use - -> FilePath -- ^ the filename (for source locations) - -> Util.StringBuffer -- ^ Haskell module source text (full Unicode is supported) -#if MIN_VERSION_ghc(9,0,1) - -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule)) -#else - -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs)) -#endif -parseHeader dflags filename contents = do - let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1 - case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of - PFailedWithErrorMessages msgs -> - throwE $ diagFromErrMsgs "parser" dflags $ msgs dflags - POk pst rdr_module -> do - let (warns, errs) = renderMessages $ getPsMessages pst dflags - - -- Just because we got a `POk`, it doesn't mean there - -- weren't errors! To clarify, the GHC parser - -- distinguishes between fatal and non-fatal - -- errors. Non-fatal errors are the sort that don't - -- prevent parsing from continuing (that is, a parse - -- tree can still be produced despite the error so that - -- further errors/warnings can be collected). Fatal - -- errors are those from which a parse tree just can't - -- be produced. - unless (null errs) $ - throwE $ diagFromErrMsgs "parser" dflags errs - - let warnings = diagFromErrMsgs "parser" dflags warns - return (warnings, rdr_module) - --- | Given a buffer, flags, and file path, produce a --- parsed module (or errors) and any parse warnings. Does not run any preprocessors --- ModSummary must contain the (preprocessed) contents of the buffer -parseFileContents - :: HscEnv - -> (GHC.ParsedSource -> IdePreprocessedSource) - -> FilePath -- ^ the filename (for source locations) - -> ModSummary - -> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule) -parseFileContents env customPreprocessor filename ms = do - let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1 - dflags = ms_hspp_opts ms - contents = fromJust $ ms_hspp_buf ms - case unP Compat.parseModule (initParserState (initParserOpts dflags) contents loc) of - PFailedWithErrorMessages msgs -> throwE $ diagFromErrMsgs "parser" dflags $ msgs dflags - POk pst rdr_module -> - let - hpm_annotations = mkApiAnns pst - psMessages = getPsMessages pst dflags - in - do - let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module - - unless (null errs) $ - throwE $ diagFromStrings "parser" DsError errs - - let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns - (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed psMessages - let (warns, errs) = renderMessages msgs - - -- Just because we got a `POk`, it doesn't mean there - -- weren't errors! To clarify, the GHC parser - -- distinguishes between fatal and non-fatal - -- errors. Non-fatal errors are the sort that don't - -- prevent parsing from continuing (that is, a parse - -- tree can still be produced despite the error so that - -- further errors/warnings can be collected). Fatal - -- errors are those from which a parse tree just can't - -- be produced. - unless (null errs) $ - throwE $ diagFromErrMsgs "parser" dflags errs - - - -- To get the list of extra source files, we take the list - -- that the parser gave us, - -- - eliminate files beginning with '<'. gcc likes to use - -- pseudo-filenames like "" and "" - -- - normalise them (eliminate differences between ./f and f) - -- - filter out the preprocessed source file - -- - filter out anything beginning with tmpdir - -- - remove duplicates - -- - filter out the .hs/.lhs source filename if we have one - -- - let n_hspp = normalise filename -#if MIN_VERSION_ghc(9,3,0) - TempDir tmp_dir = tmpDir dflags -#else - tmp_dir = tmpDir dflags -#endif - srcs0 = nubOrd $ filter (not . (tmp_dir `isPrefixOf`)) - $ filter (/= n_hspp) - $ map normalise - $ filter (not . isPrefixOf "<") - $ map Util.unpackFS - $ srcfiles pst - srcs1 = case ml_hs_file (ms_location ms) of - Just f -> filter (/= normalise f) srcs0 - Nothing -> srcs0 - - -- sometimes we see source files from earlier - -- preprocessing stages that cannot be found, so just - -- filter them out: - srcs2 <- liftIO $ filterM doesFileExist srcs1 - - let pm = ParsedModule ms parsed' srcs2 hpm_annotations - warnings = diagFromErrMsgs "parser" dflags warns - pure (warnings ++ preproc_warnings, pm) - -loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile -loadHieFile ncu f = do - GHC.hie_file_result <$> GHC.readHieFile ncu f - - -{- Note [Recompilation avoidance in the presence of TH] - -Most versions of GHC we currently support don't have a working implementation of -code unloading for object code, and no version of GHC supports this on certain -platforms like Windows. This makes it completely infeasible for interactive use, -as symbols from previous compiles will shadow over all future compiles. - -This means that we need to use bytecode when generating code for Template -Haskell. Unfortunately, we can't serialize bytecode, so we will always need -to recompile when the IDE starts. However, we can put in place a much tighter -recompilation avoidance scheme for subsequent compiles: - -1. If the source file changes, then we always need to recompile - a. For files of interest, we will get explicit `textDocument/change` events - that will let us invalidate our build products - b. For files we read from disk, we can detect source file changes by - comparing the `mtime` of the source file with the build product (.hi/.o) file - on disk. -2. If GHC's recompilation avoidance scheme based on interface file hashes says - that we need to recompile, the we need to recompile. -3. If the file in question requires code generation then, we need to recompile - if we don't have the appropriate kind of build products. - a. If we already have the build products in memory, and the conditions 1 and - 2 above hold, then we don't need to recompile - b. If we are generating object code, then we can also search for it on - disk and ensure it is up to date. Notably, we did _not_ previously re-use - old bytecode from memory when `hls-graph`/`shake` decided to rebuild the - `HiFileResult` for some reason - -4. If the file in question used Template Haskell on the previous compile, then -we need to recompile if any `Linkable` in its transitive closure changed. This -sounds bad, but it is possible to make some improvements. In particular, we only -need to recompile if any of the `Linkable`s actually used during the previous -compile change. - -How can we tell if a `Linkable` was actually used while running some TH? - -GHC provides a `hscCompileCoreExprHook` which lets us intercept bytecode as -it is being compiled and linked. We can inspect the bytecode to see which -`Linkable` dependencies it requires, and record this for use in -recompilation checking. -We record all the home package modules of the free names that occur in the -bytecode. The `Linkable`s required are then the transitive closure of these -modules in the home-package environment. This is the same scheme as used by -GHC to find the correct things to link in before running bytecode. - -This works fine if we already have previous build products in memory, but -what if we are reading an interface from disk? Well, we can smuggle in the -necessary information (linkable `Module`s required as well as the time they -were generated) using `Annotation`s, which provide a somewhat general purpose -way to serialise arbitrary information along with interface files. - -Then when deciding whether to recompile, we need to check that the versions -(i.e. hashes) of the linkables used during a previous compile match whatever is -currently in the HPT. - -As we always generate Linkables from core files, we use the core file hash -as a (hopefully) deterministic measure of whether the Linkable has changed. -This is better than using the object file hash (if we have one) because object -file generation is not deterministic. --} - -data RecompilationInfo m - = RecompilationInfo - { source_version :: FileVersion - , old_value :: Maybe (HiFileResult, FileVersion) - , get_file_version :: NormalizedFilePath -> m (Maybe FileVersion) - , get_linkable_hashes :: [NormalizedFilePath] -> m [BS.ByteString] - , regenerate :: Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface - } - --- | Either a regular GHC linkable or a core file that --- can be later turned into a proper linkable -data IdeLinkable = GhcLinkable !Linkable | CoreLinkable !UTCTime !CoreFile - -instance NFData IdeLinkable where - rnf (GhcLinkable lb) = rnf lb - rnf (CoreLinkable time _) = rnf time - -ml_core_file :: ModLocation -> FilePath -ml_core_file ml = ml_hi_file ml <.> "core" - --- | Returns an up-to-date module interface, regenerating if needed. --- Assumes file exists. --- Requires the 'HscEnv' to be set up with dependencies --- See Note [Recompilation avoidance in the presence of TH] -loadInterface - :: (MonadIO m, MonadMask m) - => HscEnv - -> ModSummary - -> Maybe LinkableType - -> RecompilationInfo m - -> m ([FileDiagnostic], Maybe HiFileResult) -loadInterface session ms linkableNeeded RecompilationInfo{..} = do - let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session - mb_old_iface = hirModIface . fst <$> old_value - mb_old_version = snd <$> old_value - - core_file = ml_core_file (ms_location ms) - iface_file = ml_hi_file (ms_location ms) - - !mod = ms_mod ms - - mb_dest_version <- case mb_old_version of - Just ver -> pure $ Just ver - Nothing -> get_file_version (toNormalizedFilePath' iface_file) - - -- The source is modified if it is newer than the destination (iface file) - -- A more precise check for the core file is performed later - let sourceMod = case mb_dest_version of - Nothing -> SourceModified -- destination file doesn't exist, assume modified source - Just dest_version - | source_version <= dest_version -> SourceUnmodified - | otherwise -> SourceModified - - -- If mb_old_iface is nothing then checkOldIface will load it for us - -- given that the source is unmodified - (recomp_iface_reqd, mb_checked_iface) -#if MIN_VERSION_ghc(9,3,0) - <- liftIO $ checkOldIface sessionWithMsDynFlags ms mb_old_iface >>= \case - UpToDateItem x -> pure (UpToDate, Just x) - OutOfDateItem reason x -> pure (NeedsRecompile reason, x) -#else - <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod mb_old_iface -#endif - - let do_regenerate _reason = withTrace "regenerate interface" $ \setTag -> do - setTag "Module" $ moduleNameString $ moduleName mod - setTag "Reason" $ showReason _reason - liftIO $ traceMarkerIO $ "regenerate interface " ++ show (moduleNameString $ moduleName mod, showReason _reason) - regenerate linkableNeeded - - case (mb_checked_iface, recomp_iface_reqd) of - (Just iface', UpToDate) -> do - let iface = shareUsages iface' - details <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface - -- parse the runtime dependencies from the annotations - let runtime_deps - | not (mi_used_th iface) = emptyModuleEnv - | otherwise = parseRuntimeDeps (md_anns details) - -- Perform the fine grained recompilation check for TH - maybe_recomp <- checkLinkableDependencies get_linkable_hashes (hsc_mod_graph sessionWithMsDynFlags) runtime_deps - case maybe_recomp of - Just msg -> do_regenerate msg - Nothing - | isJust linkableNeeded -> handleErrs $ do - (core_file@CoreFile{cf_iface_hash}, core_hash) <- liftIO $ - readBinCoreFile (mkUpdater $ hsc_NC session) core_file - if cf_iface_hash == getModuleHash iface - then return ([], Just $ mkHiFileResult ms iface details runtime_deps (Just (core_file, fingerprintToBS core_hash))) - else do_regenerate (recompBecause "Core file out of date (doesn't match iface hash)") - | otherwise -> return ([], Just $ mkHiFileResult ms iface details runtime_deps Nothing) - where handleErrs = flip catches - [Handler $ \(e :: IOException) -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")") - ,Handler $ \(e :: GhcException) -> case e of - Signal _ -> throw e - Panic _ -> throw e - _ -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")") - ] - (_, _reason) -> do_regenerate _reason - --- | Find the runtime dependencies by looking at the annotations --- serialized in the iface --- The bytestrings are the hashes of the core files for modules we --- required to run the TH splices in the given module. --- See Note [Recompilation avoidance in the presence of TH] -parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv BS.ByteString -parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns - where - go (Annotation (ModuleTarget mod) payload) - | Just bs <- fromSerialized BS.pack payload - = Just (mod, bs) - go _ = Nothing - --- | checkLinkableDependencies compares the core files in the build graph to --- the runtime dependencies of the module, to check if any of them are out of date --- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH --- See Note [Recompilation avoidance in the presence of TH] -checkLinkableDependencies :: MonadIO m => ([NormalizedFilePath] -> m [BS.ByteString]) -> ModuleGraph -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired) -checkLinkableDependencies get_linkable_hashes graph runtime_deps = do - let hs_files = mapM go (moduleEnvToList runtime_deps) - go (mod, hash) = do - ms <- mgLookupModule graph mod - let hs = fromJust $ ml_hs_file $ ms_location ms - pure (toNormalizedFilePath' hs, hash) - case hs_files of - Nothing -> error "invalid module graph" - Just fs -> do - store_hashes <- get_linkable_hashes (map fst fs) - let out_of_date = [core_file | ((core_file, expected_hash), actual_hash) <- zip fs store_hashes, expected_hash /= actual_hash] - case out_of_date of - [] -> pure Nothing - _ -> pure $ Just $ recompBecause - $ "out of date runtime dependencies: " ++ intercalate ", " (map show out_of_date) - -recompBecause = -#if MIN_VERSION_ghc(9,3,0) - NeedsRecompile . -#endif - RecompBecause -#if MIN_VERSION_ghc(9,3,0) - . CustomReason -#endif - -#if MIN_VERSION_ghc(9,3,0) -data SourceModified = SourceModified | SourceUnmodified deriving (Eq, Ord, Show) -#endif - -showReason :: RecompileRequired -> String -showReason UpToDate = "UpToDate" -#if MIN_VERSION_ghc(9,3,0) -showReason (NeedsRecompile MustCompile) = "MustCompile" -showReason (NeedsRecompile s) = printWithoutUniques s -#else -showReason MustCompile = "MustCompile" -showReason (RecompBecause s) = s -#endif - -mkDetailsFromIface :: HscEnv -> ModIface -> IO ModDetails -mkDetailsFromIface session iface = do - fixIO $ \details -> do - let !hsc' = hscUpdateHPT (\hpt -> addToHpt hpt (moduleName $ mi_module iface) (HomeModInfo iface details Nothing)) session - initIfaceLoad hsc' (typecheckIface iface) - -coreFileToCgGuts :: HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts -coreFileToCgGuts session iface details core_file = do - let act hpt = addToHpt hpt (moduleName this_mod) - (HomeModInfo iface details Nothing) - this_mod = mi_module iface - types_var <- newIORef (md_types details) - let hsc_env' = hscUpdateHPT act (session { -#if MIN_VERSION_ghc(9,3,0) - hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)]) -#else - hsc_type_env_var = Just (this_mod, types_var) -#endif - }) - core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckCoreFile this_mod types_var core_file - -- Implicit binds aren't saved, so we need to regenerate them ourselves. - let implicit_binds = concatMap getImplicitBinds tyCons - tyCons = typeEnvTyCons (md_types details) -#if MIN_VERSION_ghc(9,3,0) - pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False) Nothing [] -#else - pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False) Nothing [] -#endif - -coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo) -coreFileToLinkable linkableType session ms iface details core_file t = do - cgi_guts <- coreFileToCgGuts session iface details core_file - (warns, lb) <- case linkableType of - BCOLinkable -> generateByteCode (CoreFileTime t) session ms cgi_guts - ObjectLinkable -> generateObjectCode session ms cgi_guts - pure (warns, HomeModInfo iface details . Just <$> lb) - --- | Non-interactive, batch version of 'InteractiveEval.getDocs'. --- The interactive paths create problems in ghc-lib builds ---- and leads to fun errors like "Cannot continue after interface file error". -getDocsBatch - :: HscEnv - -> [Name] -#if MIN_VERSION_ghc(9,3,0) - -> IO [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))] -#else - -> IO [Either String (Maybe HsDocString, IntMap HsDocString)] -#endif -getDocsBatch hsc_env _names = do - res <- initIfaceLoad hsc_env $ forM _names $ \name -> - case nameModule_maybe name of - Nothing -> return (Left $ NameHasNoModule name) - Just mod -> do - ModIface { -#if MIN_VERSION_ghc(9,3,0) - mi_docs = Just Docs{ docs_mod_hdr = mb_doc_hdr - , docs_decls = dmap - , docs_args = amap - } -#else - mi_doc_hdr = mb_doc_hdr - , mi_decl_docs = DeclDocMap dmap - , mi_arg_docs = ArgDocMap amap -#endif - } <- loadSysInterface (text "getModuleInterface") mod -#if MIN_VERSION_ghc(9,3,0) - if isNothing mb_doc_hdr && isNullUniqMap dmap && isNullUniqMap amap -#else - if isNothing mb_doc_hdr && Map.null dmap && null amap -#endif - then pure (Left (NoDocsInIface mod $ compiled name)) - else pure (Right ( -#if MIN_VERSION_ghc(9,3,0) - lookupUniqMap dmap name, -#else - Map.lookup name dmap , -#endif -#if !MIN_VERSION_ghc(9,2,0) - IntMap.fromAscList $ Map.toAscList $ -#endif -#if MIN_VERSION_ghc(9,3,0) - lookupWithDefaultUniqMap amap mempty name)) -#else - Map.findWithDefault mempty name amap)) -#endif - return $ map (first $ T.unpack . printOutputable) - $ res - where - compiled n = - -- TODO: Find a more direct indicator. - case nameSrcLoc n of - RealSrcLoc {} -> False - UnhelpfulLoc {} -> True - --- | Non-interactive, batch version of 'InteractiveEval.lookupNames'. --- The interactive paths create problems in ghc-lib builds ---- and leads to fun errors like "Cannot continue after interface file error". -lookupName :: HscEnv - -> Name - -> IO (Maybe TyThing) -lookupName _ name - | Nothing <- nameModule_maybe name = pure Nothing -lookupName hsc_env name = handle $ do -#if MIN_VERSION_ghc(9,2,0) - mb_thing <- liftIO $ lookupType hsc_env name -#else - eps <- liftIO $ readIORef (hsc_EPS hsc_env) - let mb_thing = lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name -#endif - case mb_thing of - x@(Just _) -> return x - Nothing - | x@(Just thing) <- wiredInNameTyThing_maybe name - -> do when (needWiredInHomeIface thing) - (initIfaceLoad hsc_env (loadWiredInHomeIface name)) - return x - | otherwise -> do - res <- initIfaceLoad hsc_env $ importDecl name - case res of - Util.Succeeded x -> return (Just x) - _ -> return Nothing - where - handle x = x `catch` \(_ :: IOEnvFailure) -> pure Nothing - -pathToModuleName :: FilePath -> ModuleName -pathToModuleName = mkModuleName . map rep - where - rep c | isPathSeparator c = '_' - rep ':' = '_' - rep c = c +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} + +-- | Based on https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/API. +-- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values. +module Development.IDE.Core.Compile + ( TcModuleResult(..) + , RunSimplifier(..) + , compileModule + , parseModule + , typecheckModule + , computePackageDeps + , addRelativeImport + , mkHiFileResultCompile + , mkHiFileResultNoCompile + , generateObjectCode + , generateByteCode + , generateHieAsts + , writeAndIndexHieFile + , indexHieFile + , writeHiFile + , getModSummaryFromImports + , loadHieFile + , loadInterface + , RecompilationInfo(..) + , loadModulesHome + , getDocsBatch + , lookupName + , mergeEnvs + , ml_core_file + , coreFileToLinkable + , TypecheckHelpers(..) + , sourceTypecheck + , sourceParser + , shareUsages + , setNonHomeFCHook + ) where + +import Control.Concurrent.STM.Stats hiding (orElse) +import Control.DeepSeq (NFData (..), + force, rnf) +import Control.Exception (evaluate) +import Control.Exception.Safe +import Control.Lens hiding (List, pre, + (<.>)) +import Control.Monad.Extra +import Control.Monad.IO.Class +import Control.Monad.Trans.Except +import qualified Control.Monad.Trans.State.Strict as S +import Data.Aeson (toJSON) +import Data.Bifunctor (first, second) +import Data.Binary +import qualified Data.ByteString as BS +import Data.Coerce +import qualified Data.DList as DL +import Data.Functor +import Data.Generics.Aliases +import Data.Generics.Schemes +import qualified Data.HashMap.Strict as HashMap +import Data.IntMap (IntMap) +import Data.IORef +import Data.List.Extra +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Proxy (Proxy (Proxy)) +import qualified Data.Text as T +import Data.Time (UTCTime (..)) +import Data.Tuple.Extra (dupe) +import Debug.Trace +import Development.IDE.Core.FileStore (resetInterfaceStore) +import Development.IDE.Core.Preprocessor +import Development.IDE.Core.ProgressReporting (progressUpdate) +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Shake +import Development.IDE.Core.WorkerThread (writeTaskQueue) +import Development.IDE.Core.Tracing (withTrace) +import qualified Development.IDE.GHC.Compat as Compat +import qualified Development.IDE.GHC.Compat as GHC +import Development.IDE.GHC.Compat.Driver (hscTypecheckRenameWithDiagnostics) +import qualified Development.IDE.GHC.Compat.Util as Util +import Development.IDE.GHC.CoreFile +import Development.IDE.GHC.Error +import Development.IDE.GHC.Orphans () +import Development.IDE.GHC.Util +import Development.IDE.GHC.Warnings +import Development.IDE.Import.DependencyInformation +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.Location +import Development.IDE.Types.Options +import GHC (ForeignHValue, + GetDocsFailure (..), + ModLocation (..), + parsedSource) +import qualified GHC.LanguageExtensions as LangExt +import GHC.Serialized +import HieDb hiding (withHieDb) +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types (DiagnosticTag (..)) +import qualified Language.LSP.Server as LSP +import Prelude hiding (mod) +import System.Directory +import System.FilePath +import System.IO.Extra (fixIO, + newTempFileWithin) + +import qualified Data.Set as Set +import qualified GHC as G +import GHC.Core.Lint.Interactive +import GHC.Driver.Config.CoreToStg.Prep +import GHC.Iface.Ext.Types (HieASTs) +import qualified GHC.Runtime.Loader as Loader +import GHC.Tc.Gen.Splice +import GHC.Types.Error +import GHC.Types.ForeignStubs +import GHC.Types.HpcInfo +import GHC.Types.TypeEnv + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if MIN_VERSION_ghc(9,7,0) +import Data.Foldable (toList) +import GHC.Unit.Module.Warnings +#else +import Development.IDE.Core.FileStore (shareFilePath) +#endif + +#if MIN_VERSION_ghc(9,10,0) +import Development.IDE.GHC.Compat hiding (assert, + loadInterface, + parseHeader, + parseModule, + tcRnModule, + writeHieFile) +#else +import Development.IDE.GHC.Compat hiding + (loadInterface, + parseHeader, + parseModule, + tcRnModule, + writeHieFile) +#endif + +#if MIN_VERSION_ghc(9,11,0) +import qualified Data.List.NonEmpty as NE +import Data.Time (getCurrentTime) +import GHC.Driver.Env (hsc_all_home_unit_ids) +import GHC.Iface.Ext.Types (NameEntityInfo) +#endif + +#if MIN_VERSION_ghc(9,13,0) +import GHC.Driver.Env (hscInsertHPT, setModuleGraph) +import GHC.Unit.Home.Graph (UnitEnvGraph(..), unitEnv_assocs) +import GHC.Unit.Home.PackageTable (hptInternalTableRef, hptInternalTableFromRef) +import GHC.Unit.Module.ModIface (IfaceTopEnv(..)) +import GHC.Types.Avail (emptyDetOrdAvails) +import GHC.Types.Basic (ImportLevel(..), convImportLevel) +#endif + +#if MIN_VERSION_ghc(9,12,0) +import Development.IDE.Import.FindImports +#endif + +--Simple constants to make sure the source is consistently named +sourceTypecheck :: T.Text +sourceTypecheck = "typecheck" +sourceParser :: T.Text +sourceParser = "parser" + +-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. +parseModule + :: IdeOptions + -> HscEnv + -> FilePath + -> ModSummary + -> IO (IdeResult ParsedModule) +parseModule IdeOptions{..} env filename ms = + fmap (either (, Nothing) id) $ + runExceptT $ do + (diag, modu) <- parseFileContents env optPreprocessor filename ms + return (diag, Just modu) + + +-- | Given a package identifier, what packages does it depend on +computePackageDeps + :: HscEnv + -> Unit + -> IO (Either [FileDiagnostic] [UnitId]) +computePackageDeps env pkg = do + case lookupUnit env pkg of + Nothing -> + return $ Left + [ ideErrorText + (toNormalizedFilePath' noFilePath) + (T.pack $ "unknown package: " ++ show pkg) + ] + Just pkgInfo -> return $ Right $ unitDepends pkgInfo + +data TypecheckHelpers + = TypecheckHelpers + { getLinkables :: [NormalizedFilePath] -> IO [LinkableResult] -- ^ hls-graph action to get linkables for files + , getModuleGraph :: IO DependencyInformation + } + +typecheckModule :: IdeDefer + -> HscEnv + -> TypecheckHelpers + -> ParsedModule + -> IO (IdeResult TcModuleResult) +typecheckModule (IdeDefer defer) hsc tc_helpers pm = do + let modSummary = pm_mod_summary pm + dflags = ms_hspp_opts modSummary + initialized <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)" + (Loader.initializePlugins (hscSetFlags (ms_hspp_opts modSummary) hsc)) + case initialized of + Left errs -> return (errs, Nothing) + Right hscEnv -> do + etcm <- + let + -- TODO: maybe setting ms_hspp_opts is unnecessary? + mod_summary' = modSummary { ms_hspp_opts = hsc_dflags hscEnv} + in + catchSrcErrors (hsc_dflags hscEnv) sourceTypecheck $ do + tcRnModule hscEnv tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary'} + case etcm of + Left errs -> return (errs, Nothing) + Right tcm -> + let addReason diag = + map (Just (diagnosticReason (errMsgDiagnostic diag)),) $ + diagFromErrMsg sourceTypecheck (hsc_dflags hscEnv) diag + errorPipeline = map (unDefer . hideDiag dflags . tagDiag) . addReason + diags = concatMap errorPipeline $ Compat.getMessages $ tmrWarnings tcm + deferredError = any fst diags + in + return (map snd diags, Just $ tcm{tmrDeferredError = deferredError}) + where + demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id + +-- | Install hooks to capture the splices as well as the runtime module dependencies +captureSplicesAndDeps :: TypecheckHelpers -> HscEnv -> (HscEnv -> IO a) -> IO (a, Splices, ModuleEnv BS.ByteString) +captureSplicesAndDeps TypecheckHelpers{..} env k = do + splice_ref <- newIORef mempty + dep_ref <- newIORef emptyModuleEnv + res <- k (hscSetHooks (addSpliceHook splice_ref . addLinkableDepHook dep_ref $ hsc_hooks env) env) + splices <- readIORef splice_ref + needed_mods <- readIORef dep_ref + return (res, splices, needed_mods) + where + addLinkableDepHook :: IORef (ModuleEnv BS.ByteString) -> Hooks -> Hooks + addLinkableDepHook var h = h { hscCompileCoreExprHook = Just (compile_bco_hook var) } + + -- We want to record exactly which linkables/modules the typechecker needed at runtime + -- This is useful for recompilation checking. + -- See Note [Recompilation avoidance in the presence of TH] + -- + -- From hscCompileCoreExpr' in GHC + -- To update, copy hscCompileCoreExpr' (the implementation of + -- hscCompileCoreExprHook) verbatim, and add code to extract all the free + -- names in the compiled bytecode, recording the modules that those names + -- come from in the IORef,, as these are the modules on whose implementation + -- we depend. + compile_bco_hook :: IORef (ModuleEnv BS.ByteString) -> HscEnv -> SrcSpan -> CoreExpr + -> IO (ForeignHValue, [Linkable], PkgsLoaded) + compile_bco_hook var hsc_env srcspan ds_expr + = do { let dflags = hsc_dflags hsc_env + + {- Simplify it -} + ; simpl_expr <- simplifyExpr dflags hsc_env ds_expr + + {- Tidy it (temporary, until coreSat does cloning) -} + ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr + + {- Prepare for codegen -} + ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr + + {- Lint if necessary -} + ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr + + + ; let iNTERACTIVELoc = G.ModLocation{ ml_hs_file = Nothing, + ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file", + ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file", + ml_dyn_obj_file = panic "hscCompileCoreExpr':ml_dyn_obj_file", + ml_dyn_hi_file = panic "hscCompileCoreExpr':ml_dyn_hi_file", + ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" + } + ; let ictxt = hsc_IC hsc_env + + ; (binding_id, stg_expr, _, _) <- + myCoreToStgExpr (hsc_logger hsc_env) + (hsc_dflags hsc_env) + ictxt + True -- for bytecode + (icInteractiveModule ictxt) + iNTERACTIVELoc + prepd_expr + + {- Convert to BCOs -} + ; bcos <- byteCodeGen hsc_env + (icInteractiveModule ictxt) + stg_expr + [] Nothing +#if MIN_VERSION_ghc(9,11,0) + [] -- spt_entries +#endif + + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. + + -- Find the linkables for the modules we need + ; let needed_mods = mkUniqSet [ + mod -- We need the whole module for 9.4 because of multiple home units modules may have different unit ids + + | n <- concatMap (uniqDSetToList . bcoFreeNames) $ bc_bcos bcos + , not (isWiredInName n) -- Exclude wired-in names + , Just mod <- [nameModule_maybe n] -- Names from other modules + , moduleUnitId mod `elem` home_unit_ids -- Only care about stuff from the home package set + ] + home_unit_ids = +#if MIN_VERSION_ghc(9,13,0) + map fst (unitEnv_assocs $ hsc_HUG hsc_env) +#else + map fst (hugElts $ hsc_HUG hsc_env) +#endif + mods_transitive = getTransitiveMods hsc_env needed_mods + + -- If we don't support multiple home units, ModuleNames are sufficient because all the units will be the same + mods_transitive_list = + mapMaybe nodeKeyToInstalledModule $ Set.toList mods_transitive + + ; moduleLocs <- getModuleGraph + ; lbs <- getLinkables [file + | installedMod <- mods_transitive_list + , let file = fromJust $ lookupModuleFile (installedMod { moduleUnit = RealUnit (Definite $ moduleUnit installedMod) }) moduleLocs + ] +#if MIN_VERSION_ghc(9,13,0) + ; hsc_env' <- loadModulesHome (map linkableHomeMod lbs) hsc_env +#else + ; let hsc_env' = loadModulesHome (map linkableHomeMod lbs) hsc_env +#endif + + {- load it -} +#if MIN_VERSION_ghc(9,11,0) + ; bco_time <- getCurrentTime + ; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan $ + Linkable bco_time (icInteractiveModule ictxt) $ NE.singleton $ BCOs bcos +#else + ; (fv_hvs, lbss, pkgs) <- loadDecls (hscInterp hsc_env') hsc_env' srcspan bcos +#endif +#if MIN_VERSION_ghc(9,13,0) + ; let hval = (expectJust $ lookup (idName binding_id) fv_hvs, lbss, pkgs) +#else + ; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs, lbss, pkgs) +#endif + + ; modifyIORef' var (flip extendModuleEnvList [(mi_module $ hm_iface hm, linkableHash lb) | lb <- lbs, let hm = linkableHomeMod lb]) + ; return hval } + + -- TODO: support backpack + nodeKeyToInstalledModule :: NodeKey -> Maybe InstalledModule + -- We shouldn't get boot files here, but to be safe, never map them to an installed module + -- because boot files don't have linkables we can load, and we will fail if we try to look + -- for them + nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = Nothing + nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB moduleName _) uid)) = Just $ mkModule uid moduleName + nodeKeyToInstalledModule _ = Nothing + moduleToNodeKey :: Module -> NodeKey + moduleToNodeKey mod = NodeKey_Module $ ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod) + + -- Compute the transitive set of linkables required + getTransitiveMods hsc_env needed_mods +#if MIN_VERSION_ghc(9,13,0) + = Set.unions (Set.fromList (map moduleToNodeKey mods) : [ Set.fromList $ map mkNodeKey dep + | m <- mods + , Just dep <- + [mgReachable (hsc_mod_graph hsc_env) (moduleToNodeKey m)] + ]) + where mods = nonDetEltsUniqSet needed_mods -- OK because we put them into a set immediately after +#else + = Set.unions (Set.fromList (map moduleToNodeKey mods) : [ dep | m <- mods + , Just dep <- [Map.lookup (moduleToNodeKey m) (mgTransDeps (hsc_mod_graph hsc_env))] + ]) + where mods = nonDetEltsUniqSet needed_mods -- OK because we put them into a set immediately after +#endif + + -- | Add a Hook to the DynFlags which captures and returns the + -- typechecked splices before they are run. This information + -- is used for hover. + addSpliceHook :: IORef Splices -> Hooks -> Hooks + addSpliceHook var h = h { runMetaHook = Just (splice_hook (runMetaHook h) var) } + + splice_hook :: Maybe (MetaHook TcM) -> IORef Splices -> MetaHook TcM + splice_hook (fromMaybe defaultRunMeta -> hook) var metaReq e = case metaReq of + (MetaE f) -> do + expr' <- metaRequestE hook e + liftIO $ modifyIORef' var $ exprSplicesL %~ ((e, expr') :) + pure $ f expr' + (MetaP f) -> do + pat' <- metaRequestP hook e + liftIO $ modifyIORef' var $ patSplicesL %~ ((e, pat') :) + pure $ f pat' + (MetaT f) -> do + type' <- metaRequestT hook e + liftIO $ modifyIORef' var $ typeSplicesL %~ ((e, type') :) + pure $ f type' + (MetaD f) -> do + decl' <- metaRequestD hook e + liftIO $ modifyIORef' var $ declSplicesL %~ ((e, decl') :) + pure $ f decl' + (MetaAW f) -> do + aw' <- metaRequestAW hook e + liftIO $ modifyIORef' var $ awSplicesL %~ ((e, aw') :) + pure $ f aw' + + +tcRnModule + :: HscEnv + -> TypecheckHelpers -- ^ Program linkables not to unload + -> ParsedModule + -> IO TcModuleResult +tcRnModule hsc_env tc_helpers pmod = do + let ms = pm_mod_summary pmod + hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env + + (((tc_gbl_env', mrn_info), warning_messages), splices, mod_env) + <- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hscEnvTmp -> + do hscTypecheckRenameWithDiagnostics hscEnvTmp ms $ + HsParsedModule { hpm_module = parsedSource pmod + , hpm_src_files = pm_extra_src_files pmod + } + let rn_info = case mrn_info of + Just x -> x + Nothing -> error "no renamed info tcRnModule" + + -- Serialize mod_env so we can read it from the interface + mod_env_anns = map (\(mod, hash) -> Annotation (ModuleTarget mod) $ toSerialized BS.unpack hash) + (moduleEnvToList mod_env) + tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns } + pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env warning_messages) + + +-- Note [Clearing mi_globals after generating an iface] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- GHC populates the mi_global field in interfaces for GHCi if we are using the bytecode +-- interpreter. +-- However, this field is expensive in terms of heap usage, and we don't use it in HLS +-- anywhere. So we zero it out. +-- The field is not serialized or deserialised from disk, so we don't need to remove it +-- while reading an iface from disk, only if we just generated an iface in memory +-- + + + +-- | See https://github.com/haskell/haskell-language-server/issues/3450 +-- GHC's recompilation avoidance in the presense of TH is less precise than +-- HLS. To avoid GHC from pessimising HLS, we filter out certain dependency information +-- that we track ourselves. See also Note [Recompilation avoidance in the presence of TH] +filterUsages :: [Usage] -> [Usage] +filterUsages = filter $ \case UsageHomeModuleInterface{} -> False + _ -> True + +-- | Mitigation for https://gitlab.haskell.org/ghc/ghc/-/issues/22744 +-- Important to do this immediately after reading the unit before +-- anything else has a chance to read `mi_usages` +shareUsages :: ModIface -> ModIface +shareUsages iface + = iface +-- Fixed upstream in GHC 9.8 +#if !MIN_VERSION_ghc(9,7,0) + {mi_usages = usages} + where usages = map go (mi_usages iface) + go usg@UsageFile{} = usg {usg_file_path = fp} + where !fp = shareFilePath (usg_file_path usg) + go usg = usg +#endif + + +mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult +mkHiFileResultNoCompile session tcm = do + let hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) session + ms = pm_mod_summary $ tmrParsed tcm + tcGblEnv = tmrTypechecked tcm + details <- makeSimpleDetails hsc_env_tmp tcGblEnv + sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv + iface' <- mkIfaceTc hsc_env_tmp sf details ms Nothing tcGblEnv + -- See Note [Clearing mi_globals after generating an iface] + let iface = iface' +#if MIN_VERSION_ghc(9,13,0) + & set_mi_top_env (IfaceTopEnv emptyDetOrdAvails []) +#elif MIN_VERSION_ghc(9,11,0) + & set_mi_top_env Nothing + & set_mi_usages (filterUsages (mi_usages iface')) +#else + { mi_globals = Nothing, mi_usages = filterUsages (mi_usages iface') } +#endif + pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing + +mkHiFileResultCompile + :: ShakeExtras + -> HscEnv + -> TcModuleResult + -> ModGuts + -> IO (IdeResult HiFileResult) +mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do + let session = hscSetFlags (ms_hspp_opts ms) session' + ms = pm_mod_summary $ tmrParsed tcm + + (details, guts) <- do + -- write core file + -- give variables unique OccNames + tidy_opts <- initTidyOpts session + (guts, details) <- tidyProgram tidy_opts simplified_guts + pure (details, guts) + +#if MIN_VERSION_ghc(9,13,0) + partial_iface <- mkPartialIface session + (cg_binds guts) + details + ms + (tcg_import_decls (tmrTypechecked tcm)) + simplified_guts +#else + let !partial_iface = force $ mkPartialIface session + (cg_binds guts) + details + ms +#if MIN_VERSION_ghc(9,11,0) + (tcg_import_decls (tmrTypechecked tcm)) +#endif + simplified_guts +#endif + + final_iface' <- mkFullIface session partial_iface Nothing + Nothing +#if MIN_VERSION_ghc(9,11,0) + NoStubs [] +#endif + -- See Note [Clearing mi_globals after generating an iface] + let final_iface = final_iface' +#if MIN_VERSION_ghc(9,13,0) + & set_mi_top_env (IfaceTopEnv emptyDetOrdAvails []) +#elif MIN_VERSION_ghc(9,11,0) + & set_mi_top_env Nothing + & set_mi_usages (filterUsages (mi_usages final_iface')) +#else + {mi_globals = Nothing, mi_usages = filterUsages (mi_usages final_iface')} +#endif + + -- Write the core file now + core_file <- do + let core_fp = ml_core_file $ ms_location ms + core_file = codeGutsToCoreFile iface_hash guts + iface_hash = getModuleHash final_iface + core_hash1 <- atomicFileWrite se core_fp $ \fp -> + writeBinCoreFile (hsc_dflags session) fp core_file + -- We want to drop references to guts and read in a serialized, compact version + -- of the core file from disk (as it is deserialised lazily) + -- This is because we don't want to keep the guts in memory for every file in + -- the project as it becomes prohibitively expensive + -- The serialized file however is much more compact and only requires a few + -- hundred megabytes of memory total even in a large project with 1000s of + -- modules + (coreFile, !core_hash2) <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp + pure $ assert (core_hash1 == core_hash2) + $ Just (coreFile, fingerprintToBS core_hash2) + + -- Verify core file by roundtrip testing and comparison + IdeOptions{optVerifyCoreFile} <- getIdeOptionsIO se + case core_file of + Just (core, _) | optVerifyCoreFile -> do + let core_fp = ml_core_file $ ms_location ms + traceIO $ "Verifying " ++ core_fp + let CgGuts{cg_binds = unprep_binds, cg_tycons = tycons } = guts + mod = ms_mod ms + data_tycons = filter isAlgTyCon tycons + CgGuts{cg_binds = unprep_binds'} <- coreFileToCgGuts session final_iface details core + cp_cfg <- initCorePrepConfig session +#if MIN_VERSION_ghc(9,13,0) + let corePrep = corePrepPgm + (hsc_logger session) cp_cfg (initCorePrepPgmConfig (hsc_dflags session) (interactiveInScope $ hsc_IC session)) + mod + + -- Run corePrep first as we want to test the final version of the program that will + -- get translated to STG/Bytecode + prepd_binds + <- corePrep unprep_binds +#else + let corePrep = corePrepPgm + (hsc_logger session) cp_cfg (initCorePrepPgmConfig (hsc_dflags session) (interactiveInScope $ hsc_IC session)) + mod (ms_location ms) + + -- Run corePrep first as we want to test the final version of the program that will + -- get translated to STG/Bytecode + prepd_binds + <- corePrep unprep_binds data_tycons +#endif +#if MIN_VERSION_ghc(9,13,0) + prepd_binds' + <- corePrep unprep_binds' +#else + prepd_binds' + <- corePrep unprep_binds' data_tycons +#endif + let binds = noUnfoldings $ (map flattenBinds . (:[])) prepd_binds + binds' = noUnfoldings $ (map flattenBinds . (:[])) prepd_binds' + + -- diffBinds is unreliable, sometimes it goes down the wrong track. + -- This fixes the order of the bindings so that it is less likely to do so. + diffs2 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go binds binds' + -- diffs1 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go (map (:[]) $ concat binds) (map (:[]) $ concat binds') + -- diffs3 = flip S.evalState (mkRnEnv2 emptyInScopeSet) $ go (concat binds) (concat binds') + + diffs = diffs2 + go x y = S.state $ \s -> diffBinds True s x y + + -- The roundtrip doesn't preserver OtherUnfolding or occInfo, but neither are of these + -- are used for generate core or bytecode, so we can safely ignore them + -- SYB is slow but fine given that this is only used for testing + noUnfoldings = everywhere $ mkT $ \v -> if isId v + then + let v' = if isOtherUnfolding (realIdUnfolding v) then setIdUnfolding v noUnfolding else v + in setIdOccInfo v' noOccInfo + else v + isOtherUnfolding (OtherCon _) = True + isOtherUnfolding _ = False + + + when (not $ null diffs) $ + panicDoc "verify core failed!" (vcat $ punctuate (text "\n\n") diffs) -- ++ [ppr binds , ppr binds'])) + _ -> pure () + + pure ([], Just $! mkHiFileResult ms final_iface details (tmrRuntimeModules tcm) core_file) + + where + dflags = hsc_dflags session' + source = "compile" + catchErrs x = x `catches` + [ Handler $ return . (,Nothing) . diagFromGhcException source dflags + , Handler $ \diag -> + return + ( diagFromString + source DiagnosticSeverity_Error (noSpan "") + ("Error during " ++ T.unpack source ++ show @SomeException diag) + Nothing + , Nothing + ) + ] + +-- | Whether we should run the -O0 simplifier when generating core. +-- +-- This is required for template Haskell to work but we disable this in DAML. +-- See #256 +newtype RunSimplifier = RunSimplifier Bool + +-- | Compile a single type-checked module to a 'CoreModule' value, or +-- provide errors. +compileModule + :: RunSimplifier + -> HscEnv + -> ModSummary + -> TcGblEnv + -> IO (IdeResult ModGuts) +compileModule (RunSimplifier simplify) session ms tcg = + fmap (either (, Nothing) (second Just)) $ + catchSrcErrors (hsc_dflags session) "compile" $ do + (warnings,desugared_guts) <- withWarnings "compile" $ \tweak -> do + -- Breakpoints don't survive roundtripping from disk + -- and this trips up the verify-core-files check + -- They may also lead to other problems. + -- We have to setBackend ghciBackend in 9.8 as otherwise + -- non-exported definitions are stripped out. + -- However, setting this means breakpoints are generated. + -- Solution: prevent breakpoing generation by unsetting + -- Opt_InsertBreakpoints + let session' = tweak $ flip hscSetFlags session +#if MIN_VERSION_ghc(9,7,0) + $ flip gopt_unset Opt_InsertBreakpoints + $ setBackend ghciBackend +#endif + $ ms_hspp_opts ms + -- TODO: maybe settings ms_hspp_opts is unnecessary? + -- MP: the flags in ModSummary should be right, if they are wrong then + -- the correct place to fix this is when the ModSummary is created. + desugar <- hscDesugar session' (ms { ms_hspp_opts = hsc_dflags session' }) tcg + if simplify + then do + plugins <- readIORef (tcg_th_coreplugins tcg) + hscSimplify session' plugins desugar + else pure desugar + return (map snd warnings, desugared_guts) + +generateObjectCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) +generateObjectCode session summary guts = do + fmap (either (, Nothing) (second Just)) $ + catchSrcErrors (hsc_dflags session) "object" $ do + let dot_o = ml_obj_file (ms_location summary) + mod = ms_mod summary + fp = replaceExtension dot_o "s" + createDirectoryIfMissing True (takeDirectory fp) + (warnings, dot_o_fp) <- + withWarnings "object" $ \tweak -> do + let env' = tweak (hscSetFlags (ms_hspp_opts summary) session) + target = platformDefaultBackend (hsc_dflags env') + newFlags = setBackend target $ updOptLevel 0 $ setOutputFile + (Just dot_o) + $ hsc_dflags env' + session' = hscSetFlags newFlags session + (outputFilename, _mStub, _foreign_files, _cinfos, _stgcinfos) <- hscGenHardCode session' guts + (ms_location summary) + fp + obj <- compileFile session' driverNoStop (outputFilename, Just (As False)) + case obj of + Nothing -> throwGhcExceptionIO $ Panic "compileFile didn't generate object code" + Just x -> pure x + -- Need time to be the modification time for recompilation checking + t <- liftIO $ getModificationTime dot_o_fp +#if MIN_VERSION_ghc(9,11,0) + let linkable = Linkable t mod (pure $ DotO dot_o_fp ModuleObject) +#else + let linkable = LM t mod [DotO dot_o_fp] +#endif + pure (map snd warnings, linkable) + +newtype CoreFileTime = CoreFileTime UTCTime + +generateByteCode :: CoreFileTime -> HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable) +generateByteCode (CoreFileTime time) hscEnv summary guts = do + fmap (either (, Nothing) (second Just)) $ + catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do + +#if MIN_VERSION_ghc(9,11,0) + (warnings, (_, bytecode)) <- + withWarnings "bytecode" $ \_tweak -> do + let session = _tweak (hscSetFlags (ms_hspp_opts summary) hscEnv) + -- TODO: maybe settings ms_hspp_opts is unnecessary? + summary' = summary { ms_hspp_opts = hsc_dflags session } + hscInteractive session (mkCgInteractiveGuts guts) + (ms_location summary') +#else + (warnings, (_, bytecode, sptEntries)) <- + withWarnings "bytecode" $ \_tweak -> do + let session = _tweak (hscSetFlags (ms_hspp_opts summary) hscEnv) + -- TODO: maybe settings ms_hspp_opts is unnecessary? + summary' = summary { ms_hspp_opts = hsc_dflags session } + hscInteractive session (mkCgInteractiveGuts guts) + (ms_location summary') +#endif + +#if MIN_VERSION_ghc(9,11,0) + let linkable = Linkable time (ms_mod summary) (pure $ BCOs bytecode) +#else + let linkable = LM time (ms_mod summary) [BCOs bytecode sptEntries] +#endif + + pure (map snd warnings, linkable) + +demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule +demoteTypeErrorsToWarnings = + (update_pm_mod_summary . update_hspp_opts) demoteTEsToWarns where + + demoteTEsToWarns :: DynFlags -> DynFlags + -- convert the errors into warnings, and also check the warnings are enabled + demoteTEsToWarns = (`wopt_set` Opt_WarnDeferredTypeErrors) + . (`wopt_set` Opt_WarnTypedHoles) + . (`wopt_set` Opt_WarnDeferredOutOfScopeVariables) + . (`gopt_set` Opt_DeferTypeErrors) + . (`gopt_set` Opt_DeferTypedHoles) + . (`gopt_set` Opt_DeferOutOfScopeVariables) + +update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary +update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms} + +update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule +update_pm_mod_summary up pm = + pm{pm_mod_summary = up $ pm_mod_summary pm} + +unDefer :: (Maybe DiagnosticReason, FileDiagnostic) -> (Bool, FileDiagnostic) +unDefer (Just (WarningWithFlag Opt_WarnDeferredTypeErrors) , fd) = (True, upgradeWarningToError fd) +unDefer (Just (WarningWithFlag Opt_WarnTypedHoles) , fd) = (True, upgradeWarningToError fd) +unDefer (Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables), fd) = (True, upgradeWarningToError fd) +unDefer ( _ , fd) = (False, fd) + +upgradeWarningToError :: FileDiagnostic -> FileDiagnostic +upgradeWarningToError = + fdLspDiagnosticL %~ \diag -> diag {_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message diag} + where + warn2err :: T.Text -> T.Text + warn2err = T.intercalate ": error:" . T.splitOn ": warning:" + +hideDiag :: DynFlags -> (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic) +hideDiag originalFlags (w@(Just (WarningWithFlag warning)), fd) + | not (wopt warning originalFlags) + = (w, fd { fdShouldShowDiagnostic = HideDiag }) +hideDiag _originalFlags t = t + +-- | Warnings which lead to a diagnostic tag +unnecessaryDeprecationWarningFlags :: [WarningFlag] +unnecessaryDeprecationWarningFlags + = [ Opt_WarnUnusedTopBinds + , Opt_WarnUnusedLocalBinds + , Opt_WarnUnusedPatternBinds + , Opt_WarnUnusedImports + , Opt_WarnUnusedMatches + , Opt_WarnUnusedTypePatterns + , Opt_WarnUnusedForalls + , Opt_WarnUnusedRecordWildcards + , Opt_WarnInaccessibleCode +#if !MIN_VERSION_ghc(9,7,0) + , Opt_WarnWarningsDeprecations +#endif + ] + +-- | Add a unnecessary/deprecated tag to the required diagnostics. +tagDiag :: (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic) + +#if MIN_VERSION_ghc(9,7,0) +tagDiag (w@(Just (WarningWithCategory cat)), fd) + | cat == defaultWarningCategory -- default warning category is for deprecations + = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags diag) }) +tagDiag (w@(Just (WarningWithFlags warnings)), fd) + | tags <- mapMaybe requiresTag (toList warnings) + = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tags ++ concat (_tags diag) }) +#else +tagDiag (w@(Just (WarningWithFlag warning)), fd) + | Just tag <- requiresTag warning + = (w, fd & fdLspDiagnosticL %~ \diag -> diag { _tags = Just $ tag : concat (_tags diag) }) +#endif + where + requiresTag :: WarningFlag -> Maybe DiagnosticTag +#if !MIN_VERSION_ghc(9,7,0) + -- doesn't exist on 9.8, we use WarningWithCategory instead + requiresTag Opt_WarnWarningsDeprecations + = Just DiagnosticTag_Deprecated +#endif + requiresTag wflag -- deprecation was already considered above + | wflag `elem` unnecessaryDeprecationWarningFlags + = Just DiagnosticTag_Unnecessary + requiresTag _ = Nothing +-- other diagnostics are left unaffected +tagDiag t = t + +addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags +addRelativeImport fp modu dflags = dflags + {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags} + +-- | Also resets the interface store +atomicFileWrite :: ShakeExtras -> FilePath -> (FilePath -> IO a) -> IO a +atomicFileWrite se targetPath write = do + let dir = takeDirectory targetPath + createDirectoryIfMissing True dir + (tempFilePath, cleanUp) <- newTempFileWithin dir + (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x) + `onException` cleanUp + +generateHieAsts :: HscEnv -> TcModuleResult +#if MIN_VERSION_ghc(9,11,0) + -> IO ([FileDiagnostic], Maybe (HieASTs Type, NameEntityInfo)) +#else + -> IO ([FileDiagnostic], Maybe (HieASTs Type)) +#endif +generateHieAsts hscEnv tcm = + handleGenerationErrors' dflags "extended interface generation" $ runHsc hscEnv $ do + -- These varBinds use unitDataConId but it could be anything as the id name is not used + -- during the hie file generation process. It's a workaround for the fact that the hie modules + -- don't export an interface which allows for additional information to be added to hie files. + let fake_splice_binds = +#if !MIN_VERSION_ghc(9,11,0) + Util.listToBag $ +#endif + map (mkVarBind unitDataConId) (spliceExpressions $ tmrTopLevelSplices tcm) + real_binds = tcg_binds $ tmrTypechecked tcm + all_binds = +#if MIN_VERSION_ghc(9,11,0) + fake_splice_binds ++ real_binds +#else + fake_splice_binds `Util.unionBags` real_binds +#endif + ts = tmrTypechecked tcm :: TcGblEnv + top_ev_binds = tcg_ev_binds ts :: Util.Bag EvBind + insts = tcg_insts ts :: [ClsInst] + tcs = tcg_tcs ts :: [TyCon] + hie_asts = GHC.enrichHie all_binds (tmrRenamed tcm) top_ev_binds insts tcs + + pure $ Just $ +#if MIN_VERSION_ghc(9,11,0) + hie_asts (tcg_type_env ts) +#else + hie_asts +#endif + where + dflags = hsc_dflags hscEnv + +spliceExpressions :: Splices -> [LHsExpr GhcTc] +spliceExpressions Splices{..} = + DL.toList $ mconcat + [ DL.fromList $ map fst exprSplices + , DL.fromList $ map fst patSplices + , DL.fromList $ map fst typeSplices + , DL.fromList $ map fst declSplices + , DL.fromList $ map fst awSplices + ] + +-- | In addition to indexing the `.hie` file, this function is responsible for +-- maintaining the 'IndexQueue' state and notifying the user about indexing +-- progress. +-- +-- We maintain a record of all pending index operations in the 'indexPending' +-- TVar. +-- When 'indexHieFile' is called, it must check to ensure that the file hasn't +-- already be queued up for indexing. If it has, then we can just skip it +-- +-- Otherwise, we record the current file as pending and write an indexing +-- operation to the queue +-- +-- When the indexing operation is picked up and executed by the worker thread, +-- the first thing it does is ensure that a newer index for the same file hasn't +-- been scheduled by looking at 'indexPending'. If a newer index has been +-- scheduled, we can safely skip this one +-- +-- Otherwise, we start or continue a progress reporting session, telling it +-- about progress so far and the current file we are attempting to index. Then +-- we can go ahead and call in to hiedb to actually do the indexing operation +-- +-- Once this completes, we have to update the 'IndexQueue' state. First, we +-- must remove the just indexed file from 'indexPending' Then we check if +-- 'indexPending' is now empty. In that case, we end the progress session and +-- report the total number of file indexed. We also set the 'indexCompleted' +-- TVar to 0 in order to set it up for a fresh indexing session. Otherwise, we +-- can just increment the 'indexCompleted' TVar and exit. +-- +indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Util.Fingerprint -> Compat.HieFile -> IO () +indexHieFile se mod_summary srcPath !hash hf = do + atomically $ do + pending <- readTVar indexPending + case HashMap.lookup srcPath pending of + Just pendingHash | pendingHash == hash -> pure () -- An index is already scheduled + _ -> do + -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around + let !hf' = hf{hie_hs_src = mempty} + modifyTVar' indexPending $ HashMap.insert srcPath hash + writeTaskQueue indexQueue $ \withHieDb -> do + -- We are now in the worker thread + -- Check if a newer index of this file has been scheduled, and if so skip this one + newerScheduled <- atomically $ do + pendingOps <- readTVar indexPending + pure $ case HashMap.lookup srcPath pendingOps of + Nothing -> False + -- If the hash in the pending list doesn't match the current hash, then skip + Just pendingHash -> pendingHash /= hash + unless newerScheduled $ do + -- Using bracket, so even if an exception happen during withHieDb call, + -- the `post` (which clean the progress indicator) will still be called. + bracket_ pre post $ + withHieDb (\db -> HieDb.addRefsFromLoaded db targetPath (HieDb.RealFile $ fromNormalizedFilePath srcPath) hash hf') + where + mod_location = ms_location mod_summary + targetPath = Compat.ml_hie_file mod_location + HieDbWriter{..} = hiedbWriter se + + pre = progressUpdate indexProgressReporting ProgressStarted + -- Report the progress once we are done indexing this file + post = do + mdone <- atomically $ do + -- Remove current element from pending + pending <- stateTVar indexPending $ + dupe . HashMap.update (\pendingHash -> guard (pendingHash /= hash) $> pendingHash) srcPath + modifyTVar' indexCompleted (+1) + -- If we are done, report and reset completed + whenMaybe (HashMap.null pending) $ + swapTVar indexCompleted 0 + whenJust (lspEnv se) $ \env -> LSP.runLspT env $ + when (coerce $ ideTesting se) $ + LSP.sendNotification (LSP.SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ + toJSON $ fromNormalizedFilePath srcPath + whenJust mdone $ \_ -> progressUpdate indexProgressReporting ProgressCompleted + +writeAndIndexHieFile + :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] +#if MIN_VERSION_ghc(9,11,0) + -> (HieASTs Type, NameEntityInfo) +#else + -> HieASTs Type +#endif + -> BS.ByteString -> IO [FileDiagnostic] +writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source = + handleGenerationErrors dflags "extended interface write/compression" $ do + hf <- runHsc hscEnv $ + GHC.mkHieFile' mod_summary exports ast source + atomicFileWrite se targetPath $ flip GHC.writeHieFile hf + hash <- Util.getFileHash targetPath + indexHieFile se mod_summary srcPath hash hf + where + dflags = hsc_dflags hscEnv + mod_location = ms_location mod_summary + targetPath = Compat.ml_hie_file mod_location + +writeHiFile :: ShakeExtras -> HscEnv -> HiFileResult -> IO [FileDiagnostic] +writeHiFile se hscEnv tc = + handleGenerationErrors dflags "interface write" $ do + atomicFileWrite se targetPath $ \fp -> + writeIfaceFile hscEnv fp modIface + where + modIface = hirModIface tc + targetPath = ml_hi_file $ ms_location $ hirModSummary tc + dflags = hsc_dflags hscEnv + +handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic] +handleGenerationErrors dflags source action = + action >> return [] `catches` + [ Handler $ return . diagFromGhcException source dflags + , Handler $ \(exception :: SomeException) -> return $ + diagFromString + source DiagnosticSeverity_Error (noSpan "") + ("Error during " ++ T.unpack source ++ show exception) + Nothing + ] + +handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a) +handleGenerationErrors' dflags source action = + fmap ([],) action `catches` + [ Handler $ return . (,Nothing) . diagFromGhcException source dflags + , Handler $ \(exception :: SomeException) -> + return + ( diagFromString + source DiagnosticSeverity_Error (noSpan "") + ("Error during " ++ T.unpack source ++ show exception) + Nothing + , Nothing + ) + ] + +-- Merge the HPTs, module graphs and FinderCaches +-- See Note [GhcSessionDeps] in Development.IDE.Core.Rules +-- Add the current ModSummary to the graph, along with the +-- HomeModInfo's of all direct dependencies (by induction hypothesis all +-- transitive dependencies will be contained in envs) +#if MIN_VERSION_ghc(9,11,0) +mergeEnvs :: HscEnv + -> ModuleGraph + -> DependencyInformation + -> ModSummary + -> [HomeModInfo] + -> [HscEnv] + -> IO HscEnv +mergeEnvs env mg dep_info ms extraMods envs = do +#if MIN_VERSION_ghc(9,13,0) + newHug <- sequence $ foldl' mergeHUG (pure <$> hsc_HUG env) (map (fmap pure . hsc_HUG) envs) + let hsc_env' = setModuleGraph mg $ (hscUpdateHUG (const newHug) env){ + hsc_FC = (hsc_FC env) + { addToFinderCache = \im val -> + if moduleUnit im `elem` hsc_all_home_unit_ids env + then pure () + else addToFinderCache (hsc_FC env) im val + , lookupFinderCache = \im -> + if moduleUnit im `elem` hsc_all_home_unit_ids env + then case lookupModuleFile (im { moduleUnit = RealUnit (Definite $ moduleUnit im) }) dep_info of + Nothing -> pure Nothing + Just fs -> let ml = fromJust $ do + id <- lookupPathToId (depPathIdMap dep_info) fs + artifactModLocation (idToModLocation (depPathIdMap dep_info) id) +#if MIN_VERSION_ghc(9,13,0) + in pure $ Just $ InstalledFound ml +#else + in pure $ Just $ InstalledFound ml im +#endif + else lookupFinderCache (hsc_FC env) im + } + } + loadModulesHome extraMods hsc_env' +#else + return $! loadModulesHome extraMods $ + let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in + (hscUpdateHUG (const newHug) env){ + hsc_mod_graph = mg, + hsc_FC = (hsc_FC env) + { addToFinderCache = \gwib@(GWIB im _) val -> + if moduleUnit im `elem` hsc_all_home_unit_ids env + then pure () + else addToFinderCache (hsc_FC env) gwib val + , lookupFinderCache = \gwib@(GWIB im _) -> + if moduleUnit im `elem` hsc_all_home_unit_ids env + then case lookupModuleFile (im { moduleUnit = RealUnit (Definite $ moduleUnit im) }) dep_info of + Nothing -> pure Nothing + Just fs -> let ml = fromJust $ do + id <- lookupPathToId (depPathIdMap dep_info) fs + artifactModLocation (idToModLocation (depPathIdMap dep_info) id) + in pure $ Just $ InstalledFound ml im + else lookupFinderCache (hsc_FC env) gwib + } + } +#endif + + where +#if MIN_VERSION_ghc(9,13,0) + mergeHUG :: UnitEnvGraph (IO HomeUnitEnv) -> UnitEnvGraph (IO HomeUnitEnv) -> UnitEnvGraph (IO HomeUnitEnv) + mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b + mergeHUE a b = do + a_v <- a + hpt_b <- readIORef . hptInternalTableRef . homeUnitEnv_hpt =<< b + hpt_a <- readIORef . hptInternalTableRef . homeUnitEnv_hpt $ a_v + result <- hptInternalTableFromRef =<< (newIORef $! mergeUDFM hpt_a hpt_b) + return $! a_v { homeUnitEnv_hpt = result } + mergeUDFM = plusUDFM_C combineModules + combineModules a b + | HsSrcFile <- mi_hsc_src (hm_iface a) = a + | otherwise = b +#else + mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b + mergeHUE a b = a { homeUnitEnv_hpt = mergeUDFM (homeUnitEnv_hpt a) (homeUnitEnv_hpt b) } + mergeUDFM = plusUDFM_C combineModules + + combineModules a b + | HsSrcFile <- mi_hsc_src (hm_iface a) = a + | otherwise = b +#endif + +#else +mergeEnvs :: HscEnv + -> ModuleGraph + -> DependencyInformation + -> ModSummary + -> [HomeModInfo] + -> [HscEnv] + -> IO HscEnv +mergeEnvs env mg _dep_info ms extraMods envs = do + let im = Compat.installedModule (toUnitId $ moduleUnit $ ms_mod ms) (moduleName (ms_mod ms)) + ifr = InstalledFound (ms_location ms) im + curFinderCache = Compat.extendInstalledModuleEnv Compat.emptyInstalledModuleEnv im ifr + newFinderCache <- concatFC curFinderCache (map hsc_FC envs) + return $! loadModulesHome extraMods $ + let newHug = foldl' mergeHUG (hsc_HUG env) (map hsc_HUG envs) in + (hscUpdateHUG (const newHug) env){ + hsc_FC = newFinderCache, + hsc_mod_graph = mg + } + + where + mergeHUG (UnitEnvGraph a) (UnitEnvGraph b) = UnitEnvGraph $ Map.unionWith mergeHUE a b + mergeHUE a b = a { homeUnitEnv_hpt = mergeUDFM (homeUnitEnv_hpt a) (homeUnitEnv_hpt b) } + mergeUDFM = plusUDFM_C combineModules + + combineModules a b + | HsSrcFile <- mi_hsc_src (hm_iface a) = a + | otherwise = b + + -- Prefer non-boot files over non-boot files + -- otherwise we can get errors like https://gitlab.haskell.org/ghc/ghc/-/issues/19816 + -- if a boot file shadows over a non-boot file + combineModuleLocations a@(InstalledFound ml _) _ | Just fp <- ml_hs_file ml, not ("boot" `isSuffixOf` fp) = a + combineModuleLocations _ b = b + + concatFC :: FinderCacheState -> [FinderCache] -> IO FinderCache + concatFC cur xs = do + fcModules <- mapM (readIORef . fcModuleCache) xs + fcFiles <- mapM (readIORef . fcFileCache) xs + fcModules' <- newIORef $! foldl' (plusInstalledModuleEnv combineModuleLocations) cur fcModules + fcFiles' <- newIORef $! Map.unions fcFiles + pure $ FinderCache fcModules' fcFiles' +#endif + + +withBootSuffix :: HscSource -> ModLocation -> ModLocation +withBootSuffix HsBootFile = addBootSuffixLocnOut +withBootSuffix _ = id + +-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports. +-- Runs preprocessors as needed. +getModSummaryFromImports + :: HscEnv + -> FilePath + -> Maybe Util.StringBuffer + -> ExceptT [FileDiagnostic] IO ModSummaryResult +getModSummaryFromImports env fp mContents = do + (contents, opts, ppEnv, src_hash) <- preprocessor env fp mContents + + let dflags = hsc_dflags ppEnv + + -- The warns will hopefully be reported when we actually parse the module + (_warns, L main_loc hsmod) <- parseHeader dflags fp contents + + -- Copied from `HeaderInfo.getImports`, but we also need to keep the parsed imports + let mb_mod = hsmodName hsmod + imps = hsmodImports hsmod + + mod = fmap unLoc mb_mod `Util.orElse` mAIN_NAME + + (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps + + -- GHC.Prim doesn't exist physically, so don't go looking for it. + (ordinary_imps, ghc_prim_imports) + = partition ((/= moduleName gHC_PRIM) . unLoc + . ideclName . unLoc) + ord_idecls + + implicit_prelude = xopt LangExt.ImplicitPrelude dflags + implicit_imports = mkPrelImports mod main_loc + implicit_prelude imps + + + convImport (L _ i) = ( + (ideclPkgQual i) + , reLoc $ ideclName i) + + msrImports = implicit_imports ++ imps + + rn_pkg_qual = renameRawPkgQual (hsc_unit_env ppEnv) + rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn)) +#if MIN_VERSION_ghc(9,13,0) + -- In GHC 9.13+, ms_srcimps is just [Located ModuleName] and ms_textual_imps includes ImportLevel + srcImports = map snd $ rn_imps $ map convImport src_idecls + + -- Extract import level along with pkg qualifier and module name + convImportWithLevel (L _ i) = (convImportLevel (ideclLevelSpec i) + , ideclPkgQual i + , reLoc $ ideclName i) + + -- Rename package qualifiers while preserving import levels + rn_imps_with_level = fmap (\(lvl, pk, lmn@(L _ mn)) -> (lvl, rn_pkg_qual mn pk, lmn)) + + -- Implicit imports (prelude) are always NormalLevel; + -- explicit user imports preserve their declared level + textualImports = map (\(pk, lmn) -> (NormalLevel, pk, lmn)) (rn_imps $ map convImport implicit_imports) + ++ rn_imps_with_level (map convImportWithLevel ordinary_imps) +#else + srcImports = rn_imps $ map convImport src_idecls + textualImports = rn_imps $ map convImport (implicit_imports ++ ordinary_imps) +#endif + ghc_prim_import = not (null ghc_prim_imports) + + + -- Force bits that might keep the string buffer and DynFlags alive unnecessarily + liftIO $ evaluate $ rnf srcImports + liftIO $ evaluate $ rnf textualImports + + + modLoc <- liftIO $ if mod == mAIN_NAME + -- specially in tests it's common to have lots of nameless modules + -- mkHomeModLocation will map them to the same hi/hie locations + then mkHomeModLocation dflags (pathToModuleName fp) fp + else mkHomeModLocation dflags mod fp + + let modl = mkHomeModule (hscHomeUnit ppEnv) mod + sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile + msrModSummary = + ModSummary + { ms_mod = modl + , ms_hie_date = Nothing + , ms_dyn_obj_date = Nothing +#if !MIN_VERSION_ghc(9,13,0) + , ms_ghc_prim_import = ghc_prim_import +#endif + , ms_hs_hash = src_hash + + , ms_hsc_src = sourceType + -- The contents are used by the GetModSummary rule + , ms_hspp_buf = Just contents + , ms_hspp_file = fp + , ms_hspp_opts = dflags + , ms_iface_date = Nothing + , ms_location = withBootSuffix sourceType modLoc + , ms_obj_date = Nothing + , ms_parsed_mod = Nothing + , ms_srcimps = srcImports + , ms_textual_imps = textualImports + } + + msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary + msrHscEnv <- liftIO $ Loader.initializePlugins (hscSetFlags (ms_hspp_opts msrModSummary) ppEnv) + return ModSummaryResult{..} + where + -- Compute a fingerprint from the contents of `ModSummary`, + -- eliding the timestamps, the preprocessed source and other non relevant fields + computeFingerprint opts ModSummary{..} = do + fingerPrintImports <- fingerprintFromPut $ do + put $ Util.uniq $ moduleNameFS $ moduleName ms_mod +#if MIN_VERSION_ghc(9,13,0) + -- In GHC 9.13+, ms_srcimps is [Located ModuleName] and ms_textual_imps is [(ImportLevel, PkgQual, Located ModuleName)] + forM_ ms_srcimps $ \m -> do + put $ Util.uniq $ moduleNameFS $ unLoc m + forM_ ms_textual_imps $ \(_lvl, mb_p, m) -> do + put $ Util.uniq $ moduleNameFS $ unLoc m + case mb_p of + G.NoPkgQual -> pure () + G.ThisPkg uid -> put $ getKey $ getUnique uid + G.OtherPkg uid -> put $ getKey $ getUnique uid +#else + forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do + put $ Util.uniq $ moduleNameFS $ unLoc m + case mb_p of + G.NoPkgQual -> pure () + G.ThisPkg uid -> put $ getKey $ getUnique uid + G.OtherPkg uid -> put $ getKey $ getUnique uid +#endif + return $! Util.fingerprintFingerprints $ + [ Util.fingerprintString fp + , fingerPrintImports + , modLocationFingerprint ms_location + ] ++ map Util.fingerprintString opts + + modLocationFingerprint :: ModLocation -> Util.Fingerprint + modLocationFingerprint ModLocation{..} = Util.fingerprintFingerprints $ + Util.fingerprintString <$> [ fromMaybe "" ml_hs_file + , ml_hi_file + , ml_dyn_hi_file + , ml_obj_file + , ml_dyn_obj_file + , ml_hie_file] + +-- | Parse only the module header +parseHeader + :: Monad m + => DynFlags -- ^ flags to use + -> FilePath -- ^ the filename (for source locations) + -> Util.StringBuffer -- ^ Haskell module source text (full Unicode is supported) + -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located (HsModule GhcPs)) +parseHeader dflags filename contents = do + let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1 + case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of + PFailedWithErrorMessages msgs -> + throwE $ diagFromGhcErrorMessages sourceParser dflags $ msgs dflags + POk pst rdr_module -> do + let (warns, errs) = renderMessages $ getPsMessages pst + + -- Just because we got a `POk`, it doesn't mean there + -- weren't errors! To clarify, the GHC parser + -- distinguishes between fatal and non-fatal + -- errors. Non-fatal errors are the sort that don't + -- prevent parsing from continuing (that is, a parse + -- tree can still be produced despite the error so that + -- further errors/warnings can be collected). Fatal + -- errors are those from which a parse tree just can't + -- be produced. + unless (null errs) $ + throwE $ diagFromGhcErrorMessages sourceParser dflags errs + + let warnings = diagFromGhcErrorMessages sourceParser dflags warns + return (warnings, rdr_module) + +-- | Given a buffer, flags, and file path, produce a +-- parsed module (or errors) and any parse warnings. Does not run any preprocessors +-- ModSummary must contain the (preprocessed) contents of the buffer +parseFileContents + :: HscEnv + -> (GHC.ParsedSource -> IdePreprocessedSource) + -> FilePath -- ^ the filename (for source locations) + -> ModSummary + -> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule) +parseFileContents env customPreprocessor filename ms = do + let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1 + dflags = ms_hspp_opts ms + contents = fromJust $ ms_hspp_buf ms + case unP Compat.parseModule (initParserState (initParserOpts dflags) contents loc) of + PFailedWithErrorMessages msgs -> + throwE $ diagFromGhcErrorMessages sourceParser dflags $ msgs dflags + POk pst rdr_module -> + let + psMessages = getPsMessages pst + in + do + let IdePreprocessedSource preproc_warns preproc_errs parsed = customPreprocessor rdr_module + let attachNoStructuredError (span, msg) = (span, msg, Nothing) + + unless (null preproc_errs) $ + throwE $ + diagFromStrings + sourceParser + DiagnosticSeverity_Error + (fmap attachNoStructuredError preproc_errs) + + let preproc_warning_file_diagnostics = + diagFromStrings + sourceParser + DiagnosticSeverity_Warning + (fmap attachNoStructuredError preproc_warns) + (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env ms parsed psMessages + let (warns, errors) = renderMessages msgs + + -- Just because we got a `POk`, it doesn't mean there + -- weren't errors! To clarify, the GHC parser + -- distinguishes between fatal and non-fatal + -- errors. Non-fatal errors are the sort that don't + -- prevent parsing from continuing (that is, a parse + -- tree can still be produced despite the error so that + -- further errors/warnings can be collected). Fatal + -- errors are those from which a parse tree just can't + -- be produced. + unless (null errors) $ + throwE $ diagFromGhcErrorMessages sourceParser dflags errors + + -- To get the list of extra source files, we take the list + -- that the parser gave us, + -- - eliminate files beginning with '<'. gcc likes to use + -- pseudo-filenames like "" and "" + -- - normalise them (eliminate differences between ./f and f) + -- - filter out the preprocessed source file + -- - filter out anything beginning with tmpdir + -- - remove duplicates + -- - filter out the .hs/.lhs source filename if we have one + -- + let n_hspp = normalise filename + TempDir tmp_dir = tmpDir dflags + srcs0 = nubOrd $ filter (not . (tmp_dir `isPrefixOf`)) + $ filter (/= n_hspp) + $ map normalise + $ filter (not . isPrefixOf "<") + $ map Util.unpackFS + $ srcfiles pst + srcs1 = case ml_hs_file (ms_location ms) of + Just f -> filter (/= normalise f) srcs0 + Nothing -> srcs0 + + -- sometimes we see source files from earlier + -- preprocessing stages that cannot be found, so just + -- filter them out: + srcs2 <- liftIO $ filterM doesFileExist srcs1 + + let pm = ParsedModule ms parsed' srcs2 + warnings = diagFromGhcErrorMessages sourceParser dflags warns + pure (warnings ++ preproc_warning_file_diagnostics, pm) + +loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile +loadHieFile ncu f = do + GHC.hie_file_result <$> GHC.readHieFile ncu f + + +{- Note [Recompilation avoidance in the presence of TH] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most versions of GHC we currently support don't have a working implementation of +code unloading for object code, and no version of GHC supports this on certain +platforms like Windows. This makes it completely infeasible for interactive use, +as symbols from previous compiles will shadow over all future compiles. + +This means that we need to use bytecode when generating code for Template +Haskell. Unfortunately, we can't serialize bytecode, so we will always need +to recompile when the IDE starts. However, we can put in place a much tighter +recompilation avoidance scheme for subsequent compiles: + +1. If the source file changes, then we always need to recompile + a. For files of interest, we will get explicit `textDocument/change` events + that will let us invalidate our build products + b. For files we read from disk, we can detect source file changes by + comparing the `mtime` of the source file with the build product (.hi/.o) file + on disk. +2. If GHC's recompilation avoidance scheme based on interface file hashes says + that we need to recompile, the we need to recompile. +3. If the file in question requires code generation then, we need to recompile + if we don't have the appropriate kind of build products. + a. If we already have the build products in memory, and the conditions 1 and + 2 above hold, then we don't need to recompile + b. If we are generating object code, then we can also search for it on + disk and ensure it is up to date. Notably, we did _not_ previously re-use + old bytecode from memory when `hls-graph`/`shake` decided to rebuild the + `HiFileResult` for some reason + +4. If the file in question used Template Haskell on the previous compile, then +we need to recompile if any `Linkable` in its transitive closure changed. This +sounds bad, but it is possible to make some improvements. In particular, we only +need to recompile if any of the `Linkable`s actually used during the previous +compile change. + +How can we tell if a `Linkable` was actually used while running some TH? + +GHC provides a `hscCompileCoreExprHook` which lets us intercept bytecode as +it is being compiled and linked. We can inspect the bytecode to see which +`Linkable` dependencies it requires, and record this for use in +recompilation checking. +We record all the home package modules of the free names that occur in the +bytecode. The `Linkable`s required are then the transitive closure of these +modules in the home-package environment. This is the same scheme as used by +GHC to find the correct things to link in before running bytecode. + +This works fine if we already have previous build products in memory, but +what if we are reading an interface from disk? Well, we can smuggle in the +necessary information (linkable `Module`s required as well as the time they +were generated) using `Annotation`s, which provide a somewhat general purpose +way to serialise arbitrary information along with interface files. + +Then when deciding whether to recompile, we need to check that the versions +(i.e. hashes) of the linkables used during a previous compile match whatever is +currently in the HPT. + +As we always generate Linkables from core files, we use the core file hash +as a (hopefully) deterministic measure of whether the Linkable has changed. +This is better than using the object file hash (if we have one) because object +file generation is not deterministic. +-} + +data RecompilationInfo m + = RecompilationInfo + { source_version :: FileVersion + , old_value :: Maybe (HiFileResult, FileVersion) + , get_file_version :: NormalizedFilePath -> m (Maybe FileVersion) + , get_linkable_hashes :: [NormalizedFilePath] -> m [BS.ByteString] + , get_module_graph :: m DependencyInformation + , regenerate :: Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult) -- ^ Action to regenerate an interface + } + +-- | Either a regular GHC linkable or a core file that +-- can be later turned into a proper linkable +data IdeLinkable = GhcLinkable !Linkable | CoreLinkable !UTCTime !CoreFile + +instance NFData IdeLinkable where + rnf (GhcLinkable lb) = rnf lb + rnf (CoreLinkable time _) = rnf time + +ml_core_file :: ModLocation -> FilePath +ml_core_file ml = ml_hi_file ml <.> "core" + +-- | Returns an up-to-date module interface, regenerating if needed. +-- Assumes file exists. +-- Requires the 'HscEnv' to be set up with dependencies +-- See Note [Recompilation avoidance in the presence of TH] +loadInterface + :: (MonadIO m, MonadMask m) + => HscEnv + -> ModSummary + -> Maybe LinkableType + -> RecompilationInfo m + -> m ([FileDiagnostic], Maybe HiFileResult) +loadInterface session ms linkableNeeded RecompilationInfo{..} = do + let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session + mb_old_iface = hirModIface . fst <$> old_value + + core_file = ml_core_file (ms_location ms) + iface_file = ml_hi_file (ms_location ms) + + !mod = ms_mod ms + + old_iface <- case mb_old_iface of + Just iface -> pure (Just iface) + Nothing -> do + let ncu = hsc_NC sessionWithMsDynFlags + read_dflags = hsc_dflags sessionWithMsDynFlags +#if MIN_VERSION_ghc(9,13,0) + read_result <- liftIO $ readIface (hsc_hooks sessionWithMsDynFlags) (hsc_logger sessionWithMsDynFlags) read_dflags ncu mod iface_file +#else + read_result <- liftIO $ readIface read_dflags ncu mod iface_file +#endif + case read_result of + Util.Failed{} -> return Nothing + -- important to call `shareUsages` here before checkOldIface + -- consults `mi_usages` + Util.Succeeded iface -> return $ Just (shareUsages iface) + + -- If mb_old_iface is nothing then checkOldIface will load it for us + -- given that the source is unmodified + (recomp_iface_reqd, mb_checked_iface) + <- liftIO $ checkOldIface sessionWithMsDynFlags ms old_iface >>= \case + UpToDateItem x -> pure (UpToDate, Just x) + OutOfDateItem reason x -> pure (NeedsRecompile reason, x) + + let do_regenerate _reason = withTrace "regenerate interface" $ \setTag -> do + setTag "Module" $ moduleNameString $ moduleName mod + setTag "Reason" $ showReason _reason + liftIO $ traceMarkerIO $ "regenerate interface " ++ show (moduleNameString $ moduleName mod, showReason _reason) + regenerate linkableNeeded + + case (mb_checked_iface, recomp_iface_reqd) of + (Just iface, UpToDate) -> do + details <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface + -- parse the runtime dependencies from the annotations + let runtime_deps = +#if MIN_VERSION_ghc(9,13,0) + parseRuntimeDeps (md_anns details) +#else + if not (mi_used_th iface) then emptyModuleEnv + else parseRuntimeDeps (md_anns details) +#endif + -- Peform the fine grained recompilation check for TH + maybe_recomp <- checkLinkableDependencies get_linkable_hashes get_module_graph runtime_deps + case maybe_recomp of + Just msg -> do_regenerate msg + Nothing + | isJust linkableNeeded -> handleErrs $ do + (coreFile@CoreFile{cf_iface_hash}, core_hash) <- liftIO $ + readBinCoreFile (mkUpdater $ hsc_NC session) core_file + if cf_iface_hash == getModuleHash iface + then return ([], Just $ mkHiFileResult ms iface details runtime_deps (Just (coreFile, fingerprintToBS core_hash))) + else do_regenerate (recompBecause "Core file out of date (doesn't match iface hash)") + | otherwise -> return ([], Just $ mkHiFileResult ms iface details runtime_deps Nothing) + where handleErrs = flip catches + [Handler $ \(e :: IOException) -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")") + ,Handler $ \(e :: GhcException) -> case e of + Signal _ -> throw e + Panic _ -> throw e + _ -> do_regenerate (recompBecause $ "Reading core file failed (" ++ show e ++ ")") + ] + (_, _reason) -> do_regenerate _reason + +-- | Find the runtime dependencies by looking at the annotations +-- serialized in the iface +-- The bytestrings are the hashes of the core files for modules we +-- required to run the TH splices in the given module. +-- See Note [Recompilation avoidance in the presence of TH] +parseRuntimeDeps :: [ModIfaceAnnotation] -> ModuleEnv BS.ByteString +parseRuntimeDeps anns = mkModuleEnv $ mapMaybe go anns + where + go (Annotation (ModuleTarget mod) payload) + | Just bs <- fromSerialized BS.pack payload + = Just (mod, bs) + go _ = Nothing + +-- | checkLinkableDependencies compares the core files in the build graph to +-- the runtime dependencies of the module, to check if any of them are out of date +-- Hopefully 'runtime_deps' will be empty if the module didn't actually use TH +-- See Note [Recompilation avoidance in the presence of TH] +checkLinkableDependencies :: MonadIO m => ([NormalizedFilePath] -> m [BS.ByteString]) -> m DependencyInformation -> ModuleEnv BS.ByteString -> m (Maybe RecompileRequired) +checkLinkableDependencies get_linkable_hashes get_module_graph runtime_deps = do + graph <- get_module_graph + let go (mod, hash) = (,hash) <$> lookupModuleFile mod graph + hs_files = mapM go (moduleEnvToList runtime_deps) + case hs_files of + Nothing -> error "invalid module graph" + Just fs -> do + store_hashes <- get_linkable_hashes (map fst fs) + let out_of_date = [core_file | ((core_file, expected_hash), actual_hash) <- zip fs store_hashes, expected_hash /= actual_hash] + case out_of_date of + [] -> pure Nothing + _ -> pure $ Just $ recompBecause + $ "out of date runtime dependencies: " ++ intercalate ", " (map show out_of_date) + +recompBecause :: String -> RecompileRequired +recompBecause = + NeedsRecompile . + RecompBecause + . CustomReason + +data SourceModified = SourceModified | SourceUnmodified deriving (Eq, Ord, Show) + +showReason :: RecompileRequired -> String +showReason UpToDate = "UpToDate" +showReason (NeedsRecompile MustCompile) = "MustCompile" +showReason (NeedsRecompile s) = printWithoutUniques s + +mkDetailsFromIface :: HscEnv -> ModIface -> IO ModDetails +mkDetailsFromIface session iface = do + fixIO $ \details -> do +#if MIN_VERSION_ghc(9,13,0) + hscInsertHPT (HomeModInfo iface details emptyHomeModInfoLinkable) session + initIfaceLoad session (typecheckIface iface) +#else + let !hsc' = hscUpdateHPT (\hpt -> addToHpt hpt (moduleName $ mi_module iface) (HomeModInfo iface details emptyHomeModInfoLinkable)) session + initIfaceLoad hsc' (typecheckIface iface) +#endif + +coreFileToCgGuts :: HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts +coreFileToCgGuts session iface details core_file = do + let this_mod = mi_module iface + types_var <- newIORef (md_types details) +#if MIN_VERSION_ghc(9,13,0) + let hsc_env' = session { + hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)]) + } + hscInsertHPT (HomeModInfo iface details emptyHomeModInfoLinkable) hsc_env' +#else + let act hpt = addToHpt hpt (moduleName this_mod) + (HomeModInfo iface details emptyHomeModInfoLinkable) + hsc_env' = hscUpdateHPT act (session { + hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)]) + }) +#endif + core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckCoreFile this_mod types_var core_file + -- Implicit binds aren't saved, so we need to regenerate them ourselves. + let _implicit_binds = concatMap getImplicitBinds tyCons -- only used if GHC < 9.6 + tyCons = typeEnvTyCons (md_types details) + -- In GHC 9.6, the implicit binds are tidied and part of core_binds + pure $ CgGuts this_mod tyCons core_binds [] NoStubs [] mempty +#if !MIN_VERSION_ghc(9,11,0) + (emptyHpcInfo False) +#endif + Nothing [] + +coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDetails -> CoreFile -> UTCTime -> IO ([FileDiagnostic], Maybe HomeModInfo) +coreFileToLinkable linkableType session ms iface details core_file t = do + cgi_guts <- coreFileToCgGuts session iface details core_file + (warns, lb) <- case linkableType of + BCOLinkable -> fmap (maybe emptyHomeModInfoLinkable justBytecode) <$> generateByteCode (CoreFileTime t) session ms cgi_guts + ObjectLinkable -> fmap (maybe emptyHomeModInfoLinkable justObjects) <$> generateObjectCode session ms cgi_guts + pure (warns, Just $ HomeModInfo iface details lb) -- TODO wz1000 handle emptyHomeModInfoLinkable + +-- | Non-interactive, batch version of 'InteractiveEval.getDocs'. +-- The interactive paths create problems in ghc-lib builds +--- and leads to fun errors like "Cannot continue after interface file error". +getDocsBatch + :: HscEnv + -> [Name] + -> IO [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))] +getDocsBatch hsc_env _names = do + res <- initIfaceLoad hsc_env $ forM _names $ \name -> + case nameModule_maybe name of + Nothing -> return (Left $ NameHasNoModule name) + Just mod -> do + ModIface { + mi_docs = Just Docs{ docs_mod_hdr = mb_doc_hdr + , docs_decls = dmap + , docs_args = amap + } + } <- loadSysInterface (text "getModuleInterface") mod + if isNothing mb_doc_hdr && isNullUniqMap dmap && isNullUniqMap amap + then pure (Left (NoDocsInIface mod $ compiled name)) + else pure (Right ( + lookupUniqMap dmap name, + lookupWithDefaultUniqMap amap mempty name)) + return $ map (first $ T.unpack . printOutputable) res + where + compiled n = + -- TODO: Find a more direct indicator. + case nameSrcLoc n of + RealSrcLoc {} -> False + UnhelpfulLoc {} -> True + +-- | Non-interactive, batch version of 'InteractiveEval.lookupNames'. +-- The interactive paths create problems in ghc-lib builds +--- and leads to fun errors like "Cannot continue after interface file error". +lookupName :: HscEnv + -> Name + -> IO (Maybe TyThing) +lookupName _ name + | Nothing <- nameModule_maybe name = pure Nothing +lookupName hsc_env name = exceptionHandle $ do + mb_thing <- liftIO $ lookupType hsc_env name + case mb_thing of + x@(Just _) -> return x + Nothing + | x@(Just thing) <- wiredInNameTyThing_maybe name + -> do when (needWiredInHomeIface thing) + (initIfaceLoad hsc_env (loadWiredInHomeIface name)) + return x + | otherwise -> do + res <- initIfaceLoad hsc_env $ importDecl name + case res of + Util.Succeeded x -> return (Just x) + _ -> return Nothing + where + exceptionHandle x = x `catch` \(_ :: IOEnvFailure) -> pure Nothing + +pathToModuleName :: FilePath -> ModuleName +pathToModuleName = mkModuleName . map rep + where + rep c | isPathSeparator c = '_' + rep ':' = '_' + rep c = c + +-- | Initialising plugins looks in the finder cache, but we know that the plugin doesn't come from a home module, so don't +-- error out when we don't find it +setNonHomeFCHook :: HscEnv -> HscEnv +setNonHomeFCHook hsc_env = +#if MIN_VERSION_ghc(9,13,0) + hsc_env { hsc_FC = (hsc_FC hsc_env) + { lookupFinderCache = \im -> + if moduleUnit im `elem` hsc_all_home_unit_ids hsc_env + then pure (Just $ InstalledNotFound [] Nothing) + else lookupFinderCache (hsc_FC hsc_env) im + } + } +#elif MIN_VERSION_ghc(9,11,0) + hsc_env { hsc_FC = (hsc_FC hsc_env) + { lookupFinderCache = \m@(GWIB im _) -> + if moduleUnit im `elem` hsc_all_home_unit_ids hsc_env + then pure (Just $ InstalledNotFound [] Nothing) + else lookupFinderCache (hsc_FC hsc_env) m + } + } +#else + hsc_env +#endif + +{- Note [Guidelines For Using CPP In GHCIDE Import Statements] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + GHCIDE's interface with GHC is extensive, and unfortunately, because we have + to work with multiple versions of GHC, we have several files that need to use + a lot of CPP. In order to simplify the CPP in the import section of every file + we have a few specific guidelines for using CPP in these sections. + + - We don't want to nest CPP clauses, nor do we want to use else clauses. Both + nesting and else clauses end up drastically complicating the code, and require + significant mental stack to unwind. + + - CPP clauses should be placed at the end of the imports section. The clauses + should be ordered by the GHC version they target from earlier to later versions, + with negative if clauses coming before positive if clauses of the same + version. (If you think about which GHC version a clause activates for this + should make sense `!MIN_VERSION_GHC(9,0,0)` refers to 8.10 and lower which is + an earlier version than `MIN_VERSION_GHC(9,0,0)` which refers to versions 9.0 + and later). In addition there should be a space before and after each CPP + clause. + + - In if clauses that use `&&` and depend on more than one statement, the + positive statement should come before the negative statement. In addition the + clause should come after the single positive clause for that GHC version. + + - There shouldn't be multiple identical CPP statements. The use of odd or even + GHC numbers is identical, with the only preference being to use what is + already there. (i.e. (`MIN_VERSION_GHC(9,2,0)` and `MIN_VERSION_GHC(9,1,0)` + are functionally equivalent) +-} diff --git a/src/Development/IDE/Core/FileExists.hs b/src/Development/IDE/Core/FileExists.hs --- a/src/Development/IDE/Core/FileExists.hs +++ b/src/Development/IDE/Core/FileExists.hs @@ -27,19 +27,21 @@ import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), - Recorder, WithPriority, - cmapWithPrio) import Development.IDE.Types.Options +import Development.IDE.Types.Shake (toKey) import qualified Focus +import Ide.Logger (Pretty (pretty), + Recorder, WithPriority, + cmapWithPrio) import Ide.Plugin.Config (Config) +import Language.LSP.Protocol.Types import Language.LSP.Server hiding (getVirtualFile) -import Language.LSP.Types import qualified StmContainers.Map as STM import qualified System.Directory as Dir import qualified System.FilePath.Glob as Glob {- Note [File existence cache and LSP file watchers] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some LSP servers provide the ability to register file watches with the client, which will then notify us of file changes. Some clients can do this more efficiently than us, or generally it's a tricky problem @@ -95,8 +97,8 @@ instance Pretty Log where pretty = \case - LogFileStore log -> pretty log - LogShake log -> pretty log + LogFileStore msg -> pretty msg + LogShake msg -> pretty msg -- | Grab the current global value of 'FileExistsMap' without acquiring a dependency getFileExistsMapUntracked :: Action FileExistsMap @@ -104,12 +106,12 @@ FileExistsMapVar v <- getIdeGlobalAction return v --- | Modify the global store of file exists. -modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO () +-- | Modify the global store of file exists and return the keys that need to be marked as dirty +modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO [Key] modifyFileExists state changes = do FileExistsMapVar var <- getIdeGlobalState state -- Masked to ensure that the previous values are flushed together with the map update - join $ mask_ $ atomicallyNamed "modifyFileExists" $ do + mask_ $ atomicallyNamed "modifyFileExists" $ do forM_ changes $ \(f,c) -> case fromChange c of Just c' -> STM.focus (Focus.insert c') f var @@ -117,16 +119,16 @@ -- See Note [Invalidating file existence results] -- flush previous values let (fileModifChanges, fileExistChanges) = - partition ((== FcChanged) . snd) changes - mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges - io1 <- recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges - io2 <- recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges - return (io1 <> io2) + partition ((== FileChangeType_Changed) . snd) changes + keys0 <- concat <$> mapM (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges + let keys1 = map (toKey GetFileExists . fst) fileExistChanges + let keys2 = map (toKey GetModificationTime . fst) fileModifChanges + return (keys0 <> keys1 <> keys2) fromChange :: FileChangeType -> Maybe Bool -fromChange FcCreated = Just True -fromChange FcDeleted = Just False -fromChange FcChanged = Nothing +fromChange FileChangeType_Created = Just True +fromChange FileChangeType_Deleted = Just False +fromChange FileChangeType_Changed = Nothing ------------------------------------------------------------------------------------- @@ -135,6 +137,7 @@ getFileExists fp = use_ GetFileExists fp {- Note [Which files should we watch?] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The watcher system gives us a lot of flexibility: we can set multiple watchers, and they can all watch on glob patterns. @@ -201,6 +204,7 @@ else fileExistsSlow file {- Note [Invalidating file existence results] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have two mechanisms for getting file existence information: - The file existence cache - The VFS lookup diff --git a/src/Development/IDE/Core/FileStore.hs b/src/Development/IDE/Core/FileStore.hs --- a/src/Development/IDE/Core/FileStore.hs +++ b/src/Development/IDE/Core/FileStore.hs @@ -1,10 +1,12 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} module Development.IDE.Core.FileStore( + getFileModTimeContents, getFileContents, + getUriContents, + getVersionedTextDoc, setFileModified, setSomethingModified, fileStoreRules, @@ -19,66 +21,61 @@ isWatchSupported, registerFileWatches, shareFilePath, - Log(..) + Log(..), ) where -import Control.Concurrent.STM.Stats (STM, atomically, - modifyTVar') -import Control.Concurrent.STM.TQueue (writeTQueue) +import Control.Concurrent.STM.Stats (STM, atomically) import Control.Exception +import Control.Lens ((^.)) import Control.Monad.Extra import Control.Monad.IO.Class +import qualified Data.Binary as B import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS import qualified Data.HashMap.Strict as HashMap import Data.IORef import qualified Data.Text as T -import qualified Data.Text.Utf16.Rope as Rope +import qualified Data.Text as Text +import Data.Text.Utf16.Rope.Mixed (Rope) import Data.Time import Data.Time.Clock.POSIX import Development.IDE.Core.FileUtils +import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Core.WorkerThread import Development.IDE.GHC.Orphans () import Development.IDE.Graph import Development.IDE.Import.DependencyInformation import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options +import Development.IDE.Types.Shake (toKey) import HieDb.Create (deleteMissingRealFiles) -import Ide.Plugin.Config (CheckParents (..), - Config) -import System.IO.Error - -#ifdef mingw32_HOST_OS -import qualified System.Directory as Dir -#else -#endif - -import qualified Development.IDE.Types.Logger as L - -import qualified Data.Binary as B -import qualified Data.ByteString.Lazy as LBS -import Data.List (foldl') -import qualified Data.Text as Text -import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Types.Logger (Pretty (pretty), +import Ide.Logger (Pretty (pretty), Priority (Info), Recorder, WithPriority, cmapWithPrio, logWith, viaShow, (<+>)) -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions), - FileChangeType (FcChanged), +import qualified Ide.Logger as L +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (toUntypedRegistration) +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions), FileSystemWatcher (..), - WatchKind (..), - _watchers) -import qualified Language.LSP.Types as LSP -import qualified Language.LSP.Types.Capabilities as LSP + TextDocumentIdentifier (..), + VersionedTextDocumentIdentifier (..), + _watchers, + uriToNormalizedFilePath) +import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Server as LSP import Language.LSP.VFS import System.FilePath +import System.IO.Error import System.IO.Unsafe data Log @@ -96,7 +93,7 @@ <+> viaShow path <> ":" <+> pretty (fmap (fmap show) reverseDepPaths) - LogShake log -> pretty log + LogShake msg -> pretty msg addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile f -> do @@ -149,6 +146,29 @@ then return (Nothing, ([], Nothing)) else return (Nothing, ([diag], Nothing)) + +getPhysicalModificationTimeRule :: Recorder (WithPriority Log) -> Rules () +getPhysicalModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetPhysicalModificationTime file -> + getPhysicalModificationTimeImpl file + +getPhysicalModificationTimeImpl + :: NormalizedFilePath + -> Action (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion)) +getPhysicalModificationTimeImpl file = do + let file' = fromNormalizedFilePath file + let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time)) + + alwaysRerun + + liftIO $ fmap wrap (getModTime file') + `catch` \(e :: IOException) -> do + let err | isDoesNotExistError e = "File does not exist: " ++ file' + | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e + diag = ideErrorText file (T.pack err) + if isDoesNotExistError e + then return (Nothing, ([], Nothing)) + else return (Nothing, ([diag], Nothing)) + -- | Interface files cannot be watched, since they live outside the workspace. -- But interface files are private, in that only HLS writes them. -- So we implement watching ourselves, and bypass the need for alwaysRerun. @@ -156,24 +176,28 @@ isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot", ".hie", ".hie-boot", ".core"] -- | Reset the GetModificationTime state of interface files -resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM () +resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM [Key] resetInterfaceStore state f = do deleteValue state GetModificationTime f -- | Reset the GetModificationTime state of watched files -- Assumes the list does not include any FOIs -resetFileStore :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO () +resetFileStore :: IdeState -> [(NormalizedFilePath, LSP.FileChangeType)] -> IO [Key] resetFileStore ideState changes = mask $ \_ -> do -- we record FOIs document versions in all the stored values -- so NEVER reset FOIs to avoid losing their versions -- FOI filtering is done by the caller (LSP Notification handler) - forM_ changes $ \(nfp, c) -> do - case c of - FcChanged - -- already checked elsewhere | not $ HM.member nfp fois - -> atomically $ - deleteValue (shakeExtras ideState) GetModificationTime nfp - _ -> pure () + fmap concat <$> + forM changes $ \(nfp, c) -> do + case c of + LSP.FileChangeType_Changed + -- already checked elsewhere | not $ HM.member nfp fois + -> + atomically $ do + ks <- deleteValue (shakeExtras ideState) GetModificationTime nfp + vs <- deleteValue (shakeExtras ideState) GetPhysicalModificationTime nfp + pure $ ks ++ vs + _ -> pure [] modificationTime :: FileVersion -> Maybe UTCTime @@ -185,20 +209,20 @@ getFileContentsImpl :: NormalizedFilePath - -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe T.Text)) + -> Action ([FileDiagnostic], Maybe (FileVersion, Maybe Rope)) getFileContentsImpl file = do -- need to depend on modification time to introduce a dependency with Cutoff time <- use_ GetModificationTime file res <- do mbVirtual <- getVirtualFile file - pure $ Rope.toText . _file_text <$> mbVirtual + pure $ _file_text <$> mbVirtual pure ([], Just (time, res)) -- | Returns the modification time and the contents. -- For VFS paths, the modification time is the current time. -getFileContents :: NormalizedFilePath -> Action (UTCTime, Maybe T.Text) -getFileContents f = do - (fv, txt) <- use_ GetFileContents f +getFileModTimeContents :: NormalizedFilePath -> Action (UTCTime, Maybe Rope) +getFileModTimeContents f = do + (fv, contents) <- use_ GetFileContents f modTime <- case modificationTime fv of Just t -> pure t Nothing -> do @@ -208,11 +232,34 @@ _ -> do posix <- getModTime $ fromNormalizedFilePath f pure $ posixSecondsToUTCTime posix - return (modTime, txt) + return (modTime, contents) +getFileContents :: NormalizedFilePath -> Action (Maybe Rope) +getFileContents f = snd <$> use_ GetFileContents f + +getUriContents :: NormalizedUri -> Action (Maybe Rope) +getUriContents uri = + join <$> traverse getFileContents (uriToNormalizedFilePath uri) + +-- | Given a text document identifier, annotate it with the latest version. +-- +-- Like Language.LSP.Server.Core.getVersionedTextDoc, but gets the virtual file +-- from the Shake VFS rather than the LSP VFS. +getVersionedTextDoc :: TextDocumentIdentifier -> Action VersionedTextDocumentIdentifier +getVersionedTextDoc doc = do + let uri = doc ^. L.uri + mvf <- + maybe (pure Nothing) getVirtualFile $ + uriToNormalizedFilePath $ toNormalizedUri uri + let ver = case mvf of + Just (VirtualFile lspver _ _ _) -> lspver + Nothing -> 0 + return (VersionedTextDocumentIdentifier uri ver) + fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules () fileStoreRules recorder isWatched = do getModificationTimeRule recorder + getPhysicalModificationTimeRule recorder getFileContentsRule recorder addWatchedFileRule recorder isWatched @@ -223,16 +270,18 @@ -> IdeState -> Bool -- ^ Was the file saved? -> NormalizedFilePath + -> IO [Key] -> IO () -setFileModified recorder vfs state saved nfp = do +setFileModified recorder vfs state saved nfp actionBefore = do ideOptions <- getIdeOptionsIO $ shakeExtras state doCheckParents <- optCheckParents ideOptions let checkParents = case doCheckParents of AlwaysCheck -> True CheckOnSave -> saved _ -> False - join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp] - restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] + restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] $ do + keys<-actionBefore + return (toKey GetModificationTime nfp:keys) when checkParents $ typecheckParents recorder state nfp @@ -242,25 +291,21 @@ typecheckParentsAction :: Recorder (WithPriority Log) -> NormalizedFilePath -> Action () typecheckParentsAction recorder nfp = do - revs <- transitiveReverseDependencies nfp <$> useNoFile_ GetModuleGraph - let log = logWith recorder + revs <- transitiveReverseDependencies nfp <$> useWithSeparateFingerprintRule_ GetModuleGraphTransReverseDepsFingerprints GetModuleGraph nfp case revs of - Nothing -> log Info $ LogCouldNotIdentifyReverseDeps nfp + Nothing -> logWith recorder Info $ LogCouldNotIdentifyReverseDeps nfp Just rs -> do - log Info $ LogTypeCheckingReverseDeps nfp revs + logWith recorder Info $ LogTypeCheckingReverseDeps nfp revs void $ uses GetModIface rs -- | Note that some keys have been modified and restart the session -- Only valid if the virtual file system was initialised by LSP, as that -- independently tracks which files are modified. -setSomethingModified :: VFSModified -> IdeState -> [Key] -> String -> IO () -setSomethingModified vfs state keys reason = do +setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO () +setSomethingModified vfs state reason actionBetweenSession = do -- Update database to remove any files that might have been renamed/deleted - atomically $ do - writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) - modifyTVar' (dirtyKeys $ shakeExtras state) $ \x -> - foldl' (flip insertKeySet) x keys - void $ restartShakeSession (shakeExtras state) vfs reason [] + atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) + void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do @@ -268,26 +313,27 @@ if watchSupported then do let - regParams = LSP.RegistrationParams (List [LSP.SomeRegistration registration]) + regParams = LSP.RegistrationParams [toUntypedRegistration registration] -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't). -- We could also use something like a random UUID, as some other servers do, but this works for -- our purposes. - registration = LSP.Registration "globalFileWatches" - LSP.SWorkspaceDidChangeWatchedFiles - regOptions + registration = LSP.TRegistration { _id ="globalFileWatches" + , _method = LSP.SMethod_WorkspaceDidChangeWatchedFiles + , _registerOptions = Just regOptions} regOptions = - DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers } + DidChangeWatchedFilesRegistrationOptions { _watchers = watchers } -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind - watchKind = WatchKind { _watchCreate = True, _watchChange = True, _watchDelete = True} + -- WatchKind_Custom 7 is for create, change, and delete + watchKind = LSP.WatchKind_Custom 7 -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is -- The patterns will be something like "**/.hs", i.e. "any number of directory segments, -- followed by a file with an extension 'hs'. watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind } -- We use multiple watchers instead of one using '{}' because lsp-test doesn't -- support that: https://github.com/bubba/lsp-test/issues/77 - watchers = [ watcher (Text.pack glob) | glob <- globs ] + watchers = [ watcher (LSP.GlobPattern (LSP.InL (LSP.Pattern (Text.pack glob)))) | glob <- globs ] - void $ LSP.sendRequest LSP.SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response + void $ LSP.sendRequest LSP.SMethod_ClientRegisterCapability regParams (const $ pure ()) -- TODO handle response return True else return False @@ -311,7 +357,6 @@ atomicModifyIORef' filePathMap $ \km -> let new_key = HashMap.lookup k km in case new_key of - Just v -> (km, v) + Just v -> (km, v) Nothing -> (HashMap.insert k k km, k) {-# NOINLINE shareFilePath #-} - diff --git a/src/Development/IDE/Core/FileUtils.hs b/src/Development/IDE/Core/FileUtils.hs --- a/src/Development/IDE/Core/FileUtils.hs +++ b/src/Development/IDE/Core/FileUtils.hs @@ -6,6 +6,7 @@ import Data.Time.Clock.POSIX + #ifdef mingw32_HOST_OS import qualified System.Directory as Dir #else diff --git a/src/Development/IDE/Core/IdeConfiguration.hs b/src/Development/IDE/Core/IdeConfiguration.hs --- a/src/Development/IDE/Core/IdeConfiguration.hs +++ b/src/Development/IDE/Core/IdeConfiguration.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DuplicateRecordFields #-} module Development.IDE.Core.IdeConfiguration ( IdeConfiguration(..) , registerIdeConfiguration @@ -13,16 +12,17 @@ where import Control.Concurrent.Strict + import Control.Monad import Control.Monad.IO.Class import Data.Aeson.Types (Value) import Data.Hashable (Hashed, hashed, unhashed) import Data.HashSet (HashSet, singleton) -import Data.Text (Text, isPrefixOf) +import Data.Text (isPrefixOf) import Development.IDE.Core.Shake import Development.IDE.Graph import Development.IDE.Types.Location -import Language.LSP.Types +import Language.LSP.Protocol.Types import System.FilePath (isRelative) -- | Lsp client relevant configuration details @@ -49,15 +49,15 @@ IdeConfiguration {..} where workspaceFolders = - foldMap (singleton . toNormalizedUri) _rootUri + foldMap (singleton . toNormalizedUri) (nullToMaybe _rootUri) <> (foldMap . foldMap) (singleton . parseWorkspaceFolder) - _workspaceFolders + (nullToMaybe =<< _workspaceFolders) clientSettings = hashed _initializationOptions parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri parseWorkspaceFolder WorkspaceFolder{_uri} = - toNormalizedUri (Uri _uri) + toNormalizedUri _uri modifyWorkspaceFolders :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO () diff --git a/src/Development/IDE/Core/LookupMod.hs b/src/Development/IDE/Core/LookupMod.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Core/LookupMod.hs @@ -0,0 +1,24 @@ +module Development.IDE.Core.LookupMod (lookupMod, LookupModule) where + +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import Development.IDE.Core.Shake (HieDbWriter, IdeAction) +import Development.IDE.GHC.Compat.Core (ModuleName, Unit) +import Development.IDE.Types.Location (Uri) + +-- | Gives a Uri for the module, given the .hie file location and the the module info +-- The Bool denotes if it is a boot module +type LookupModule m = FilePath -> ModuleName -> Unit -> Bool -> MaybeT m Uri + +-- | Eventually this will lookup/generate URIs for files in dependencies, but not in the +-- project. Right now, this is just a stub. +lookupMod :: + -- | access the database + HieDbWriter -> + -- | The `.hie` file we got from the database + FilePath -> + ModuleName -> + Unit -> + -- | Is this file a boot file? + Bool -> + MaybeT IdeAction Uri +lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing diff --git a/src/Development/IDE/Core/OfInterest.hs b/src/Development/IDE/Core/OfInterest.hs --- a/src/Development/IDE/Core/OfInterest.hs +++ b/src/Development/IDE/Core/OfInterest.hs @@ -1,8 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} -- | Utilities and state for the files of interest - those which are currently -- open in the editor. The rule is 'IsFileOfInterest' @@ -24,7 +23,7 @@ import Control.Monad.IO.Class import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import qualified Data.Text as T +import Data.Proxy import Development.IDE.Graph import Control.Concurrent.STM.Stats (atomically, @@ -39,21 +38,24 @@ import Development.IDE.Plugin.Completions.Types import Development.IDE.Types.Exports import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), +import Development.IDE.Types.Options (IdeTesting (..)) +import Development.IDE.Types.Shake (toKey) +import GHC.TypeLits (KnownSymbol) +import Ide.Logger (Pretty (pretty), + Priority (..), Recorder, WithPriority, cmapWithPrio, - logDebug) -import Development.IDE.Types.Options (IdeTesting (..)) + logWith) +import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Server as LSP -import qualified Language.LSP.Types as LSP data Log = LogShake Shake.Log deriving Show instance Pretty Log where pretty = \case - LogShake log -> pretty log + LogShake msg -> pretty msg newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus)) @@ -101,24 +103,26 @@ OfInterestVar var <- getIdeGlobalAction liftIO $ readVar var -addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO () +addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key] addFileOfInterest state f v = do OfInterestVar var <- getIdeGlobalState state (prev, files) <- modifyVar var $ \dict -> do let (prev, new) = HashMap.alterF (, Just v) f dict pure (new, (prev, new)) - when (prev /= Just v) $ do - join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] - logDebug (ideLogger state) $ - "Set files of interest to: " <> T.pack (show files) + if prev /= Just v + then do + logWith (ideLogger state) Debug $ + LogSetFilesOfInterest (HashMap.toList files) + return [toKey IsFileOfInterest f] + else return [] -deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO () +deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO [Key] deleteFileOfInterest state f = do OfInterestVar var <- getIdeGlobalState state files <- modifyVar' var $ HashMap.delete f - join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] - logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show files) - + logWith (ideLogger state) Debug $ + LogSetFilesOfInterest (HashMap.toList files) + return [toKey IsFileOfInterest f] scheduleGarbageCollection :: IdeState -> IO () scheduleGarbageCollection state = do GarbageCollectVar var <- getIdeGlobalState state @@ -130,13 +134,14 @@ kick = do files <- HashMap.keys <$> getFilesOfInterestUntracked ShakeExtras{exportsMap, ideTesting = IdeTesting testing, lspEnv, progress} <- getShakeExtras - let signal msg = when testing $ liftIO $ + let signal :: KnownSymbol s => Proxy s -> Action () + signal msg = when testing $ liftIO $ mRunLspT lspEnv $ - LSP.sendNotification (LSP.SCustomMethod msg) $ + LSP.sendNotification (LSP.SMethod_CustomMethod msg) $ toJSON $ map fromNormalizedFilePath files - signal "kick/start" - liftIO $ progressUpdate progress KickStarted + signal (Proxy @"kick/start") + liftIO $ progressUpdate progress ProgressNewStarted -- Update the exports map results <- uses GenerateCore files @@ -147,7 +152,7 @@ let mguts = catMaybes results void $ liftIO $ atomically $ modifyTVar' exportsMap (updateExportsMapMg mguts) - liftIO $ progressUpdate progress KickCompleted + liftIO $ progressUpdate progress ProgressCompleted GarbageCollectVar var <- getIdeGlobalAction garbageCollectionScheduled <- liftIO $ readVar var @@ -155,4 +160,4 @@ void garbageCollectDirtyKeys liftIO $ writeVar var False - signal "kick/done" + signal (Proxy @"kick/done") diff --git a/src/Development/IDE/Core/PluginUtils.hs b/src/Development/IDE/Core/PluginUtils.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Core/PluginUtils.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE GADTs #-} +module Development.IDE.Core.PluginUtils +(-- * Wrapped Action functions + runActionE +, runActionMT +, useE +, useMT +, usesE +, usesMT +, useWithStaleE +, useWithStaleMT +-- * Wrapped IdeAction functions +, runIdeActionE +, runIdeActionMT +, useWithStaleFastE +, useWithStaleFastMT +, uriToFilePathE +-- * Wrapped PositionMapping functions +, toCurrentPositionE +, toCurrentPositionMT +, fromCurrentPositionE +, fromCurrentPositionMT +, toCurrentRangeE +, toCurrentRangeMT +, fromCurrentRangeE +, fromCurrentRangeMT +-- * Diagnostics +, activeDiagnosticsInRange +, activeDiagnosticsInRangeMT +, injectServerDiagnostics +-- * Formatting handlers +, mkFormattingHandlers) where + +import Control.Concurrent.STM +import Control.Lens +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.Extra +import Control.Monad.IO.Class +import Control.Monad.Reader (runReaderT) +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import qualified Data.Text as T +import qualified Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE.Core.FileStore +import Development.IDE.Core.PositionMapping +import Development.IDE.Core.Service (runAction) +import Development.IDE.Core.Shake (IdeAction, IdeRule, + IdeState (shakeExtras), + mkDelayedAction, + shakeEnqueue) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.GHC.Orphans () +import Development.IDE.Graph hiding (ShakeValue) +import Development.IDE.Types.Diagnostics +import Development.IDE.Types.Location (NormalizedFilePath) +import qualified Development.IDE.Types.Location as Location +import qualified Ide.Logger as Logger +import Ide.Plugin.Error +import Ide.PluginUtils (rangesOverlap) +import Ide.Types +import qualified Language.LSP.Protocol.Lens as LSP +import Language.LSP.Protocol.Message (SMethod (..)) +import Language.LSP.Protocol.Types (CodeActionParams) +import qualified Language.LSP.Protocol.Types as LSP +import qualified StmContainers.Map as STM + +-- ---------------------------------------------------------------------------- +-- Action wrappers +-- ---------------------------------------------------------------------------- + +-- |ExceptT version of `runAction`, takes a ExceptT Action +runActionE :: MonadIO m => String -> IdeState -> ExceptT e Action a -> ExceptT e m a +runActionE herald ide act = + mapExceptT liftIO . ExceptT $ + join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runExceptT act) + +-- |MaybeT version of `runAction`, takes a MaybeT Action +runActionMT :: MonadIO m => String -> IdeState -> MaybeT Action a -> MaybeT m a +runActionMT herald ide act = + mapMaybeT liftIO . MaybeT $ + join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug $ runMaybeT act) + +-- |ExceptT version of `use` that throws a PluginRuleFailed upon failure +useE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError Action v +useE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useMT k + +-- |MaybeT version of `use` +useMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v +useMT k = MaybeT . Shake.use k + +-- |ExceptT version of `uses` that throws a PluginRuleFailed upon failure +usesE :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> ExceptT PluginError Action (f v) +usesE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . usesMT k + +-- |MaybeT version of `uses` +usesMT :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> MaybeT Action (f v) +usesMT k xs = MaybeT $ sequence <$> Shake.uses k xs + +-- |ExceptT version of `useWithStale` that throws a PluginRuleFailed upon +-- failure +useWithStaleE :: IdeRule k v + => k -> NormalizedFilePath -> ExceptT PluginError Action (v, PositionMapping) +useWithStaleE key = maybeToExceptT (PluginRuleFailed (T.pack $ show key)) . useWithStaleMT key + +-- |MaybeT version of `useWithStale` +useWithStaleMT :: IdeRule k v + => k -> NormalizedFilePath -> MaybeT Action (v, PositionMapping) +useWithStaleMT key file = MaybeT $ runIdentity <$> Shake.usesWithStale key (Identity file) + +-- ---------------------------------------------------------------------------- +-- IdeAction wrappers +-- ---------------------------------------------------------------------------- + +-- |ExceptT version of `runIdeAction`, takes a ExceptT IdeAction +runIdeActionE :: MonadIO m => String -> Shake.ShakeExtras -> ExceptT e IdeAction a -> ExceptT e m a +runIdeActionE _herald s i = ExceptT $ liftIO $ runReaderT (Shake.runIdeActionT $ runExceptT i) s + +-- |MaybeT version of `runIdeAction`, takes a MaybeT IdeAction +runIdeActionMT :: MonadIO m => String -> Shake.ShakeExtras -> MaybeT IdeAction a -> MaybeT m a +runIdeActionMT _herald s i = MaybeT $ liftIO $ runReaderT (Shake.runIdeActionT $ runMaybeT i) s + +-- |ExceptT version of `useWithStaleFast` that throws a PluginRuleFailed upon +-- failure +useWithStaleFastE :: IdeRule k v => k -> NormalizedFilePath -> ExceptT PluginError IdeAction (v, PositionMapping) +useWithStaleFastE k = maybeToExceptT (PluginRuleFailed (T.pack $ show k)) . useWithStaleFastMT k + +-- |MaybeT version of `useWithStaleFast` +useWithStaleFastMT :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping) +useWithStaleFastMT k = MaybeT . Shake.useWithStaleFast k + +-- ---------------------------------------------------------------------------- +-- Location wrappers +-- ---------------------------------------------------------------------------- + +-- |ExceptT version of `uriToFilePath` that throws a PluginInvalidParams upon +-- failure +uriToFilePathE :: Monad m => LSP.Uri -> ExceptT PluginError m FilePath +uriToFilePathE uri = maybeToExceptT (PluginInvalidParams (T.pack $ "uriToFilePath' failed. Uri:" <> show uri)) $ uriToFilePathMT uri + +-- |MaybeT version of `uriToFilePath` +uriToFilePathMT :: Monad m => LSP.Uri -> MaybeT m FilePath +uriToFilePathMT = MaybeT . pure . Location.uriToFilePath' + +-- ---------------------------------------------------------------------------- +-- PositionMapping wrappers +-- ---------------------------------------------------------------------------- + +-- |ExceptT version of `toCurrentPosition` that throws a PluginInvalidUserState +-- upon failure +toCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position +toCurrentPositionE mapping = maybeToExceptT (PluginInvalidUserState "toCurrentPosition"). toCurrentPositionMT mapping + +-- |MaybeT version of `toCurrentPosition` +toCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position +toCurrentPositionMT mapping = MaybeT . pure . toCurrentPosition mapping + +-- |ExceptT version of `fromCurrentPosition` that throws a +-- PluginInvalidUserState upon failure +fromCurrentPositionE :: Monad m => PositionMapping -> LSP.Position -> ExceptT PluginError m LSP.Position +fromCurrentPositionE mapping = maybeToExceptT (PluginInvalidUserState "fromCurrentPosition") . fromCurrentPositionMT mapping + +-- |MaybeT version of `fromCurrentPosition` +fromCurrentPositionMT :: Monad m => PositionMapping -> LSP.Position -> MaybeT m LSP.Position +fromCurrentPositionMT mapping = MaybeT . pure . fromCurrentPosition mapping + +-- |ExceptT version of `toCurrentRange` that throws a PluginInvalidUserState +-- upon failure +toCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range +toCurrentRangeE mapping = maybeToExceptT (PluginInvalidUserState "toCurrentRange") . toCurrentRangeMT mapping + +-- |MaybeT version of `toCurrentRange` +toCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range +toCurrentRangeMT mapping = MaybeT . pure . toCurrentRange mapping + +-- |ExceptT version of `fromCurrentRange` that throws a PluginInvalidUserState +-- upon failure +fromCurrentRangeE :: Monad m => PositionMapping -> LSP.Range -> ExceptT PluginError m LSP.Range +fromCurrentRangeE mapping = maybeToExceptT (PluginInvalidUserState "fromCurrentRange") . fromCurrentRangeMT mapping + +-- |MaybeT version of `fromCurrentRange` +fromCurrentRangeMT :: Monad m => PositionMapping -> LSP.Range -> MaybeT m LSP.Range +fromCurrentRangeMT mapping = MaybeT . pure . fromCurrentRange mapping + +-- ---------------------------------------------------------------------------- +-- Diagnostics +-- ---------------------------------------------------------------------------- + +-- | @'activeDiagnosticsInRangeMT' shakeExtras nfp range@ computes the +-- 'FileDiagnostic' 's that HLS produced and overlap with the given @range@. +-- +-- This function is to be used whenever we need an authoritative source of truth +-- for which diagnostics are shown to the user. +-- These diagnostics can be used to provide various IDE features, for example +-- CodeActions, CodeLenses, or refactorings. +-- +-- However, why do we need this when computing 'CodeAction's? A 'CodeActionParam' +-- has the 'CodeActionContext' which already contains the diagnostics! +-- But according to the LSP docs, the server shouldn't rely that these Diagnostic +-- are actually up-to-date and accurately reflect the state of the document. +-- +-- From the LSP docs: +-- > An array of diagnostics known on the client side overlapping the range +-- > provided to the `textDocument/codeAction` request. They are provided so +-- > that the server knows which errors are currently presented to the user +-- > for the given range. There is no guarantee that these accurately reflect +-- > the error state of the resource. The primary parameter +-- > to compute code actions is the provided range. +-- +-- Thus, even when the client sends us the context, we should compute the +-- diagnostics on the server side. +activeDiagnosticsInRangeMT :: MonadIO m => Shake.ShakeExtras -> NormalizedFilePath -> LSP.Range -> MaybeT m [FileDiagnostic] +activeDiagnosticsInRangeMT ide nfp range = do + MaybeT $ liftIO $ atomically $ do + mDiags <- STM.lookup (LSP.normalizedFilePathToUri nfp) (Shake.publishedDiagnostics ide) + case mDiags of + Nothing -> pure Nothing + Just fileDiags -> do + pure $ Just $ filter diagRangeOverlaps fileDiags + where + diagRangeOverlaps = \fileDiag -> + rangesOverlap range (fileDiag ^. fdLspDiagnosticL . LSP.range) + +-- | Just like 'activeDiagnosticsInRangeMT'. See the docs of 'activeDiagnosticsInRangeMT' for details. +activeDiagnosticsInRange :: MonadIO m => Shake.ShakeExtras -> NormalizedFilePath -> LSP.Range -> m (Maybe [FileDiagnostic]) +activeDiagnosticsInRange ide nfp range = runMaybeT (activeDiagnosticsInRangeMT ide nfp range) + +-- Prefer server-side diagnostics if available; they are authoritative. +injectServerDiagnostics :: IdeState -> CodeActionParams -> IO CodeActionParams +injectServerDiagnostics ide params@LSP.CodeActionParams{_textDocument=LSP.TextDocumentIdentifier{_uri}, _range} = do + serverDiags <- case LSP.uriToNormalizedFilePath (LSP.toNormalizedUri _uri) of + Nothing -> pure [] + Just nfp -> do + mDiags <- activeDiagnosticsInRange (shakeExtras ide) nfp _range + case mDiags of + Nothing -> pure [] + Just diags -> pure $ diags ^.. traverse . fdLspDiagnosticL + pure $ params & LSP.context . LSP.diagnostics .~ serverDiags + +-- ---------------------------------------------------------------------------- +-- Formatting handlers +-- ---------------------------------------------------------------------------- + +-- `mkFormattingHandlers` was moved here from hls-plugin-api package so that +-- `mkFormattingHandlers` can refer to `IdeState`. `IdeState` is defined in the +-- ghcide package, but hls-plugin-api does not depend on ghcide, so `IdeState` +-- is not in scope there. + +mkFormattingHandlers :: FormattingHandler IdeState -> PluginHandlers IdeState +mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provider SMethod_TextDocumentFormatting) + <> mkPluginHandler SMethod_TextDocumentRangeFormatting (provider SMethod_TextDocumentRangeFormatting) + where + provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler IdeState m + provider m ide _pid params + | Just nfp <- LSP.uriToNormalizedFilePath $ LSP.toNormalizedUri uri = do + contentsMaybe <- liftIO $ runAction "mkFormattingHandlers" ide $ getFileContents nfp + case contentsMaybe of + Just contents -> do + let (typ, mtoken) = case m of + SMethod_TextDocumentFormatting -> (FormatText, params ^. LSP.workDoneToken) + SMethod_TextDocumentRangeFormatting -> (FormatRange (params ^. LSP.range), params ^. LSP.workDoneToken) + _ -> Prelude.error "mkFormattingHandlers: impossible" + f ide mtoken typ (Rope.toText contents) nfp opts + Nothing -> throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri + + | otherwise = throwError $ PluginInvalidParams $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri + where + uri = params ^. LSP.textDocument . LSP.uri + opts = params ^. LSP.options diff --git a/src/Development/IDE/Core/PositionMapping.hs b/src/Development/IDE/Core/PositionMapping.hs --- a/src/Development/IDE/Core/PositionMapping.hs +++ b/src/Development/IDE/Core/PositionMapping.hs @@ -9,7 +9,7 @@ , fromCurrentPosition , toCurrentPosition , PositionDelta(..) - , addDelta + , addOldDelta , idDelta , composeDelta , mkDelta @@ -24,15 +24,18 @@ ) where import Control.DeepSeq +import Control.Lens ((^.)) import Control.Monad import Data.Algorithm.Diff import Data.Bifunctor import Data.List -import qualified Data.Text as T -import qualified Data.Vector.Unboxed as V -import Language.LSP.Types (Position (Position), Range (Range), - TextDocumentContentChangeEvent (TextDocumentContentChangeEvent), - UInt) +import qualified Data.Text as T +import qualified Data.Vector.Unboxed as V +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types (Position (Position), + Range (Range), + TextDocumentContentChangeEvent (TextDocumentContentChangeEvent), + UInt, type (|?) (InL)) -- | Either an exact position, or the range of text that was substituted data PositionResult a @@ -101,7 +104,7 @@ zeroMapping = PositionMapping idDelta -- | Compose two position mappings. Composes in the same way as function --- composition (ie the second argument is applyed to the position first). +-- composition (ie the second argument is applied to the position first). composeDelta :: PositionDelta -> PositionDelta -> PositionDelta @@ -116,14 +119,20 @@ mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta mkDelta cs = foldl' applyChange idDelta cs --- | Add a new delta onto a Mapping k n to make a Mapping (k - 1) n -addDelta :: PositionDelta -> PositionMapping -> PositionMapping -addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm) +-- | addOldDelta +-- Add a old delta onto a Mapping k n to make a Mapping (k - 1) n +addOldDelta :: + PositionDelta -- ^ delta from version k - 1 to version k + -> PositionMapping -- ^ The input mapping is from version k to version n + -> PositionMapping -- ^ The output mapping is from version k - 1 to version n +addOldDelta delta (PositionMapping pm) = PositionMapping (composeDelta pm delta) +-- TODO: We currently ignore the right hand side (if there is only text), as +-- that was what was done with lsp* 1.6 packages applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta -applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta - { toDelta = toCurrent r t <=< toDelta - , fromDelta = fromDelta <=< fromCurrent r t +applyChange PositionDelta{..} (TextDocumentContentChangeEvent (InL x)) = PositionDelta + { toDelta = toCurrent (x ^. L.range) (x ^. L.text) <=< toDelta + , fromDelta = fromDelta <=< fromCurrent (x ^. L.range) (x ^. L.text) } applyChange posMapping _ = posMapping @@ -214,9 +223,9 @@ line' -> PositionExact (Position (fromIntegral line') col) -- Construct a mapping between lines in the diff - -- -1 for unsucessful mapping + -- -1 for unsuccessful mapping go :: [Diff T.Text] -> Int -> Int -> ([Int], [Int]) go [] _ _ = ([],[]) - go (Both _ _ : xs) !lold !lnew = bimap (lnew :) (lold :) $ go xs (lold+1) (lnew+1) - go (First _ : xs) !lold !lnew = first (-1 :) $ go xs (lold+1) lnew - go (Second _ : xs) !lold !lnew = second (-1 :) $ go xs lold (lnew+1) + go (Both _ _ : xs) !glold !glnew = bimap (glnew :) (glold :) $ go xs (glold+1) (glnew+1) + go (First _ : xs) !glold !glnew = first (-1 :) $ go xs (glold+1) glnew + go (Second _ : xs) !glold !glnew = second (-1 :) $ go xs glold (glnew+1) diff --git a/src/Development/IDE/Core/Preprocessor.hs b/src/Development/IDE/Core/Preprocessor.hs --- a/src/Development/IDE/Core/Preprocessor.hs +++ b/src/Development/IDE/Core/Preprocessor.hs @@ -8,9 +8,9 @@ import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util as Util -import qualified Development.IDE.GHC.Util as Util import Development.IDE.GHC.CPP import Development.IDE.GHC.Orphans () +import qualified Development.IDE.GHC.Util as Util import Control.DeepSeq (NFData (rnf)) import Control.Exception (evaluate) @@ -28,12 +28,13 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import qualified GHC.LanguageExtensions as LangExt -import System.FilePath -import System.IO.Extra -#if MIN_VERSION_ghc(9,3,0) +import qualified GHC.Runtime.Loader as Loader import GHC.Utils.Logger (LogFlags (..)) -import GHC.Utils.Outputable (renderWithContext) +#if MIN_VERSION_ghc(9,13,0) +import GHC.Driver.Config.Parser (supportedLanguagePragmas) #endif +import System.FilePath +import System.IO.Extra -- | Given a file and some contents, apply any necessary preprocessors, -- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies. @@ -54,17 +55,17 @@ !src_hash <- liftIO $ Util.fingerprintFromStringBuffer contents -- Perform cpp - (opts, env) <- ExceptT $ parsePragmasIntoHscEnv env filename contents - let dflags = hsc_dflags env - let logger = hsc_logger env - (isOnDisk, contents, opts, env) <- + (opts, pEnv) <- ExceptT $ parsePragmasIntoHscEnv env filename contents + let dflags = hsc_dflags pEnv + let logger = hsc_logger pEnv + (newIsOnDisk, newContents, newOpts, newEnv) <- if not $ xopt LangExt.Cpp dflags then - return (isOnDisk, contents, opts, env) + return (isOnDisk, contents, opts, pEnv) else do cppLogs <- liftIO $ newIORef [] let newLogger = pushLogHook (const (logActionCompat $ logAction cppLogs)) logger - contents <- ExceptT - $ (Right <$> (runCpp (putLogHook newLogger env) filename + con <- ExceptT + $ (Right <$> (runCpp (putLogHook newLogger pEnv) filename $ if isOnDisk then Nothing else Just contents)) `catch` ( \(e :: Util.GhcException) -> do @@ -73,25 +74,21 @@ [] -> throw e diags -> return $ Left diags ) - (opts, env) <- ExceptT $ parsePragmasIntoHscEnv env filename contents - return (False, contents, opts, env) + (options, hscEnv) <- ExceptT $ parsePragmasIntoHscEnv pEnv filename con + return (False, con, options, hscEnv) -- Perform preprocessor if not $ gopt Opt_Pp dflags then - return (contents, opts, env, src_hash) + return (newContents, newOpts, newEnv, src_hash) else do - contents <- liftIO $ runPreprocessor env filename $ if isOnDisk then Nothing else Just contents - (opts, env) <- ExceptT $ parsePragmasIntoHscEnv env filename contents - return (contents, opts, env, src_hash) + con <- liftIO $ runPreprocessor newEnv filename $ if newIsOnDisk then Nothing else Just newContents + (options, hscEnv) <- ExceptT $ parsePragmasIntoHscEnv newEnv filename con + return (con, options, hscEnv, src_hash) where logAction :: IORef [CPPLog] -> LogActionCompat logAction cppLogs dflags _reason severity srcSpan _style msg = do -#if MIN_VERSION_ghc(9,3,0) - let log = CPPLog (fromMaybe SevWarning severity) srcSpan $ T.pack $ renderWithContext (log_default_user_context dflags) msg -#else - let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg -#endif - modifyIORef cppLogs (log :) + let cppLog = CPPLog (fromMaybe SevWarning severity) srcSpan $ T.pack $ renderWithContext (log_default_user_context dflags) msg + modifyIORef cppLogs (cppLog :) @@ -110,7 +107,7 @@ diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic] diagsFromCPPLogs filename logs = - map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $ + map (\d -> ideErrorFromLspDiag (cppDiagToDiagnostic d) (toNormalizedFilePath' filename) Nothing) $ go [] logs where -- On errors, CPP calls logAction with a real span for the initial log and @@ -118,12 +115,12 @@ -- informational log messages and attaches them to the initial log message. go :: [CPPDiag] -> [CPPLog] -> [CPPDiag] go acc [] = reverse $ map (\d -> d {cdMessage = reverse $ cdMessage d}) acc - go acc (CPPLog sev (RealSrcSpan span _) msg : logs) = - let diag = CPPDiag (realSrcSpanToRange span) (toDSeverity sev) [msg] - in go (diag : acc) logs - go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) = - go (diag {cdMessage = msg : cdMessage diag} : diags) logs - go [] (CPPLog _sev (UnhelpfulSpan _) _msg : logs) = go [] logs + go acc (CPPLog sev (RealSrcSpan rSpan _) msg : gLogs) = + let diag = CPPDiag (realSrcSpanToRange rSpan) (toDSeverity sev) [msg] + in go (diag : acc) gLogs + go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : gLogs) = + go (diag {cdMessage = msg : cdMessage diag} : diags) gLogs + go [] (CPPLog _sev (UnhelpfulSpan _) _msg : gLogs) = go [] gLogs cppDiagToDiagnostic :: CPPDiag -> Diagnostic cppDiagToDiagnostic d = Diagnostic @@ -133,7 +130,9 @@ _source = Just "CPP", _message = T.unlines $ cdMessage d, _relatedInformation = Nothing, - _tags = Nothing + _tags = Nothing, + _codeDescription = Nothing, + _data_ = Nothing } @@ -148,17 +147,22 @@ -> Util.StringBuffer -> IO (Either [FileDiagnostic] ([String], HscEnv)) parsePragmasIntoHscEnv env fp contents = catchSrcErrors dflags0 "pragmas" $ do -#if MIN_VERSION_ghc(9,3,0) - let (_warns,opts) = getOptions (initParserOpts dflags0) contents fp +#if MIN_VERSION_ghc(9,13,0) + let supportedExts = supportedLanguagePragmas dflags0 + let (_warns,opts) = getOptions (initParserOpts dflags0) supportedExts contents fp #else - let opts = getOptions dflags0 contents fp + let (_warns,opts) = getOptions (initParserOpts dflags0) contents fp #endif -- Force bits that might keep the dflags and stringBuffer alive unnecessarily evaluate $ rnf opts +#if MIN_VERSION_ghc(9,13,0) + (dflags, _, _) <- parseDynamicFilePragma (hsc_logger env) dflags0 opts +#else (dflags, _, _) <- parseDynamicFilePragma dflags0 opts - hsc_env' <- initializePlugins (hscSetFlags dflags env) +#endif + hsc_env' <- Loader.initializePlugins (hscSetFlags dflags env) return (map unLoc opts, hscSetFlags (disableWarningsAsErrors $ hsc_dflags hsc_env') hsc_env') where dflags0 = hsc_dflags env @@ -194,17 +198,17 @@ -- | Run CPP on a file runCpp :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer -runCpp env0 filename contents = withTempDir $ \dir -> do +runCpp env0 filename mbContents = withTempDir $ \dir -> do let out = dir takeFileName filename <.> "out" let dflags1 = addOptP "-D__GHCIDE__" (hsc_dflags env0) let env1 = hscSetFlags dflags1 env0 - case contents of + case mbContents of Nothing -> do -- Happy case, file is not modified, so run CPP on it in-place -- which also makes things like relative #include files work -- and means location information is correct - doCpp env1 True filename out + doCpp env1 filename out liftIO $ Util.hGetStringBuffer out Just contents -> do @@ -218,26 +222,26 @@ let inp = dir "___GHCIDE_MAGIC___" withBinaryFile inp WriteMode $ \h -> hPutStringBuffer h contents - doCpp env2 True inp out + doCpp env2 inp out -- Fix up the filename in lines like: -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___" let tweak x - | Just x <- stripPrefix "# " x - , "___GHCIDE_MAGIC___" `isInfixOf` x - , let num = takeWhile (not . isSpace) x + | Just y <- stripPrefix "# " x + , "___GHCIDE_MAGIC___" `isInfixOf` y + , let num = takeWhile (not . isSpace) y -- important to use /, and never \ for paths, even on Windows, since then C escapes them -- and GHC gets all confused - = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\"" + = "# " <> num <> " \"" <> map (\z -> if isPathSeparator z then '/' else z) filename <> "\"" | otherwise = x Util.stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out -- | Run a preprocessor on a file runPreprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer -runPreprocessor env filename contents = withTempDir $ \dir -> do +runPreprocessor env filename mbContents = withTempDir $ \dir -> do let out = dir takeFileName filename <.> "out" - inp <- case contents of + inp <- case mbContents of Nothing -> return filename Just contents -> do let inp = dir takeFileName filename <.> "hs" diff --git a/src/Development/IDE/Core/ProgressReporting.hs b/src/Development/IDE/Core/ProgressReporting.hs --- a/src/Development/IDE/Core/ProgressReporting.hs +++ b/src/Development/IDE/Core/ProgressReporting.hs @@ -1,202 +1,236 @@ -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + module Development.IDE.Core.ProgressReporting - ( ProgressEvent(..) - , ProgressReporting(..) - , noProgressReporting - , delayedProgressReporting - -- utilities, reexported for use in Core.Shake - , mRunLspT - , mRunLspTCallback - -- for tests - , recordProgress - , InProgressState(..) + ( ProgressEvent (..), + PerFileProgressReporting (..), + ProgressReporting, + noPerFileProgressReporting, + progressReporting, + progressReportingNoTrace, + -- utilities, reexported for use in Core.Shake + mRunLspT, + mRunLspTCallback, + -- for tests + recordProgress, + InProgressState (..), + progressStop, + progressUpdate ) - where +where -import Control.Concurrent.Async -import Control.Concurrent.STM.Stats (TVar, atomicallyNamed, - modifyTVar', newTVarIO, - readTVarIO) -import Control.Concurrent.Strict -import Control.Monad.Extra +import Control.Concurrent.STM (STM) +import Control.Concurrent.STM.Stats (TVar, atomically, + atomicallyNamed, modifyTVar', + newTVarIO, readTVar, retry) +import Control.Concurrent.Strict (modifyVar_, newVar, + threadDelay) +import Control.Monad.Extra hiding (loop) import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) -import Data.Foldable (for_) import Data.Functor (($>)) import qualified Data.Text as T -import Data.Unique import Development.IDE.GHC.Orphans () -import Development.IDE.Graph hiding (ShakeValue) import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified Focus +import Language.LSP.Protocol.Types +import Language.LSP.Server (ProgressAmount (..), + ProgressCancellable (..), + withProgress) import qualified Language.LSP.Server as LSP -import Language.LSP.Types -import qualified Language.LSP.Types as LSP import qualified StmContainers.Map as STM -import System.Time.Extra -import UnliftIO.Exception (bracket_) +import UnliftIO (Async, async, bracket, cancel) data ProgressEvent - = KickStarted - | KickCompleted + = ProgressNewStarted + | ProgressCompleted + | ProgressStarted -data ProgressReporting = ProgressReporting - { progressUpdate :: ProgressEvent -> IO () - , inProgress :: forall a. NormalizedFilePath -> Action a -> Action a - , progressStop :: IO () +data ProgressReporting = ProgressReporting + { _progressUpdate :: ProgressEvent -> IO (), + _progressStop :: IO () + -- ^ we are using IO here because creating and stopping the `ProgressReporting` + -- is different from how we use it. } -noProgressReporting :: IO ProgressReporting -noProgressReporting = return $ ProgressReporting - { progressUpdate = const $ pure () - , inProgress = const id - , progressStop = pure () +data PerFileProgressReporting = PerFileProgressReporting + { + inProgress :: forall a. NormalizedFilePath -> IO a -> IO a, + -- ^ see Note [ProgressReporting API and InProgressState] + progressReportingInner :: ProgressReporting } +class ProgressReporter a where + progressUpdate :: a -> ProgressEvent -> IO () + progressStop :: a -> IO () + +instance ProgressReporter ProgressReporting where + progressUpdate = _progressUpdate + progressStop = _progressStop + +instance ProgressReporter PerFileProgressReporting where + progressUpdate = _progressUpdate . progressReportingInner + progressStop = _progressStop . progressReportingInner + +{- Note [ProgressReporting API and InProgressState] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The progress of tasks can be tracked in two ways: + +1. `ProgressReporting`: we have an internal state that actively tracks the progress. + Changes to the progress are made directly to this state. + +2. `ProgressReporting`: there is an external state that tracks the progress. + The external state is converted into an STM Int for the purpose of reporting progress. + +The `inProgress` function is only useful when we are using `ProgressReporting`. +-} + +noProgressReporting :: ProgressReporting +noProgressReporting = ProgressReporting + { _progressUpdate = const $ pure (), + _progressStop = pure () + } +noPerFileProgressReporting :: IO PerFileProgressReporting +noPerFileProgressReporting = + return $ + PerFileProgressReporting + { inProgress = const id, + progressReportingInner = noProgressReporting + } + -- | State used in 'delayedProgressReporting' data State - = NotStarted - | Stopped - | Running (Async ()) + = NotStarted + | Stopped + | Running (Async ()) -- | State transitions used in 'delayedProgressReporting' data Transition = Event ProgressEvent | StopProgress -updateState :: IO (Async ()) -> Transition -> State -> IO State -updateState _ _ Stopped = pure Stopped -updateState start (Event KickStarted) NotStarted = Running <$> start -updateState start (Event KickStarted) (Running a) = cancel a >> Running <$> start -updateState _ (Event KickCompleted) (Running a) = cancel a $> NotStarted -updateState _ (Event KickCompleted) st = pure st -updateState _ StopProgress (Running a) = cancel a $> Stopped -updateState _ StopProgress st = pure st +updateState :: IO () -> Transition -> State -> IO State +updateState _ _ Stopped = pure Stopped +updateState start (Event ProgressNewStarted) NotStarted = Running <$> async start +updateState start (Event ProgressNewStarted) (Running job) = cancel job >> Running <$> async start +updateState start (Event ProgressStarted) NotStarted = Running <$> async start +updateState _ (Event ProgressStarted) (Running job) = return (Running job) +updateState _ (Event ProgressCompleted) (Running job) = cancel job $> NotStarted +updateState _ (Event ProgressCompleted) st = pure st +updateState _ StopProgress (Running job) = cancel job $> Stopped +updateState _ StopProgress st = pure st -- | Data structure to track progress across the project -data InProgressState = InProgressState - { todoVar :: TVar Int -- ^ Number of files to do - , doneVar :: TVar Int -- ^ Number of files done - , currentVar :: STM.Map NormalizedFilePath Int - } +-- see Note [ProgressReporting API and InProgressState] +data InProgressState + = InProgressState + { -- | Number of files to do + todoVar :: TVar Int, + -- | Number of files done + doneVar :: TVar Int, + currentVar :: STM.Map NormalizedFilePath Int + } newInProgress :: IO InProgressState newInProgress = InProgressState <$> newTVarIO 0 <*> newTVarIO 0 <*> STM.newIO recordProgress :: InProgressState -> NormalizedFilePath -> (Int -> Int) -> IO () -recordProgress InProgressState{..} file shift = do - (prev, new) <- atomicallyNamed "recordProgress" $ STM.focus alterPrevAndNew file currentVar - atomicallyNamed "recordProgress2" $ do - case (prev,new) of - (Nothing,0) -> modifyTVar' doneVar (+1) >> modifyTVar' todoVar (+1) - (Nothing,_) -> modifyTVar' todoVar (+1) - (Just 0, 0) -> pure () - (Just 0, _) -> modifyTVar' doneVar pred - (Just _, 0) -> modifyTVar' doneVar (+1) - (Just _, _) -> pure() +recordProgress InProgressState {..} file shift = do + (prev, new) <- atomicallyNamed "recordProgress" $ STM.focus alterPrevAndNew file currentVar + atomicallyNamed "recordProgress2" $ case (prev, new) of + (Nothing, 0) -> modifyTVar' doneVar (+ 1) >> modifyTVar' todoVar (+ 1) + (Nothing, _) -> modifyTVar' todoVar (+ 1) + (Just 0, 0) -> pure () + (Just 0, _) -> modifyTVar' doneVar pred + (Just _, 0) -> modifyTVar' doneVar (+ 1) + (Just _, _) -> pure () where alterPrevAndNew = do - prev <- Focus.lookup - Focus.alter alter - new <- Focus.lookupWithDefault 0 - return (prev, new) + prev <- Focus.lookup + Focus.alter alter + new <- Focus.lookupWithDefault 0 + return (prev, new) alter x = let x' = maybe (shift 0) shift x in Just x' --- | A 'ProgressReporting' that enqueues Begin and End notifications in a new --- thread, with a grace period (nothing will be sent if 'KickCompleted' arrives --- before the end of the grace period). -delayedProgressReporting - :: Seconds -- ^ Grace period before starting - -> Seconds -- ^ sampling delay - -> Maybe (LSP.LanguageContextEnv c) - -> ProgressReportingStyle - -> IO ProgressReporting -delayedProgressReporting before after Nothing optProgressStyle = noProgressReporting -delayedProgressReporting before after (Just lspEnv) optProgressStyle = do - inProgressState <- newInProgress - progressState <- newVar NotStarted - let progressUpdate event = updateStateVar $ Event event - progressStop = updateStateVar StopProgress - updateStateVar = modifyVar_ progressState . updateState (lspShakeProgress inProgressState) - inProgress = updateStateForFile inProgressState - return ProgressReporting{..} - where - lspShakeProgress InProgressState{..} = do - -- first sleep a bit, so we only show progress messages if it's going to take - -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes) - liftIO $ sleep before - u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique +-- | `progressReportingNoTrace` initiates a new progress reporting session. +-- It functions similarly to `progressReporting`, but it utilizes an external state for progress tracking. +-- Refer to Note [ProgressReporting API and InProgressState] for more details. +progressReportingNoTrace :: + STM Int -> + STM Int -> + Maybe (LSP.LanguageContextEnv c) -> + T.Text -> + ProgressReportingStyle -> + IO ProgressReporting +progressReportingNoTrace _ _ Nothing _title _optProgressStyle = return noProgressReporting +progressReportingNoTrace todo done (Just lspEnv) title optProgressStyle = do + progressState <- newVar NotStarted + let _progressUpdate event = liftIO $ updateStateVar $ Event event + _progressStop = updateStateVar StopProgress + updateStateVar = modifyVar_ progressState . updateState (progressCounter lspEnv title optProgressStyle todo done) + return ProgressReporting {..} - b <- liftIO newBarrier - void $ LSP.runLspT lspEnv $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate - LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b - liftIO $ async $ do - ready <- waitBarrier b - LSP.runLspT lspEnv $ for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0) - where - start id = LSP.sendNotification LSP.SProgress $ - LSP.ProgressParams - { _token = id - , _value = LSP.Begin $ WorkDoneProgressBeginParams - { _title = "Processing" - , _cancellable = Nothing - , _message = Nothing - , _percentage = Nothing - } - } - stop id = LSP.sendNotification LSP.SProgress - LSP.ProgressParams - { _token = id - , _value = LSP.End WorkDoneProgressEndParams - { _message = Nothing - } - } - loop _ _ | optProgressStyle == NoProgress = - forever $ liftIO $ threadDelay maxBound - loop id prevPct = do - done <- liftIO $ readTVarIO doneVar - todo <- liftIO $ readTVarIO todoVar - liftIO $ sleep after - if todo == 0 then loop id 0 else do - let - nextFrac :: Double - nextFrac = fromIntegral done / fromIntegral todo - nextPct :: UInt - nextPct = floor $ 100 * nextFrac - when (nextPct /= prevPct) $ - LSP.sendNotification LSP.SProgress $ - LSP.ProgressParams - { _token = id - , _value = LSP.Report $ case optProgressStyle of - Explicit -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Just $ T.pack $ show done <> "/" <> show todo - , _percentage = Nothing - } - Percentage -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing - , _message = Nothing - , _percentage = Just nextPct - } - NoProgress -> error "unreachable" - } - loop id nextPct +-- | `progressReporting` initiates a new progress reporting session. +-- It necessitates the active tracking of progress using the `inProgress` function. +-- Refer to Note [ProgressReporting API and InProgressState] for more details. +progressReporting :: + Maybe (LSP.LanguageContextEnv c) -> + T.Text -> + ProgressReportingStyle -> + IO PerFileProgressReporting +progressReporting Nothing _title _optProgressStyle = noPerFileProgressReporting +progressReporting (Just lspEnv) title optProgressStyle = do + inProgressState <- newInProgress + progressReportingInner <- progressReportingNoTrace (readTVar $ todoVar inProgressState) + (readTVar $ doneVar inProgressState) (Just lspEnv) title optProgressStyle + let + inProgress :: NormalizedFilePath -> IO a -> IO a + inProgress = updateStateForFile inProgressState + return PerFileProgressReporting {..} + where + updateStateForFile inProgress file = UnliftIO.bracket (liftIO $ f succ) (const $ liftIO $ f pred) . const + where + -- This functions are deliberately eta-expanded to avoid space leaks. + -- Do not remove the eta-expansion without profiling a session with at + -- least 1000 modifications. - updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const - -- This functions are deliberately eta-expanded to avoid space leaks. - -- Do not remove the eta-expansion without profiling a session with at - -- least 1000 modifications. - where - f shift = recordProgress inProgress file shift + f = recordProgress inProgress file -mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m () +-- Kill this to complete the progress session +progressCounter :: + LSP.LanguageContextEnv c -> + T.Text -> + ProgressReportingStyle -> + STM Int -> + STM Int -> + IO () +progressCounter lspEnv title optProgressStyle getTodo getDone = + LSP.runLspT lspEnv $ withProgress title Nothing NotCancellable $ \update -> loop update 0 + where + loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound + loop update prevPct = do + (todo, done, nextPct) <- liftIO $ atomically $ do + todo <- getTodo + done <- getDone + let nextFrac :: Double + nextFrac = if todo == 0 then 0 else fromIntegral done / fromIntegral todo + nextPct :: UInt + nextPct = floor $ 100 * nextFrac + when (nextPct == prevPct) retry + pure (todo, done, nextPct) + + _ <- update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo)) + loop update nextPct + +mRunLspT :: (Applicative m) => Maybe (LSP.LanguageContextEnv c) -> LSP.LspT c m () -> m () mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f mRunLspT Nothing _ = pure () -mRunLspTCallback :: Monad m - => Maybe (LSP.LanguageContextEnv c) - -> (LSP.LspT c m a -> LSP.LspT c m a) - -> m a - -> m a +mRunLspTCallback :: + (Monad m) => + Maybe (LSP.LanguageContextEnv c) -> + (LSP.LspT c m a -> LSP.LspT c m a) -> + m a -> + m a mRunLspTCallback (Just lspEnv) f g = LSP.runLspT lspEnv $ f (lift g) mRunLspTCallback Nothing _ g = g diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -1,8 +1,8 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} @@ -17,7 +17,7 @@ ) where import Control.DeepSeq -import Control.Exception (assert) +import qualified Control.Exception as E import Control.Lens import Data.Aeson.Types (Value) import Data.Hashable @@ -34,15 +34,21 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq) import Development.IDE.Types.KnownTargets import GHC.Generics (Generic) +import GHC.Iface.Ext.Types (HieASTs, + TypeIndex) +import GHC.Iface.Ext.Utils (RefMap) import Data.ByteString (ByteString) -import Data.Text (Text) +import Data.Text.Utf16.Rope.Mixed (Rope) import Development.IDE.Import.FindImports (ArtifactsLocation) import Development.IDE.Spans.Common import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Diagnostics +import GHC.Driver.Errors.Types (WarningMessages) import GHC.Serialized (Serialized) -import Language.LSP.Types (Int32, +import Ide.Logger (Pretty (..), + viaShow) +import Language.LSP.Protocol.Types (Int32, NormalizedFilePath) data LinkableType = ObjectLinkable | BCOLinkable @@ -69,13 +75,14 @@ -- all comments included using Opt_KeepRawTokenStream type instance RuleResult GetParsedModuleWithComments = ParsedModule --- | The dependency information produced by following the imports recursively. --- This rule will succeed even if there is an error, e.g., a module could not be located, --- a module could not be parsed or an import cycle. -type instance RuleResult GetDependencyInformation = DependencyInformation - type instance RuleResult GetModuleGraph = DependencyInformation +-- | it only compute the fingerprint of the module graph for a file and its dependencies +-- we need this to trigger recompilation when the sub module graph for a file changes +type instance RuleResult GetModuleGraphTransDepsFingerprints = Fingerprint +type instance RuleResult GetModuleGraphTransReverseDepsFingerprints = Fingerprint +type instance RuleResult GetModuleGraphImmediateReverseDepsFingerprints = Fingerprint + data GetKnownTargets = GetKnownTargets deriving (Show, Generic, Eq, Ord) instance Hashable GetKnownTargets @@ -86,7 +93,7 @@ type instance RuleResult GenerateCore = ModGuts data GenerateCore = GenerateCore - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GenerateCore instance NFData GenerateCore @@ -106,12 +113,12 @@ rnf = rwhnf data GetLinkable = GetLinkable - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetLinkable instance NFData GetLinkable data GetImportMap = GetImportMap - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetImportMap instance NFData GetImportMap @@ -161,6 +168,8 @@ -- ^ Which modules did we need at runtime while compiling this file? -- Used for recompilation checking in the presence of TH -- Stores the hash of their core file + , tmrWarnings :: WarningMessages + -- ^ Structured warnings for this module. } instance Show TcModuleResult where show = show . pm_mod_summary . tmrParsed @@ -192,9 +201,9 @@ mkHiFileResult :: ModSummary -> ModIface -> ModDetails -> ModuleEnv ByteString -> Maybe (CoreFile, ByteString) -> HiFileResult mkHiFileResult hirModSummary hirModIface hirModDetails hirRuntimeModules hirCoreFp = - assert (case hirCoreFp of Just (CoreFile{cf_iface_hash}, _) - -> getModuleHash hirModIface == cf_iface_hash - _ -> True) + E.assert (case hirCoreFp of + Just (CoreFile{cf_iface_hash}, _) -> getModuleHash hirModIface == cf_iface_hash + _ -> True) HiFileResult{..} where hirIfaceFp = fingerprintToBS . getModuleHash $ hirModIface -- will always be two bytes @@ -243,14 +252,20 @@ -- | A IntervalMap telling us what is in scope at each point type instance RuleResult GetBindings = Bindings -data DocAndKindMap = DKMap {getDocMap :: !DocMap, getKindMap :: !KindMap} -instance NFData DocAndKindMap where - rnf (DKMap a b) = rwhnf a `seq` rwhnf b +data DocAndTyThingMap = DKMap + { getDocMap :: !DocMap + -- ^ Docs for declarations: functions, data types, instances, methods, etc + , getTyThingMap :: !TyThingMap + , getArgDocMap :: !ArgDocMap + -- ^ Docs for arguments, e.g., function arguments and method arguments + } +instance NFData DocAndTyThingMap where + rnf (DKMap a b c) = rwhnf a `seq` rwhnf b `seq` rwhnf c -instance Show DocAndKindMap where +instance Show DocAndTyThingMap where show = const "docmap" -type instance RuleResult GetDocMap = DocAndKindMap +type instance RuleResult GetDocMap = DocAndTyThingMap -- | A GHC session that we reuse. type instance RuleResult GhcSession = HscEnvEq @@ -262,8 +277,8 @@ -- | Resolve the imports in a module to the file path of a module in the same package type instance RuleResult GetLocatedImports = [(Located ModuleName, Maybe ArtifactsLocation)] --- | This rule is used to report import cycles. It depends on GetDependencyInformation. --- We cannot report the cycles directly from GetDependencyInformation since +-- | This rule is used to report import cycles. It depends on GetModuleGraph. +-- We cannot report the cycles directly from GetModuleGraph since -- we can only report diagnostics for the current file. type instance RuleResult ReportImportCycles = () @@ -279,10 +294,12 @@ type instance RuleResult GetModIface = HiFileResult -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk. -type instance RuleResult GetFileContents = (FileVersion, Maybe Text) +type instance RuleResult GetFileContents = (FileVersion, Maybe Rope) type instance RuleResult GetFileExists = Bool +type instance RuleResult GetFileHash = Fingerprint + type instance RuleResult AddWatchedFile = Bool @@ -308,6 +325,13 @@ instance NFData GetModificationTime +data GetPhysicalModificationTime = GetPhysicalModificationTime + deriving (Generic, Show, Eq) + deriving anyclass (Hashable, NFData) + +-- | Get the modification time of a file on disk, ignoring any version in the VFS. +type instance RuleResult GetPhysicalModificationTime = FileVersion + pattern GetModificationTime :: GetModificationTime pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True} @@ -333,21 +357,30 @@ instance NFData GetFileContents data GetFileExists = GetFileExists - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance NFData GetFileExists instance Hashable GetFileExists +data GetFileHash = GetFileHash + deriving (Eq, Show, Generic) + +instance NFData GetFileHash +instance Hashable GetFileHash + data FileOfInterestStatus = OnDisk | Modified { firstOpen :: !Bool -- ^ was this file just opened } - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable FileOfInterestStatus instance NFData FileOfInterestStatus +instance Pretty FileOfInterestStatus where + pretty = viaShow + data IsFileOfInterestResult = NotFOI | IsFOI FileOfInterestStatus - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable IsFileOfInterestResult instance NFData IsFileOfInterestResult @@ -379,17 +412,17 @@ type instance RuleResult GetModSummaryWithoutTimestamps = ModSummaryResult data GetParsedModule = GetParsedModule - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetParsedModule instance NFData GetParsedModule data GetParsedModuleWithComments = GetParsedModuleWithComments - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetParsedModuleWithComments instance NFData GetParsedModuleWithComments data GetLocatedImports = GetLocatedImports - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetLocatedImports instance NFData GetLocatedImports @@ -397,47 +430,57 @@ type instance RuleResult NeedsCompilation = Maybe LinkableType data NeedsCompilation = NeedsCompilation - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable NeedsCompilation instance NFData NeedsCompilation -data GetDependencyInformation = GetDependencyInformation - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetDependencyInformation -instance NFData GetDependencyInformation - data GetModuleGraph = GetModuleGraph - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetModuleGraph instance NFData GetModuleGraph +data GetModuleGraphTransDepsFingerprints = GetModuleGraphTransDepsFingerprints + deriving (Eq, Show, Generic) +instance Hashable GetModuleGraphTransDepsFingerprints +instance NFData GetModuleGraphTransDepsFingerprints + +data GetModuleGraphTransReverseDepsFingerprints = GetModuleGraphTransReverseDepsFingerprints + deriving (Eq, Show, Generic) +instance Hashable GetModuleGraphTransReverseDepsFingerprints +instance NFData GetModuleGraphTransReverseDepsFingerprints + +data GetModuleGraphImmediateReverseDepsFingerprints = GetModuleGraphImmediateReverseDepsFingerprints + deriving (Eq, Show, Generic) +instance Hashable GetModuleGraphImmediateReverseDepsFingerprints +instance NFData GetModuleGraphImmediateReverseDepsFingerprints + data ReportImportCycles = ReportImportCycles - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable ReportImportCycles instance NFData ReportImportCycles data TypeCheck = TypeCheck - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable TypeCheck instance NFData TypeCheck data GetDocMap = GetDocMap - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetDocMap instance NFData GetDocMap data GetHieAst = GetHieAst - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetHieAst instance NFData GetHieAst data GetBindings = GetBindings - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetBindings instance NFData GetBindings data GhcSession = GhcSession - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GhcSession instance NFData GhcSession @@ -446,7 +489,7 @@ -- Required for interactive evaluation, but leads to more cache invalidations fullModSummary :: Bool } - deriving newtype (Eq, Typeable, Hashable, NFData) + deriving newtype (Eq, Hashable, NFData) instance Show GhcSessionDeps where show (GhcSessionDeps_ False) = "GhcSessionDeps" @@ -456,44 +499,45 @@ pattern GhcSessionDeps = GhcSessionDeps_ False data GetModIfaceFromDisk = GetModIfaceFromDisk - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetModIfaceFromDisk instance NFData GetModIfaceFromDisk data GetModIfaceFromDiskAndIndex = GetModIfaceFromDiskAndIndex - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetModIfaceFromDiskAndIndex instance NFData GetModIfaceFromDiskAndIndex data GetModIface = GetModIface - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetModIface instance NFData GetModIface data IsFileOfInterest = IsFileOfInterest - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable IsFileOfInterest instance NFData IsFileOfInterest data GetModSummaryWithoutTimestamps = GetModSummaryWithoutTimestamps - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetModSummaryWithoutTimestamps instance NFData GetModSummaryWithoutTimestamps data GetModSummary = GetModSummary - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetModSummary instance NFData GetModSummary --- | Get the vscode client settings stored in the ide state +-- See Note [Client configuration in Rules] +-- | Get the client config stored in the ide state data GetClientSettings = GetClientSettings - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable GetClientSettings instance NFData GetClientSettings type instance RuleResult GetClientSettings = Hashed (Maybe Value) -data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Typeable, Generic) +data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Generic) instance Hashable AddWatchedFile instance NFData AddWatchedFile @@ -513,10 +557,41 @@ instance Show IdeGhcSession where show _ = "IdeGhcSession" instance NFData IdeGhcSession where rnf !_ = () -data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Typeable, Generic) +data GhcSessionIO = GhcSessionIO deriving (Eq, Show, Generic) instance Hashable GhcSessionIO instance NFData GhcSessionIO makeLensesWith (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) ''Splices + +{- Note [Client configuration in Rules] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The LSP client configuration is stored by `lsp` for us, and is accesible in +handlers through the LspT monad. + +This is all well and good, but what if we want to write a Rule that depends +on the configuration? For example, we might have a plugin that provides +diagnostics - if the configuration changes to turn off that plugin, then +we need to invalidate the Rule producing the diagnostics so that they go +away. More broadly, any time we define a Rule that really depends on the +configuration, such that the dependency needs to be tracked and the Rule +invalidated when the configuration changes, we have a problem. + +The solution is that we have to mirror the configuration into the state +that our build system knows about. That means that: +- We have a parallel record of the state in 'IdeConfiguration' +- We install a callback so that when the config changes we can update the +'IdeConfiguration' and mark the rule as dirty. + +Then we can define a Rule that gets the configuration, and build Actions +on top of that that behave properly. However, these should really only +be used if you need the dependency tracking - for normal usage in handlers +the config can simply be accessed directly from LspT. + +TODO(michaelpj): this is me writing down what I think the logic is, but +it doesn't make much sense to me. In particular, we *can* get the LspT +in an Action. So I don't know why we need to store it twice. We would +still need to invalidate the Rule otherwise we won't know it's changed, +though. See https://github.com/haskell/ghcide/pull/731 for some context. +-} diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -3,7 +3,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} -- | A Shake implementation of the compiler service, built @@ -12,29 +11,25 @@ module Development.IDE.Core.Rules( -- * Types IdeState, GetParsedModule(..), TransitiveDependencies(..), - Priority(..), GhcSessionIO(..), GetClientSettings(..), + GhcSessionIO(..), GetClientSettings(..), -- * Functions - priorityTypeCheck, - priorityGenerateCore, - priorityFilesOfInterest, runAction, toIdeResult, defineNoFile, defineEarlyCutOffNoFile, mainRule, RulesConfig(..), - getDependencies, getParsedModule, getParsedModuleWithComments, getClientConfigAction, usePropertyAction, + usePropertyByPathAction, getHieFile, -- * Rules CompiledLinkables(..), getParsedModuleRule, getParsedModuleWithCommentsRule, getLocatedImportsRule, - getDependencyInformationRule, reportImportCyclesRule, typeCheckRule, getDocMapRule, @@ -48,7 +43,6 @@ getHieAstsRule, getBindingsRule, needsCompilationRule, - computeLinkableTypeForDynFlags, generateCoreRule, getImportMapRule, regenerateHiFile, @@ -57,64 +51,77 @@ typeCheckRuleDefinition, getRebuildCount, getSourceFileSource, + currentLinkables, GhcSessionDepsConfig(..), Log(..), DisplayTHWarning(..), ) where -import Control.Concurrent.Async (concurrently) +import Control.Applicative +import Control.Concurrent.STM.Stats (atomically) +import Control.Concurrent.STM.TVar import Control.Concurrent.Strict import Control.DeepSeq +import Control.Exception (evaluate) import Control.Exception.Safe +import Control.Lens ((%~), (&), (.~)) import Control.Monad.Extra +import Control.Monad.IO.Unlift import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Except (ExceptT, except, runExceptT) import Control.Monad.Trans.Maybe -import Data.Aeson (Result (Success), - toJSON) -import qualified Data.Aeson.Types as A +import Data.Aeson (toJSON) import qualified Data.Binary as B import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Coerce +import Data.Default (Default, def) import Data.Foldable +import Data.Hashable import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HashSet -import Data.Hashable -import Data.IORef -import Control.Concurrent.STM.TVar import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap +import Data.IORef import Data.List +import Data.List.Extra (nubOrd, nubOrdOn) import qualified Data.Map as M import Data.Maybe -import qualified Data.Text.Utf16.Rope as Rope -import qualified Data.Set as Set +import Data.Proxy import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Text.Utf16.Rope.Mixed as Rope import Data.Time (UTCTime (..)) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Tuple.Extra import Data.Typeable (cast) import Development.IDE.Core.Compile -import Development.IDE.Core.FileExists hiding (LogShake, Log) +import Development.IDE.Core.FileExists hiding (Log, + LogShake) import Development.IDE.Core.FileStore (getFileContents, getModTime) import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.OfInterest hiding (LogShake, Log) +import Development.IDE.Core.OfInterest hiding (Log, + LogShake) import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes -import Development.IDE.Core.Service hiding (LogShake, Log) -import Development.IDE.Core.Shake hiding (Log) -import Development.IDE.GHC.Compat.Env +import Development.IDE.Core.Service hiding (Log, + LogShake) +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat hiding - (vcat, nest, parseModule, - TargetId(..), - loadInterface, + (TargetId (..), Var, + loadInterface, + nest, + parseModule, + settings, vcat, (<+>)) -import qualified Development.IDE.GHC.Compat as Compat hiding (vcat, nest) +import qualified Development.IDE.GHC.Compat as Compat hiding + (nest, + vcat) import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error import Development.IDE.GHC.Util hiding @@ -129,38 +136,52 @@ import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Location import Development.IDE.Types.Options +import qualified Development.IDE.Types.Shake as Shake +import GHC.Iface.Ext.Types (HieASTs (..)) +import GHC.Iface.Ext.Utils (generateReferencesMap) import qualified GHC.LanguageExtensions as LangExt +#if MIN_VERSION_ghc(9,13,0) +import GHC.Types.PkgQual (PkgQual (NoPkgQual)) +import GHC.Types.Basic (ImportLevel (..)) +import GHC.Unit.Types (GenWithIsBoot(..)) +import GHC.Unit.Module.Graph (mkModuleEdge) +import GHC.Unit.Module.ModNodeKey (mnkModuleName) +#endif +import HIE.Bios.Ghc.Gap (hostIsDynamic) import qualified HieDb +import Ide.Logger (Pretty (pretty), + Recorder, + WithPriority, + cmapWithPrio, + logWith, nest, + vcat, (<+>)) +import qualified Ide.Logger as Logger import Ide.Plugin.Config -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (SMethod (SCustomMethod, SWindowShowMessage), ShowMessageParams (ShowMessageParams), MessageType (MtInfo)) -import Language.LSP.VFS -import System.Directory (makeAbsolute, doesFileExist) -import Data.Default (def, Default) import Ide.Plugin.Properties (HasProperty, + HasPropertyByPath, + KeyNamePath, KeyNameProxy, Properties, ToHsType, - useProperty) -import Ide.PluginUtils (configForPlugin) + useProperty, + usePropertyByPath) import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser), - PluginId, PluginDescriptor (pluginId), IdePlugins (IdePlugins)) -import Control.Concurrent.STM.Stats (atomically) -import Language.LSP.Server (LspT) -import System.Info.Extra (isWindows) -import HIE.Bios.Ghc.Gap (hostIsDynamic) -import Development.IDE.Types.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat) -import qualified Development.IDE.Core.Shake as Shake -import qualified Development.IDE.Types.Logger as Logger -import qualified Development.IDE.Types.Shake as Shake -import Development.IDE.GHC.CoreFile -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Control.Monad.IO.Unlift -#if MIN_VERSION_ghc(9,3,0) -import GHC.Unit.Module.Graph -import GHC.Unit.Env -#endif + PluginId, getVirtualFileFromVFS) +import qualified Language.LSP.Protocol.Lens as JL +import Language.LSP.Protocol.Message (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage)) +import Language.LSP.Protocol.Types (MessageType (MessageType_Info), + ShowMessageParams (ShowMessageParams)) +import Language.LSP.Server (LspT) +import qualified Language.LSP.Server as LSP +import Language.LSP.VFS +import Prelude hiding (mod) +import System.Directory (doesFileExist) +import System.Info.Extra (isWindows) + +import qualified Data.IntMap as IM +import GHC.Fingerprint + data Log = LogShake Shake.Log | LogReindexingHieFile !NormalizedFilePath @@ -172,7 +193,7 @@ instance Pretty Log where pretty = \case - LogShake log -> pretty log + LogShake msg -> pretty msg LogReindexingHieFile path -> "Re-indexing hie file for" <+> pretty (fromNormalizedFilePath path) LogLoadingHieFile path -> @@ -205,18 +226,15 @@ ------------------------------------------------------------ -- Exposed API ------------------------------------------------------------ --- | Get all transitive file dependencies of a given module. --- Does not include the file itself. -getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath]) -getDependencies file = - fmap transitiveModuleDeps . (`transitiveDeps` file) <$> use_ GetDependencyInformation file +-- TODO: rename +-- TODO: return text --> return rope getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString getSourceFileSource nfp = do - (_, msource) <- getFileContents nfp + msource <- getFileContents nfp case msource of Nothing -> liftIO $ BS.readFile (fromNormalizedFilePath nfp) - Just source -> pure $ T.encodeUtf8 source + Just source -> pure $ T.encodeUtf8 $ Rope.toText source -- | Parse the contents of a haskell file. getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule) @@ -231,15 +249,6 @@ -- Rules -- These typically go from key to value and are oracles. -priorityTypeCheck :: Priority -priorityTypeCheck = Priority 0 - -priorityGenerateCore :: Priority -priorityGenerateCore = Priority (-1) - -priorityFilesOfInterest :: Priority -priorityFilesOfInterest = Priority (-2) - -- | WARNING: -- We currently parse the module both with and without Opt_Haddock, and -- return the one with Haddocks if it -- succeeds. However, this may not work @@ -259,45 +268,10 @@ let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } reset_ms pm = pm { pm_mod_summary = ms' } - -- We still parse with Haddocks whether Opt_Haddock is True or False to collect information - -- but we no longer need to parse with and without Haddocks separately for above GHC90. - res@(_,pmod) <- if Compat.ghcVersion >= Compat.GHC90 then - liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt file (withOptHaddock ms) - else do - let dflags = ms_hspp_opts ms - mainParse = getParsedModuleDefinition hsc opt file ms - - -- Parse again (if necessary) to capture Haddock parse errors - if gopt Opt_Haddock dflags - then - liftIO $ (fmap.fmap.fmap) reset_ms mainParse - else do - let haddockParse = getParsedModuleDefinition hsc opt file (withOptHaddock ms) - - -- parse twice, with and without Haddocks, concurrently - -- we cannot ignore Haddock parse errors because files of - -- non-interest are always parsed with Haddocks - -- If we can parse Haddocks, might as well use them - ((diags,res),(diagsh,resh)) <- liftIO $ (fmap.fmap.fmap.fmap) reset_ms $ concurrently mainParse haddockParse - - -- Merge haddock and regular diagnostics so we can always report haddock - -- parse errors - let diagsM = mergeParseErrorsHaddock diags diagsh - case resh of - Just _ - | HaddockParse <- optHaddockParse opt - -> pure (diagsM, resh) - -- If we fail to parse haddocks, report the haddock diagnostics as well and - -- return the non-haddock parse. - -- This seems to be the correct behaviour because the Haddock flag is added - -- by us and not the user, so our IDE shouldn't stop working because of it. - _ -> pure (diagsM, res) - -- Add dependencies on included files - _ <- uses GetModificationTime $ map toNormalizedFilePath' (maybe [] pm_extra_src_files pmod) - pure res + liftIO $ (fmap.fmap.fmap) reset_ms $ getParsedModuleDefinition hsc opt file ms -withOptHaddock :: ModSummary -> ModSummary -withOptHaddock = withOption Opt_Haddock +withoutOptHaddock :: ModSummary -> ModSummary +withoutOptHaddock = withoutOption Opt_Haddock withOption :: GeneralFlag -> ModSummary -> ModSummary withOption opt ms = ms{ms_hspp_opts= gopt_set (ms_hspp_opts ms) opt} @@ -305,18 +279,6 @@ withoutOption :: GeneralFlag -> ModSummary -> ModSummary withoutOption opt ms = ms{ms_hspp_opts= gopt_unset (ms_hspp_opts ms) opt} --- | Given some normal parse errors (first) and some from Haddock (second), merge them. --- Ignore Haddock errors that are in both. Demote Haddock-only errors to warnings. -mergeParseErrorsHaddock :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic] -mergeParseErrorsHaddock normal haddock = normal ++ - [ (a,b,c{_severity = Just DsWarning, _message = fixMessage $ _message c}) - | (a,b,c) <- haddock, Diag._range c `Set.notMember` locations] - where - locations = Set.fromList $ map (Diag._range . thd3) normal - - fixMessage x | "parse error " `T.isPrefixOf` x = "Haddock " <> x - | otherwise = "Haddock: " <> x - -- | This rule provides a ParsedModule preserving all annotations, -- including keywords, punctuation and comments. -- So it is suitable for use cases where you need a perfect edit. @@ -328,12 +290,12 @@ ModSummaryResult{msrModSummary = ms, msrHscEnv = hsc} <- use_ GetModSummary file opt <- getIdeOptions - let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms + let ms' = withoutOptHaddock $ withOption Opt_KeepRawTokenStream ms modify_dflags <- getModifyDynFlags dynFlagsModifyParser - let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } + let ms'' = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' } reset_ms pm = pm { pm_mod_summary = ms' } - liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition hsc opt file ms + liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition hsc opt file ms'' getModifyDynFlags :: (DynFlagsModifications -> a) -> Action a getModifyDynFlags f = do @@ -358,35 +320,36 @@ getLocatedImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \GetLocatedImports file -> do ModSummaryResult{msrModSummary = ms} <- use_ GetModSummaryWithoutTimestamps file - targets <- useNoFile_ GetKnownTargets - let targetsMap = HM.mapWithKey const targets + (KnownTargets targets) <- useNoFile_ GetKnownTargets +#if MIN_VERSION_ghc(9,13,0) + let imports = [(False, lvl, mbPkgName, modName) | (lvl, mbPkgName, modName) <- ms_textual_imps ms] + ++ [(True, NormalLevel, NoPkgQual, noLoc modName) | L _ modName <- ms_srcimps ms] +#else let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms] +#endif env_eq <- use_ GhcSession file - let env = hscEnvWithImportPaths env_eq - let import_dirs = deps env_eq + let env = hscEnv env_eq + let import_dirs = map (second homeUnitEnv_dflags) $ hugElts $ hsc_HUG env let dflags = hsc_dflags env - isImplicitCradle = isNothing $ envImportPaths env_eq - dflags <- return $ if isImplicitCradle - then addRelativeImport file (moduleName $ ms_mod ms) dflags - else dflags opt <- getIdeOptions let getTargetFor modName nfp - | isImplicitCradle = do - itExists <- getFileExists nfp - return $ if itExists then Just nfp else Nothing - | Just (TargetFile nfp') <- HM.lookup (TargetFile nfp) targetsMap = do + | Just (TargetFile nfp') <- HM.lookupKey (TargetFile nfp) targets = do -- reuse the existing NormalizedFilePath in order to maximize sharing itExists <- getFileExists nfp' return $ if itExists then Just nfp' else Nothing | Just tt <- HM.lookup (TargetModule modName) targets = do -- reuse the existing NormalizedFilePath in order to maximize sharing - let ttmap = HM.mapWithKey const (HashSet.toMap tt) - nfp' = HM.lookupDefault nfp nfp ttmap + let nfp' = fromMaybe nfp $ HashSet.lookupElement nfp tt itExists <- getFileExists nfp' return $ if itExists then Just nfp' else Nothing - | otherwise - = return Nothing + | otherwise = do + itExists <- getFileExists nfp + return $ if itExists then Just nfp else Nothing +#if MIN_VERSION_ghc(9,13,0) + (diags, imports') <- fmap unzip $ forM imports $ \(isSource, _lvl, mbPkgName, modName) -> do +#else (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do +#endif diagOrImp <- locateModule (hscSetFlags dflags env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource case diagOrImp of Left diags -> pure (diags, Just (modName, Nothing)) @@ -401,7 +364,7 @@ bootArtifact <- if boot == Just True then do let modName = ms_mod_name ms - loc <- liftIO $ mkHomeModLocation dflags modName (fromNormalizedFilePath bootPath) + loc <- liftIO $ mkHomeModLocation dflags' modName (fromNormalizedFilePath bootPath) return $ Just (noLoc modName, Just (ArtifactsLocation bootPath (Just loc) True)) else pure Nothing -} @@ -415,17 +378,17 @@ execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1) execRawDepM act = execStateT act - ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty IntMap.empty + ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty , IntMap.empty ) -- | Given a target file path, construct the raw dependency results by following -- imports recursively. -rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation +rawDependencyInformation :: [NormalizedFilePath] -> Action (RawDependencyInformation, BootIdMap) rawDependencyInformation fs = do (rdi, ss) <- execRawDepM (goPlural fs) let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss - return (rdi { rawBootMap = bm }) + return (rdi, bm) where goPlural ff = do mss <- lift $ (fmap.fmap) msrModSummary <$> uses GetModSummaryWithoutTimestamps ff @@ -434,19 +397,19 @@ go :: NormalizedFilePath -- ^ Current module being processed -> Maybe ModSummary -- ^ ModSummary of the module -> RawDepM FilePathId - go f msum = do + go f mbModSum = do -- First check to see if we have already processed the FilePath -- If we have, just return its Id but don't update any of the state. -- Otherwise, we need to process its imports. checkAlreadyProcessed f $ do - let al = modSummaryToArtifactsLocation f msum + let al = modSummaryToArtifactsLocation f mbModSum -- Get a fresh FilePathId for the new file fId <- getFreshFid al -- Record this module and its location - whenJust msum $ \ms -> - modifyRawDepInfo (\rd -> rd { rawModuleNameMap = IntMap.insert (getFilePathId fId) - (ShowableModuleName (moduleName $ ms_mod ms)) - (rawModuleNameMap rd)}) + whenJust mbModSum $ \ms -> + modifyRawDepInfo (\rd -> rd { rawModuleMap = IntMap.insert (getFilePathId fId) + (ShowableModule $ ms_mod ms) + (rawModuleMap rd)}) -- Adding an edge to the bootmap so we can make sure to -- insert boot nodes before the real files. addBootMap al fId @@ -518,39 +481,29 @@ dropBootSuffix :: FilePath -> FilePath dropBootSuffix hs_src = reverse . drop (length @[] "-boot") . reverse $ hs_src -getDependencyInformationRule :: Recorder (WithPriority Log) -> Rules () -getDependencyInformationRule recorder = - define (cmapWithPrio LogShake recorder) $ \GetDependencyInformation file -> do - rawDepInfo <- rawDependencyInformation [file] - pure ([], Just $ processDependencyInformation rawDepInfo) - reportImportCyclesRule :: Recorder (WithPriority Log) -> Rules () reportImportCyclesRule recorder = - define (cmapWithPrio LogShake recorder) $ \ReportImportCycles file -> fmap (\errs -> if null errs then ([], Just ()) else (errs, Nothing)) $ do - DependencyInformation{..} <- use_ GetDependencyInformation file - let fileId = pathToId depPathIdMap file - case IntMap.lookup (getFilePathId fileId) depErrorNodes of - Nothing -> pure [] - Just errs -> do - let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs) - -- Convert cycles of files into cycles of module names - forM cycles $ \(imp, files) -> do - modNames <- forM files $ \fileId -> do - let file = idToPath depPathIdMap fileId - getModuleName file - pure $ toDiag imp $ sort modNames + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \ReportImportCycles file -> fmap (\errs -> if null errs then (Just "1",([], Just ())) else (Nothing, (errs, Nothing))) $ do + DependencyInformation{..} <- useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph file + case pathToId depPathIdMap file of + -- The header of the file does not parse, so it can't be part of any import cycles. + Nothing -> pure [] + Just fileId -> + case IntMap.lookup (getFilePathId fileId) depErrorNodes of + Nothing -> pure [] + Just errs -> do + let cycles = mapMaybe (cycleErrorInFile fileId) (toList errs) + -- Convert cycles of files into cycles of module names + forM cycles $ \(imp, files) -> do + modNames <- forM files $ + getModuleName . idToPath depPathIdMap + pure $ toDiag imp $ sort modNames where cycleErrorInFile f (PartOfCycle imp fs) | f `elem` fs = Just (imp, fs) cycleErrorInFile _ _ = Nothing - toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic - { _range = rng - , _severity = Just DsError - , _source = Just "Import cycle detection" - , _message = "Cyclic module dependency between " <> showCycle mods - , _code = Nothing - , _relatedInformation = Nothing - , _tags = Nothing - } + toDiag imp mods = + ideErrorWithSource (Just "Import cycle detection") (Just DiagnosticSeverity_Error) fp ("Cyclic module dependency between " <> showCycle mods) Nothing + & fdLspDiagnosticL %~ JL.range .~ rng where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp) fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp) getModuleName file = do @@ -570,34 +523,39 @@ res <- readHieFileForSrcFromDisk recorder file vfsRef <- asks vfsVar vfsData <- liftIO $ _vfsMap <$> readTVarIO vfsRef - (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of + (currentSource, ver) <- liftIO $ case getVirtualFileFromVFS (VFS vfsData) (filePathToUri' file) of Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file) - Just vf -> pure (Rope.toText $ _file_text vf, Just $ _lsp_version vf) - let refmap = Compat.generateReferencesMap . Compat.getAsts . Compat.hie_asts $ res + Just vf -> pure (virtualFileText vf, Just $ virtualFileVersion vf) + let refmap = generateReferencesMap . getAsts . Compat.hie_asts $ res del = deltaFromDiff (T.decodeUtf8 $ Compat.hie_hs_src res) currentSource pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver) getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult) getHieAstRuleDefinition f hsc tmr = do - (diags, masts) <- liftIO $ generateHieAsts hsc tmr + (diags, masts') <- liftIO $ generateHieAsts hsc tmr +#if MIN_VERSION_ghc(9,11,0) + let masts = fst <$> masts' +#else + let masts = masts' +#endif se <- getShakeExtras isFoi <- use_ IsFileOfInterest f diagsWrite <- case isFoi of IsFOI Modified{firstOpen = False} -> do when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ - LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $ + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ toJSON $ fromNormalizedFilePath f pure [] - _ | Just asts <- masts -> do + _ | Just asts <- masts' -> do source <- getSourceFileSource f let exports = tcg_exports $ tmrTypechecked tmr - msum = tmrModSummary tmr - liftIO $ writeAndIndexHieFile hsc se msum f exports asts source + modSummary = tmrModSummary tmr + liftIO $ writeAndIndexHieFile hsc se modSummary f exports asts source _ -> pure [] - let refmap = Compat.generateReferencesMap . Compat.getAsts <$> masts - typemap = AtPoint.computeTypeReferences . Compat.getAsts <$> masts + let refmap = generateReferencesMap . getAsts <$> masts + typemap = AtPoint.computeTypeReferences . getAsts <$> masts pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> typemap <*> pure HieFresh) getImportMapRule :: Recorder (WithPriority Log) -> Rules () @@ -632,7 +590,7 @@ -- | Persistent rule to ensure that hover doesn't block on startup persistentDocMapRule :: Rules () -persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty, idDelta, Nothing) +persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty mempty, idDelta, Nothing) readHieFileForSrcFromDisk :: Recorder (WithPriority Log) -> NormalizedFilePath -> MaybeT IdeAction Compat.HieFile readHieFileForSrcFromDisk recorder file = do @@ -646,10 +604,9 @@ readHieFileFromDisk recorder hie_loc = do nc <- asks ideNc res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc - let log = (liftIO .) . logWith recorder case res of - Left e -> log Logger.Debug $ LogLoadingHieFileFail hie_loc e - Right _ -> log Logger.Debug $ LogLoadingHieFileSuccess hie_loc + Left e -> liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFileFail hie_loc e + Right _ -> liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFileSuccess hie_loc except res -- | Typechecks a module. @@ -663,7 +620,7 @@ -- very expensive. when (foi == NotFOI) $ logWith recorder Logger.Warning $ LogTypecheckedFOI file - typeCheckRuleDefinition hsc pm + typeCheckRuleDefinition hsc pm file knownFilesRule :: Recorder (WithPriority Log) -> Rules () knownFilesRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetKnownTargets -> do @@ -671,12 +628,62 @@ fs <- knownTargets pure (LBS.toStrict $ B.encode $ hash fs, unhashed fs) +getFileHashRule :: Recorder (WithPriority Log) -> Rules () +getFileHashRule recorder = + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetFileHash file -> do + void $ use_ GetModificationTime file + fileHash <- liftIO $ Util.getFileHash (fromNormalizedFilePath file) + return (Just (fingerprintToBS fileHash), ([], Just fileHash)) + getModuleGraphRule :: Recorder (WithPriority Log) -> Rules () -getModuleGraphRule recorder = defineNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do +getModuleGraphRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetModuleGraph -> do fs <- toKnownFiles <$> useNoFile_ GetKnownTargets - rawDepInfo <- rawDependencyInformation (HashSet.toList fs) - pure $ processDependencyInformation rawDepInfo + dependencyInfoForFiles (HashSet.toList fs) +#if MIN_VERSION_ghc(9,13,0) +-- | Build level-aware module graph edges from a ModSummary and a list of dependency NodeKeys. +-- A module can be imported at multiple levels (e.g. @import splice M@ + @import M@), +-- so we collect ALL levels per module and produce one edge per (module, level) pair. +-- This is required for GHC 9.14's level-aware module graph (@mg_zero_graph@). +mkLevelEdges :: ModSummary -> [NodeKey] -> [ModuleNodeEdge] +mkLevelEdges ms dep_node_keys = concatMap (\nk -> map (\lvl -> mkModuleEdge lvl nk) (lookupLevels nk)) dep_node_keys + where + importLevelsMap = M.map nubOrd $ M.fromListWith (++) + [(unLoc mn, [lvl]) | (lvl, _pkg, mn) <- ms_textual_imps ms] + lookupLevels nk = case nk of + NodeKey_Module mnk -> + M.findWithDefault [NormalLevel] (gwib_mod $ mnkModuleName mnk) importLevelsMap + _ -> [NormalLevel] +#endif + +dependencyInfoForFiles :: [NormalizedFilePath] -> Action (BS.ByteString, DependencyInformation) +dependencyInfoForFiles fs = do + (rawDepInfo, bm) <- rawDependencyInformation fs + let (all_fs, _all_ids) = unzip $ HM.toList $ pathToIdMap $ rawPathIdMap rawDepInfo + msrs <- uses GetModSummaryWithoutTimestamps all_fs + let mss = map (fmap msrModSummary) msrs + let deps = map (\i -> IM.lookup (getFilePathId i) (rawImports rawDepInfo)) _all_ids + nodeKeys = IM.fromList $ catMaybes $ zipWith (\fi mms -> (getFilePathId fi,) . NodeKey_Module . msKey <$> mms) _all_ids mss + mns = catMaybes $ zipWith go mss deps +#if MIN_VERSION_ghc(9,13,0) + go (Just ms) (Just (Right (ModuleImports xs))) = Just $ ModuleNode this_dep_edges (ModuleNodeCompile ms) + where this_dep_ids = mapMaybe snd xs + this_dep_node_keys = mapMaybe (\fi -> IM.lookup (getFilePathId fi) nodeKeys) this_dep_ids + this_dep_edges = mkLevelEdges ms this_dep_node_keys + go (Just ms) _ = Just $ ModuleNode [] (ModuleNodeCompile ms) +#else + go (Just ms) (Just (Right (ModuleImports xs))) = Just $ ModuleNode this_dep_keys ms + where this_dep_ids = mapMaybe snd xs + this_dep_keys = mapMaybe (\fi -> IM.lookup (getFilePathId fi) nodeKeys) this_dep_ids + go (Just ms) _ = Just $ ModuleNode [] ms +#endif + go _ _ = Nothing + mg = mkModuleGraph mns + let shallowFingers = IntMap.fromList $ foldr' (\(i, m) acc -> case m of + Just x -> (getFilePathId i,msrFingerprint x):acc + Nothing -> acc) [] $ zip _all_ids msrs + pure (fingerprintToBS $ Util.fingerprintFingerprints $ map (maybe fingerprint0 msrFingerprint) msrs, processDependencyInformation rawDepInfo bm mg shallowFingers) + -- This is factored out so it can be directly called from the GetModIface -- rule. Directly calling this rule means that on the initial load we can -- garbage collect all the intermediate typechecked modules rather than @@ -684,14 +691,15 @@ typeCheckRuleDefinition :: HscEnv -> ParsedModule + -> NormalizedFilePath -> Action (IdeResult TcModuleResult) -typeCheckRuleDefinition hsc pm = do - setPriority priorityTypeCheck +typeCheckRuleDefinition hsc pm fp = do IdeOptions { optDefer = defer } <- getIdeOptions unlift <- askUnliftIO let dets = TypecheckHelpers { getLinkables = unliftIO unlift . uses_ GetLinkable + , getModuleGraph = unliftIO unlift $ useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph fp } addUsageDependencies $ liftIO $ typecheckModule defer hsc dets pm @@ -718,23 +726,35 @@ defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GhcSessionIO -> do alwaysRerun opts <- getIdeOptions + config <- getClientConfigAction res <- optGhcSession opts - let fingerprint = LBS.toStrict $ B.encode $ hash (sessionVersion res) + let fingerprint = LBS.toStrict $ LBS.concat + [ B.encode (hash (sessionVersion res)) + -- When the session version changes, reload all session + -- hsc env sessions + , B.encode (show (sessionLoading config)) + -- The loading config affects session loading. + -- Invalidate all build nodes. + -- Changing the session loading config will increment + -- the 'sessionVersion', thus we don't generate the same fingerprint + -- twice by accident. + ] return (fingerprint, res) defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO + -- loading is always returning a absolute path now (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file -- add the deps to the Shake graph let addDependency fp = do -- VSCode uses absolute paths in its filewatch notifications - afp <- liftIO $ makeAbsolute fp - let nfp = toNormalizedFilePath' afp + let nfp = toNormalizedFilePath' fp itExists <- getFileExists nfp when itExists $ void $ do - use_ GetModificationTime nfp + use_ GetPhysicalModificationTime nfp + mapM_ addDependency deps let cutoffHash = LBS.toStrict $ B.encode (hash (snd val)) @@ -745,14 +765,15 @@ ghcSessionDepsDefinition fullModSummary ghcSessionDepsConfig env file newtype GhcSessionDepsConfig = GhcSessionDepsConfig - { checkForImportCycles :: Bool + { fullModuleGraph :: Bool } instance Default GhcSessionDepsConfig where def = GhcSessionDepsConfig - { checkForImportCycles = True + { fullModuleGraph = True } -- | Note [GhcSessionDeps] +-- ~~~~~~~~~~~~~~~~~~~~~ -- For a file 'Foo', GhcSessionDeps "Foo.hs" results in an HscEnv which includes -- 1. HomeModInfo's (in the HUG/HPT) for all modules in the transitive closure of "Foo", **NOT** including "Foo" itself. -- 2. ModSummary's (in the ModuleGraph) for all modules in the transitive closure of "Foo", including "Foo" itself. @@ -761,36 +782,53 @@ :: -- | full mod summary Bool -> GhcSessionDepsConfig -> HscEnvEq -> NormalizedFilePath -> Action (Maybe HscEnvEq) -ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do - let hsc = hscEnv env - +ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} hscEnvEq file = do mbdeps <- mapM(fmap artifactFilePath . snd) <$> use_ GetLocatedImports file case mbdeps of Nothing -> return Nothing Just deps -> do - when checkForImportCycles $ void $ uses_ ReportImportCycles deps - ms <- msrModSummary <$> if fullModSummary + when fullModuleGraph $ void $ use_ ReportImportCycles file + msr <- if fullModSummary then use_ GetModSummary file else use_ GetModSummaryWithoutTimestamps file - + let + ms = msrModSummary msr + -- This `HscEnv` has its plugins initialized in `parsePragmasIntoHscEnv` + -- Fixes the bug in #4631 + env = msrHscEnv msr depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps ifaces <- uses_ GetModIface deps - let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails Nothing) ifaces -#if MIN_VERSION_ghc(9,3,0) - -- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph - -- also points to all the direct descendants of the current module. To get the keys for the descendants - -- we must get their `ModSummary`s - !final_deps <- do - dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps - -- Don't want to retain references to the entire ModSummary when just the key will do - return $!! map (NodeKey_Module . msKey) dep_mss - let moduleNode = (ms, final_deps) + let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces + de <- useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph file + mg <- do + if fullModuleGraph + then return $ depModuleGraph de + else do + let mgs = map hsc_mod_graph depSessions + -- On GHC 9.4+, the module graph contains not only ModSummary's but each `ModuleNode` in the graph + -- also points to all the direct descendants of the current module. To get the keys for the descendants + -- we must get their `ModSummary`s + !final_deps <- do + dep_mss <- map msrModSummary <$> uses_ GetModSummaryWithoutTimestamps deps + return $!! map (NodeKey_Module . msKey) dep_mss +#if MIN_VERSION_ghc(9,13,0) + let final_dep_edges = mkLevelEdges ms final_deps + let module_graph_nodes = + nubOrdOn mkNodeKey (ModuleNode final_dep_edges (ModuleNodeCompile ms) : concatMap mgModSummaries' mgs) #else - let moduleNode = ms + let module_graph_nodes = + nubOrdOn mkNodeKey (ModuleNode final_deps ms : concatMap mgModSummaries' mgs) #endif - session' <- liftIO $ mergeEnvs hsc moduleNode inLoadOrder depSessions + liftIO $ evaluate $ liftRnf rwhnf module_graph_nodes + return $ mkModuleGraph module_graph_nodes + session' <- liftIO $ mergeEnvs env mg de ms inLoadOrder depSessions - Just <$> liftIO (newHscEnvEqWithImportPaths (envImportPaths env) session' []) + -- Here we avoid a call to to `newHscEnvEqWithImportPaths`, which creates a new + -- ExportsMap when it is called. We only need to create the ExportsMap once per + -- session, while `ghcSessionDepsDefinition` will be called for each file we need + -- to compile. `updateHscEnvEq` will refresh the HscEnv (session') and also + -- generate a new Unique. + Just <$> liftIO (updateHscEnvEq hscEnvEq session') -- | Load a iface from disk, or generate it if there isn't one or it is out of date -- This rule also ensures that the `.hie` and `.o` (if needed) files are written out. @@ -803,19 +841,20 @@ Just session -> do linkableType <- getLinkableType f ver <- use_ GetModificationTime f - ShakeExtras{ideNc} <- getShakeExtras let m_old = case old of Shake.Succeeded (Just old_version) v -> Just (v, old_version) Shake.Stale _ (Just old_version) v -> Just (v, old_version) - _ -> Nothing + _ -> Nothing recompInfo = RecompilationInfo { source_version = ver , old_value = m_old , get_file_version = use GetModificationTime_{missingFileDiagnostics = False} , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs + , get_module_graph = useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph f , regenerate = regenerateHiFile session f ms } - r <- loadInterface (hscEnv session) ms linkableType recompInfo + hsc_env' <- setFileCacheHook (hscEnv session) + r <- loadInterface hsc_env' ms linkableType recompInfo case r of (diags, Nothing) -> return (Nothing, (diags, Nothing)) (diags, Just x) -> do @@ -840,17 +879,17 @@ -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db let ms = hirModSummary x hie_loc = Compat.ml_hie_file $ ms_location ms - hash <- liftIO $ Util.getFileHash hie_loc + fileHash <- liftIO $ Util.getFileHash hie_loc mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath f)) - hie_loc' <- liftIO $ traverse (makeAbsolute . HieDb.hieModuleHieFile) mrow + let hie_loc' = HieDb.hieModuleHieFile <$> mrow case mrow of Just row - | hash == HieDb.modInfoHash (HieDb.hieModInfo row) + | fileHash == HieDb.modInfoHash (HieDb.hieModInfo row) && Just hie_loc == hie_loc' -> do -- All good, the db has indexed the file when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ - LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $ + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ toJSON $ fromNormalizedFilePath f -- Not in db, must re-index _ -> do @@ -862,7 +901,7 @@ -- can just re-index the file we read from disk Right hf -> liftIO $ do logWith recorder Logger.Debug $ LogReindexingHieFile f - indexHieFile se ms f hash hf + indexHieFile se ms f fileHash hf return (Just x) @@ -883,36 +922,28 @@ defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModSummary f -> do session' <- hscEnv <$> use_ GhcSession f modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal - let session = hscSetFlags (modify_dflags $ hsc_dflags session') session' - (modTime, mFileContent) <- getFileContents f + let session = setNonHomeFCHook $ hscSetFlags (modify_dflags $ hsc_dflags session') session' -- TODO wz1000 + mFileContent <- getFileContents f let fp = fromNormalizedFilePath f modS <- liftIO $ runExceptT $ - getModSummaryFromImports session fp modTime (textToStringBuffer <$> mFileContent) + getModSummaryFromImports session fp (textToStringBuffer . Rope.toText <$> mFileContent) case modS of Right res -> do -- Check for Template Haskell when (uses_th_qq $ msrModSummary res) $ do DisplayTHWarning act <- getIdeGlobalAction liftIO act -#if MIN_VERSION_ghc(9,3,0) let bufFingerPrint = ms_hs_hash (msrModSummary res) -#else - bufFingerPrint <- liftIO $ - fingerprintFromStringBuffer $ fromJust $ ms_hspp_buf $ msrModSummary res -#endif let fingerPrint = Util.fingerprintFingerprints [ msrFingerprint res, bufFingerPrint ] return ( Just (fingerprintToBS fingerPrint) , ([], Just res)) Left diags -> return (Nothing, (diags, Nothing)) defineEarlyCutoff (cmapWithPrio LogShake recorder) $ RuleNoDiagnostics $ \GetModSummaryWithoutTimestamps f -> do - ms <- use GetModSummary f - case ms of + mbMs <- use GetModSummary f + case mbMs of Just res@ModSummaryResult{..} -> do let ms = msrModSummary { -#if !MIN_VERSION_ghc(9,3,0) - ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps", -#endif ms_hspp_buf = error "use GetModSummary instead of GetModSummaryWithoutTimestamps" } fp = fingerprintToBS msrFingerprint @@ -922,9 +953,9 @@ generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult ModGuts) generateCore runSimplifier file = do packageState <- hscEnv <$> use_ GhcSessionDeps file + hsc' <- setFileCacheHook packageState tm <- use_ TypeCheck file - setPriority priorityGenerateCore - liftIO $ compileModule runSimplifier packageState (tmrModSummary tm) (tmrTypechecked tm) + liftIO $ compileModule runSimplifier hsc' (tmrModSummary tm) (tmrTypechecked tm) generateCoreRule :: Recorder (WithPriority Log) -> Rules () generateCoreRule recorder = @@ -933,22 +964,23 @@ getModIfaceRule :: Recorder (WithPriority Log) -> Rules () getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModIface f -> do fileOfInterest <- use_ IsFileOfInterest f - res@(_,(_,mhmi)) <- case fileOfInterest of + res <- case fileOfInterest of IsFOI status -> do -- Never load from disk for files of interest tmr <- use_ TypeCheck f linkableType <- getLinkableType f hsc <- hscEnv <$> use_ GhcSessionDeps f + hsc' <- setFileCacheHook hsc let compile = fmap ([],) $ use GenerateCore f se <- getShakeExtras - (diags, !hiFile) <- writeCoreFileIfNeeded se hsc linkableType compile tmr - let fp = hiFileFingerPrint <$> hiFile - hiDiags <- case hiFile of + (diags, !mbHiFile) <- writeCoreFileIfNeeded se hsc' linkableType compile tmr + let fp = hiFileFingerPrint <$> mbHiFile + hiDiags <- case mbHiFile of Just hiFile | OnDisk <- status - , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc hiFile + , not (tmrDeferredError tmr) -> liftIO $ writeHiFile se hsc' hiFile _ -> pure [] - return (fp, (diags++hiDiags, hiFile)) + return (fp, (diags++hiDiags, mbHiFile)) NotFOI -> do hiFile <- use GetModIfaceFromDiskAndIndex f let fp = hiFileFingerPrint <$> hiFile @@ -970,30 +1002,31 @@ count <- getRebuildCountVar <$> getIdeGlobalAction liftIO $ atomically $ modifyTVar' count (+1) +setFileCacheHook :: HscEnv -> Action HscEnv +setFileCacheHook old_hsc_env = do +#if MIN_VERSION_ghc(9,11,0) + unlift <- askUnliftIO + return $ old_hsc_env { hsc_FC = (hsc_FC old_hsc_env) { lookupFileCache = unliftIO unlift . use_ GetFileHash . toNormalizedFilePath' } } +#else + return old_hsc_env +#endif + -- | Also generates and indexes the `.hie` file, along with the `.o` file if needed -- Invariant maintained is that if the `.hi` file was successfully written, then the -- `.hie` and `.o` file (if needed) were also successfully written regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> ModSummary -> Maybe LinkableType -> Action ([FileDiagnostic], Maybe HiFileResult) regenerateHiFile sess f ms compNeeded = do - let hsc = hscEnv sess + hsc <- setFileCacheHook (hscEnv sess) opt <- getIdeOptions - -- Embed haddocks in the interface file - (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f (withOptHaddock ms) - (diags, mb_pm) <- - -- We no longer need to parse again if GHC version is above 9.0. https://github.com/haskell/haskell-language-server/issues/1892 - if Compat.ghcVersion >= Compat.GHC90 || isJust mb_pm then do - return (diags, mb_pm) - else do - -- if parsing fails, try parsing again with Haddock turned off - (diagsNoHaddock, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f ms - return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm) + -- By default, we parse with `-haddock` unless 'OptHaddockParse' is overwritten. + (diags, mb_pm) <- liftIO $ getParsedModuleDefinition hsc opt f ms case mb_pm of Nothing -> return (diags, Nothing) Just pm -> do -- Invoke typechecking directly to update it without incurring a dependency -- on the parsed module and the typecheck rules - (diags', mtmr) <- typeCheckRuleDefinition hsc pm + (diags', mtmr) <- typeCheckRuleDefinition hsc pm f case mtmr of Nothing -> pure (diags', Nothing) Just tmr -> do @@ -1012,16 +1045,16 @@ -- Write hie file. Do this before writing the .hi file to -- ensure that we always have a up2date .hie file if we have -- a .hi file - se <- getShakeExtras + se' <- getShakeExtras (gDiags, masts) <- liftIO $ generateHieAsts hsc tmr source <- getSourceFileSource f wDiags <- forM masts $ \asts -> - liftIO $ writeAndIndexHieFile hsc se (tmrModSummary tmr) f (tcg_exports $ tmrTypechecked tmr) asts source + liftIO $ writeAndIndexHieFile hsc se' (tmrModSummary tmr) f (tcg_exports $ tmrTypechecked tmr) asts source -- We don't write the `.hi` file if there are deferred errors, since we won't get -- accurate diagnostics next time if we do hiDiags <- if not $ tmrDeferredError tmr - then liftIO $ writeHiFile se hsc hiFile + then liftIO $ writeHiFile se' hsc hiFile else pure [] pure (hiDiags <> gDiags <> concat wDiags) @@ -1047,6 +1080,7 @@ (diags', !res) <- liftIO $ mkHiFileResultCompile se hsc tmr guts pure (diags++diags', res) +-- See Note [Client configuration in Rules] getClientSettingsRule :: Recorder (WithPriority Log) -> Rules () getClientSettingsRule recorder = defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GetClientSettings -> do alwaysRerun @@ -1063,30 +1097,44 @@ pluginConfig <- getPluginConfigAction plId pure $ useProperty kn p $ plcConfig pluginConfig +usePropertyByPathAction :: + (HasPropertyByPath props path t) => + KeyNamePath path -> + PluginId -> + Properties props -> + Action (ToHsType t) +usePropertyByPathAction path plId p = do + pluginConfig <- getPluginConfigAction plId + pure $ usePropertyByPath path p $ plcConfig pluginConfig + -- --------------------------------------------------------------------- getLinkableRule :: Recorder (WithPriority Log) -> Rules () getLinkableRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetLinkable f -> do - ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary f - HiFileResult{hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f - let obj_file = ml_obj_file (ms_location ms) - core_file = ml_core_file (ms_location ms) - -- Can't use `GetModificationTime` rule because the core file was possibly written in this - -- very session, so the results aren't reliable - core_t <- liftIO $ getModTime core_file + HiFileResult{hirModSummary, hirModIface, hirModDetails, hirCoreFp} <- use_ GetModIface f + let obj_file = ml_obj_file (ms_location hirModSummary) + core_file = ml_core_file (ms_location hirModSummary) +#if MIN_VERSION_ghc(9,11,0) + mkLinkable t mod l = Linkable t mod (pure l) + dotO o = DotO o ModuleObject +#else + mkLinkable t mod l = LM t mod [l] + dotO = DotO +#endif case hirCoreFp of - Nothing -> error "called GetLinkable for a file without a linkable" - Just (bin_core, hash) -> do + Nothing -> error $ "called GetLinkable for a file without a linkable: " ++ show f + Just (bin_core, fileHash) -> do session <- use_ GhcSessionDeps f - ShakeExtras{ideNc} <- getShakeExtras - let namecache_updater = mkUpdater ideNc linkableType <- getLinkableType f >>= \case - Nothing -> error "called GetLinkable for a file which doesn't need compilation" + Nothing -> error $ "called GetLinkable for a file which doesn't need compilation: " ++ show f Just t -> pure t + -- Can't use `GetModificationTime` rule because the core file was possibly written in this + -- very session, so the results aren't reliable + core_t <- liftIO $ getModTime core_file (warns, hmi) <- case linkableType of -- Bytecode needs to be regenerated from the core file - BCOLinkable -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (posixSecondsToUTCTime core_t) + BCOLinkable -> liftIO $ coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core (posixSecondsToUTCTime core_t) -- Object code can be read from the disk ObjectLinkable -> do -- object file is up to date if it is newer than the core file @@ -1099,10 +1147,15 @@ else pure Nothing case mobj_time of Just obj_t - | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (Just $ LM (posixSecondsToUTCTime obj_t) (ms_mod ms) [DotO obj_file])) - _ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) ms hirModIface hirModDetails bin_core (error "object doesn't have time") + | obj_t >= core_t -> pure ([], Just $ HomeModInfo hirModIface hirModDetails (justObjects $ mkLinkable (posixSecondsToUTCTime obj_t) (ms_mod hirModSummary) (dotO obj_file))) + _ -> liftIO $ coreFileToLinkable linkableType (hscEnv session) hirModSummary hirModIface hirModDetails bin_core (error "object doesn't have time") -- Record the linkable so we know not to unload it, and unload old versions - whenJust (hm_linkable =<< hmi) $ \(LM time mod _) -> do + whenJust ((homeModInfoByteCode =<< hmi) <|> (homeModInfoObject =<< hmi)) +#if MIN_VERSION_ghc(9,11,0) + $ \(Linkable time mod _) -> do +#else + $ \(LM time mod _) -> do +#endif compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction liftIO $ modifyVar compiledLinkables $ \old -> do let !to_keep = extendModuleEnv old mod time @@ -1116,21 +1169,22 @@ --just before returning it to be loaded. This has a substantial effect on recompile --times as the number of loaded modules and splices increases. -- - unload (hscEnv session) (map (\(mod, time) -> LM time mod []) $ moduleEnvToList to_keep) + --We use a dummy DotA linkable part to fake a NativeCode linkable. + --The unload function doesn't care about the exact linkable parts. + unload (hscEnv session) (map (\(mod', time') -> mkLinkable time' mod' (DotA "dummy")) $ moduleEnvToList to_keep) return (to_keep, ()) - return (hash <$ hmi, (warns, LinkableResult <$> hmi <*> pure hash)) + return (fileHash <$ hmi, (warns, LinkableResult <$> hmi <*> pure fileHash)) -- | For now we always use bytecode unless something uses unboxed sums and tuples along with TH getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType) getLinkableType f = use_ NeedsCompilation f --- needsCompilationRule :: Rules () needsCompilationRule :: NormalizedFilePath -> Action (IdeResultNoDiagnosticsEarlyCutoff (Maybe LinkableType)) needsCompilationRule file - | "boot" `isSuffixOf` (fromNormalizedFilePath file) = + | "boot" `isSuffixOf` fromNormalizedFilePath file = pure (Just $ encodeLinkableType Nothing, Just Nothing) needsCompilationRule file = do - graph <- useNoFile GetModuleGraph + graph <- useWithSeparateFingerprintRule GetModuleGraphImmediateReverseDepsFingerprints GetModuleGraph file res <- case graph of -- Treat as False if some reverse dependency header fails to parse Nothing -> pure Nothing @@ -1147,50 +1201,40 @@ -- that we just threw away, and thus have to recompile all dependencies once -- again, this time keeping the object code. -- A file needs to be compiled if any file that depends on it uses TemplateHaskell or needs to be compiled - ms <- msrModSummary . fst <$> useWithStale_ GetModSummaryWithoutTimestamps file (modsums,needsComps) <- liftA2 (,) (map (fmap (msrModSummary . fst)) <$> usesWithStale GetModSummaryWithoutTimestamps revdeps) (uses NeedsCompilation revdeps) - pure $ computeLinkableType ms modsums (map join needsComps) + pure $ computeLinkableType modsums (map join needsComps) pure (Just $ encodeLinkableType res, Just res) where - computeLinkableType :: ModSummary -> [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType - computeLinkableType this deps xs + computeLinkableType :: [Maybe ModSummary] -> [Maybe LinkableType] -> Maybe LinkableType + computeLinkableType deps xs | Just ObjectLinkable `elem` xs = Just ObjectLinkable -- If any dependent needs object code, so do we - | Just BCOLinkable `elem` xs = Just this_type -- If any dependent needs bytecode, then we need to be compiled - | any (maybe False uses_th_qq) deps = Just this_type -- If any dependent needs TH, then we need to be compiled + | Just BCOLinkable `elem` xs = Just BCOLinkable -- If any dependent needs bytecode, then we need to be compiled + | any (maybe False uses_th_qq) deps = Just BCOLinkable -- If any dependent needs TH, then we need to be compiled | otherwise = Nothing -- If none of these conditions are satisfied, we don't need to compile - where - this_type = computeLinkableTypeForDynFlags (ms_hspp_opts this) uses_th_qq :: ModSummary -> Bool uses_th_qq (ms_hspp_opts -> dflags) = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags --- | How should we compile this module? --- (assuming we do in fact need to compile it). --- Depends on whether it uses unboxed tuples or sums -computeLinkableTypeForDynFlags :: DynFlags -> LinkableType -computeLinkableTypeForDynFlags d -#if defined(GHC_PATCHED_UNBOXED_BYTECODE) || MIN_VERSION_ghc(9,2,0) - = BCOLinkable -#else - | unboxed_tuples_or_sums = ObjectLinkable - | otherwise = BCOLinkable -#endif - where - unboxed_tuples_or_sums = - xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d - -- | Tracks which linkables are current, so we don't need to unload them newtype CompiledLinkables = CompiledLinkables { getCompiledLinkables :: Var (ModuleEnv UTCTime) } instance IsIdeGlobal CompiledLinkables data RulesConfig = RulesConfig - { -- | Disable import cycle checking for improved performance in large codebases - checkForImportCycles :: Bool + { -- | Share the computation for the entire module graph + -- We usually compute the full module graph for the project + -- and share it for all files. + -- However, in large projects it might not be desirable to wait + -- for computing the entire module graph before starting to + -- typecheck a particular file. + -- Disabling this drastically decreases sharing and is likely to + -- increase memory usage if you have multiple files open + -- Disabling this also disables checking for import cycles + fullModuleGraph :: Bool -- | Disable TH for improved performance in large codebases - , enableTemplateHaskell :: Bool + , enableTemplateHaskell :: Bool -- | Warning to show when TH is not supported by the current HLS binary , templateHaskellWarning :: LspT Config IO () } @@ -1201,8 +1245,8 @@ displayTHWarning :: LspT c IO () displayTHWarning | not isWindows && not hostIsDynamic = do - LSP.sendNotification SWindowShowMessage $ - ShowMessageParams MtInfo thWarningMessage + LSP.sendNotification SMethod_WindowShowMessage $ + ShowMessageParams MessageType_Info thWarningMessage | otherwise = return () thWarningMessage :: T.Text @@ -1222,16 +1266,16 @@ getParsedModuleRule recorder getParsedModuleWithCommentsRule recorder getLocatedImportsRule recorder - getDependencyInformationRule recorder reportImportCyclesRule recorder typeCheckRule recorder getDocMapRule recorder - loadGhcSession recorder def{checkForImportCycles} + loadGhcSession recorder def{fullModuleGraph} getModIfaceFromDiskRule recorder getModIfaceFromDiskAndIndexRule recorder getModIfaceRule recorder getModSummaryRule templateHaskellWarning recorder getModuleGraphRule recorder + getFileHashRule recorder knownFilesRule recorder getClientSettingsRule recorder getHieAstsRule recorder @@ -1252,6 +1296,19 @@ persistentDocMapRule persistentImportMapRule getLinkableRule recorder + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModuleGraphTransDepsFingerprints file -> do + di <- useNoFile_ GetModuleGraph + let finger = lookupFingerprint file di (depTransDepsFingerprints di) + return (fingerprintToBS <$> finger, ([], finger)) + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModuleGraphTransReverseDepsFingerprints file -> do + di <- useNoFile_ GetModuleGraph + let finger = lookupFingerprint file di (depTransReverseDepsFingerprints di) + return (fingerprintToBS <$> finger, ([], finger)) + defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GetModuleGraphImmediateReverseDepsFingerprints file -> do + di <- useNoFile_ GetModuleGraph + let finger = lookupFingerprint file di (depImmediateReverseDepsFingerprints di) + return (fingerprintToBS <$> finger, ([], finger)) + -- | Get HieFile for haskell file on NormalizedFilePath getHieFile :: NormalizedFilePath -> Action (Maybe HieFile) diff --git a/src/Development/IDE/Core/Service.hs b/src/Development/IDE/Core/Service.hs --- a/src/Development/IDE/Core/Service.hs +++ b/src/Development/IDE/Core/Service.hs @@ -1,9 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} -- | A Shake implementation of the compiler service, built -- using the "Shaker" abstraction layer for in-memory use. @@ -19,20 +17,22 @@ ) where import Control.Applicative ((<|>)) +import Control.Concurrent.STM (newTVarIO) +import Control.Monad.IO.Class (liftIO) import Development.IDE.Core.Debouncer import Development.IDE.Core.FileExists (fileExistsRules) import Development.IDE.Core.OfInterest hiding (Log, LogShake) import Development.IDE.Graph -import Development.IDE.Types.Logger as Logger (Logger, - Pretty (pretty), +import Development.IDE.Session (SessionLoaderPendingBarrierVar (..)) +import Development.IDE.Types.Options (IdeOptions (..)) +import Ide.Logger as Logger (Pretty (pretty), Priority (Debug), Recorder, WithPriority, cmapWithPrio) -import Development.IDE.Types.Options (IdeOptions (..)) import Ide.Plugin.Config +import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP -import qualified Language.LSP.Types as LSP import Control.Monad import qualified Development.IDE.Core.FileExists as FileExists @@ -52,10 +52,11 @@ instance Pretty Log where pretty = \case - LogShake log -> pretty log - LogOfInterest log -> pretty log - LogFileExists log -> pretty log + LogShake msg -> pretty msg + LogOfInterest msg -> pretty msg + LogFileExists msg -> pretty msg + ------------------------------------------------------------ -- Exposed API @@ -65,14 +66,14 @@ -> IdePlugins IdeState -> Rules () -> Maybe (LSP.LanguageContextEnv Config) - -> Logger -> Debouncer LSP.NormalizedUri -> IdeOptions -> WithHieDb - -> IndexQueue + -> ThreadQueue -> Monitoring + -> FilePath -- ^ Root directory see Note [Root Directory] -> IO IdeState -initialise recorder defaultConfig plugins mainRule lspEnv logger debouncer options withHieDb hiedbChan metrics = do +initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics rootDir = do shakeProfiling <- do let fromConf = optShakeProfiling options fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING" @@ -82,7 +83,6 @@ lspEnv defaultConfig plugins - logger debouncer shakeProfiling (optReportProgress options) @@ -91,11 +91,14 @@ hiedbChan (optShakeOptions options) metrics - $ do + (do + pendingBarrier <- liftIO $ newTVarIO Nothing + addIdeGlobal $ SessionLoaderPendingBarrierVar pendingBarrier addIdeGlobal $ GlobalIdeOptions options ofInterestRules (cmapWithPrio LogOfInterest recorder) fileExistsRules (cmapWithPrio LogFileExists recorder) lspEnv - mainRule + mainRule) + rootDir -- | Shutdown the Compiler Service. shutdown :: IdeState -> IO () diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -1,16 +1,12 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TypeFamilies #-} -- | A Shake implementation of the compiler service. -- @@ -26,15 +22,17 @@ -- always stored as real Haskell values, whereas Shake serialises all 'A' values -- between runs. To deserialise a Shake value, we just consult Values. module Development.IDE.Core.Shake( - IdeState, shakeSessionInit, shakeExtras, shakeDb, + IdeState, shakeSessionInit, shakeExtras, shakeDb, rootDir, ShakeExtras(..), getShakeExtras, getShakeExtrasRules, - KnownTargets, Target(..), toKnownFiles, - IdeRule, IdeResult, + KnownTargets(..), Target(..), toKnownFiles, unionKnownTargets, mkKnownTargets, + IdeRule, IdeResult, RestartQueue, GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), shakeOpen, shakeShut, shakeEnqueue, newSession, use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction, + useWithSeparateFingerprintRule, + useWithSeparateFingerprintRule_, FastResult(..), use_, useNoFile_, uses_, useWithStale, usesWithStale, @@ -55,14 +53,13 @@ HLS.getClientConfig, getPluginConfigAction, knownTargets, - setPriority, ideLogger, actionLogger, getVirtualFile, FileVersion(..), - Priority(..), updatePositionMapping, - deleteValue, recordDirtyKeys, + updatePositionMappingHelper, + deleteValue, WithProgressFunc, WithIndefiniteProgressFunc, ProgressEvent(..), DelayedAction, mkDelayedAction, @@ -77,7 +74,10 @@ garbageCollectDirtyKeys, garbageCollectDirtyKeysOlderThan, Log(..), - VFSModified(..), getClientConfigAction + VFSModified(..), getClientConfigAction, + ThreadQueue(..), + runWithSignal, + askShake ) where import Control.Concurrent.Async @@ -86,12 +86,14 @@ import Control.Concurrent.Strict import Control.DeepSeq import Control.Exception.Extra hiding (bracket_) +import Control.Lens ((%~), (&), (?~)) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.Maybe import Data.Aeson (Result (Success), toJSON) +import qualified Data.Aeson.Types as A import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS8 import Data.Coerce (coerce) @@ -99,14 +101,13 @@ import Data.Dynamic import Data.EnumMap.Strict (EnumMap) import qualified Data.EnumMap.Strict as EM -import Data.Foldable (find, for_, toList) +import Data.Foldable (find, for_) import Data.Functor ((<&>)) import Data.Functor.Identity import Data.Hashable import qualified Data.HashMap.Strict as HMap import Data.HashSet (HashSet) import qualified Data.HashSet as HSet -import Data.IORef import Data.List.Extra (foldl', partition, takeEnd) import qualified Data.Map.Strict as Map @@ -126,18 +127,25 @@ import Development.IDE.Core.PositionMapping import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes +import Development.IDE.Types.Options as Options +import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Server as LSP + import Development.IDE.Core.Tracing +import Development.IDE.Core.WorkerThread +#if MIN_VERSION_ghc(9,13,0) import Development.IDE.GHC.Compat (NameCache, - NameCacheUpdater (..), + NameCacheUpdater, + newNameCache) +#else +import Development.IDE.GHC.Compat (NameCache, + NameCacheUpdater, initNameCache, - knownKeyNames, - mkSplitUniqSupply) -#if !MIN_VERSION_ghc(9,3,0) -import Development.IDE.GHC.Compat (upNameCache) + knownKeyNames) #endif -import qualified Data.Aeson.Types as A import Development.IDE.GHC.Orphans () -import Development.IDE.Graph hiding (ShakeValue) +import Development.IDE.Graph hiding (ShakeValue, + action) import qualified Development.IDE.Graph as Shake import Development.IDE.Graph.Database (ShakeDatabase, shakeGetBuildStep, @@ -148,47 +156,53 @@ import Development.IDE.Graph.Rule import Development.IDE.Types.Action import Development.IDE.Types.Diagnostics -import Development.IDE.Types.Exports +import Development.IDE.Types.Exports hiding (exportsMapSize) import qualified Development.IDE.Types.Exports as ExportsMap import Development.IDE.Types.KnownTargets import Development.IDE.Types.Location -import Development.IDE.Types.Logger hiding (Priority) -import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Monitoring (Monitoring (..)) -import Development.IDE.Types.Options import Development.IDE.Types.Shake import qualified Focus import GHC.Fingerprint import GHC.Stack (HasCallStack) +import GHC.TypeLits (KnownSymbol) import HieDb.Types +import Ide.Logger hiding (Priority) +import qualified Ide.Logger as Logger import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS -import Ide.Types (IdePlugins (IdePlugins), - PluginDescriptor (pluginId), - PluginId) -import Language.LSP.Diagnostics -import qualified Language.LSP.Server as LSP -import Language.LSP.Types -import qualified Language.LSP.Types as LSP -import Language.LSP.Types.Capabilities +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import qualified Language.LSP.Protocol.Types as LSP import Language.LSP.VFS hiding (start) import qualified "list-t" ListT -import OpenTelemetry.Eventlog +import OpenTelemetry.Eventlog hiding (addEvent) +import qualified Prettyprinter as Pretty import qualified StmContainers.Map as STM import System.FilePath hiding (makeRelative) import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra +import UnliftIO (MonadUnliftIO (withRunInIO)) + data Log = LogCreateHieDbExportsMapStart | LogCreateHieDbExportsMapFinish !Int - | LogBuildSessionRestart !String ![DelayedActionInternal] !(KeySet) !Seconds !(Maybe FilePath) + | LogBuildSessionRestart !String ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath) | LogBuildSessionRestartTakingTooLong !Seconds | LogDelayedAction !(DelayedAction ()) !Seconds | LogBuildSessionFinish !(Maybe SomeException) | LogDiagsDiffButNoLspEnv ![FileDiagnostic] | LogDefineEarlyCutoffRuleNoDiagHasDiag !FileDiagnostic | LogDefineEarlyCutoffRuleCustomNewnessHasDiag !FileDiagnostic + | LogCancelledAction !T.Text + | LogSessionInitialised + | LogLookupPersistentKey !T.Text + | LogShakeGarbageCollection !T.Text !Int !Seconds + -- * OfInterest Log messages + | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)] deriving Show instance Pretty Log where @@ -205,10 +219,10 @@ , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ] LogBuildSessionRestartTakingTooLong seconds -> "Build restart is taking too long (" <> pretty seconds <> " seconds)" - LogDelayedAction delayedAction duration -> + LogDelayedAction delayedAct seconds -> hsep - [ "Finished:" <+> pretty (actionName delayedAction) - , "Took:" <+> pretty (showDuration duration) ] + [ "Finished:" <+> pretty (actionName delayedAct) + , "Took:" <+> pretty (showDuration seconds) ] LogBuildSessionFinish e -> vcat [ "Finished build session" @@ -222,30 +236,55 @@ LogDefineEarlyCutoffRuleCustomNewnessHasDiag fileDiagnostic -> "defineEarlyCutoff RuleWithCustomNewnessCheck - file diagnostic:" <+> pretty (showDiagnosticsColored [fileDiagnostic]) + LogCancelledAction action -> + pretty action <+> "was cancelled" + LogSessionInitialised -> "Shake session initialized" + LogLookupPersistentKey key -> + "LOOKUP PERSISTENT FOR:" <+> pretty key + LogShakeGarbageCollection label number duration -> + pretty label <+> "of" <+> pretty number <+> "keys (took " <+> pretty (showDuration duration) <> ")" + LogSetFilesOfInterest ofInterest -> + "Set files of interst to" <> Pretty.line + <> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest) -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by -- a worker thread. data HieDbWriter = HieDbWriter - { indexQueue :: IndexQueue - , indexPending :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing - , indexCompleted :: TVar Int -- ^ to report progress - , indexProgressToken :: Var (Maybe LSP.ProgressToken) - -- ^ This is a Var instead of a TVar since we need to do IO to initialise/update, so we need a lock + { indexQueue :: IndexQueue + , indexPending :: TVar (HMap.HashMap NormalizedFilePath Fingerprint) -- ^ Avoid unnecessary/out of date indexing + , indexCompleted :: TVar Int -- ^ to report progress + , indexProgressReporting :: ProgressReporting } -- | Actions to queue up on the index worker thread -- The inner `(HieDb -> IO ()) -> IO ()` wraps `HieDb -> IO ()` -- with (currently) retry functionality -type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) +type IndexQueue = TaskQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) +type RestartQueue = TaskQueue (IO ()) +type LoaderQueue = TaskQueue (IO ()) + +data ThreadQueue = ThreadQueue { + tIndexQueue :: IndexQueue + , tRestartQueue :: RestartQueue + , tLoaderQueue :: LoaderQueue +} + +-- Note [Semantic Tokens Cache Location] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- storing semantic tokens cache for each file in shakeExtras might +-- not be ideal, since it most used in LSP request handlers +-- instead of rules. We should consider moving it to a more +-- appropriate place in the future if we find one, store it for now. + -- information we stash inside the shakeExtra field data ShakeExtras = ShakeExtras { --eventer :: LSP.FromServerMessage -> IO () lspEnv :: Maybe (LSP.LanguageContextEnv Config) ,debouncer :: Debouncer NormalizedUri - ,logger :: Logger + ,shakeRecorder :: Recorder (WithPriority Log) ,idePlugins :: IdePlugins IdeState ,globals :: TVar (HMap.HashMap TypeRep Dynamic) -- ^ Registry of global state used by rules. @@ -253,27 +292,32 @@ ,state :: Values ,diagnostics :: STMDiagnosticStore ,hiddenDiagnostics :: STMDiagnosticStore - ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic] + ,publishedDiagnostics :: STM.Map NormalizedUri [FileDiagnostic] -- ^ This represents the set of diagnostics that we have published. -- Due to debouncing not every change might get published. + + ,semanticTokensCache:: STM.Map NormalizedFilePath SemanticTokens + -- ^ Cache of last response of semantic tokens for each file, + -- so we can compute deltas for semantic tokens(SMethod_TextDocumentSemanticTokensFullDelta). + -- putting semantic tokens cache and id in shakeExtras might not be ideal + -- see Note [Semantic Tokens Cache Location] + ,semanticTokensId :: TVar Int + -- ^ semanticTokensId is used to generate unique ids for each lsp response of semantic tokens. ,positionMapping :: STM.Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping)) -- ^ Map from a text document version to a PositionMapping that describes how to map -- positions in a version of that document to positions in the latest version -- First mapping is delta from previous version and second one is an - -- accumulation of all previous mappings. - ,progress :: ProgressReporting + -- accumulation to the current version. + ,progress :: PerFileProgressReporting ,ideTesting :: IdeTesting -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants ,restartShakeSession :: VFSModified -> String -> [DelayedAction ()] + -> IO [Key] -> IO () -#if MIN_VERSION_ghc(9,3,0) ,ideNc :: NameCache -#else - ,ideNc :: IORef NameCache -#endif -- | A mapping of module name to known target (or candidate targets, if missing) ,knownTargetsVar :: TVar (Hashed KnownTargets) -- | A mapping of exported identifiers for local modules. Updated on kick @@ -296,6 +340,10 @@ -- ^ Default HLS config, only relevant if the client does not provide any Config , dirtyKeys :: TVar KeySet -- ^ Set of dirty rule keys since the last Shake run + , restartQueue :: RestartQueue + -- ^ Queue of restart actions to be run. + , loaderQueue :: LoaderQueue + -- ^ Queue of loader actions to be run. } type WithProgressFunc = forall a. @@ -303,18 +351,23 @@ type WithIndefiniteProgressFunc = forall a. T.Text -> LSP.ProgressCancellable -> IO a -> IO a -type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe (Dynamic,PositionDelta,TextDocumentVersion)) +type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe (Dynamic,PositionDelta,Maybe Int32)) getShakeExtras :: Action ShakeExtras getShakeExtras = do + -- Will fail the action with a pattern match failure, but be caught Just x <- getShakeExtra @ShakeExtras return x getShakeExtrasRules :: Rules ShakeExtras getShakeExtrasRules = do - Just x <- getShakeExtraRules @ShakeExtras - return x + mExtras <- getShakeExtraRules @ShakeExtras + case mExtras of + Just x -> return x + -- This will actually crash HLS + Nothing -> liftIO $ fail "missing ShakeExtras" +-- See Note [Client configuration in Rules] -- | Returns the client configuration, creating a build dependency. -- You should always use this function when accessing client configuration -- from build rules. @@ -340,7 +393,7 @@ -- This is called when we don't already have a result, or computing the rule failed. -- The result of this function will always be marked as 'stale', and a 'proper' rebuild of the rule will -- be queued if the rule hasn't run before. -addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules () +addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,Maybe Int32))) -> Rules () addPersistentRule k getVal = do ShakeExtras{persistentKeys} <- getShakeExtrasRules void $ liftIO $ atomically $ modifyTVar' persistentKeys $ insertKeyMap (newKey k) (fmap (fmap (first3 toDyn)) . getVal) @@ -351,11 +404,12 @@ getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile) getVirtualFile nf = do vfs <- fmap _vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras - pure $! Map.lookup (filePathToUri' nf) vfs -- Don't leak a reference to the entire map + pure $! -- Don't leak a reference to the entire map + getVirtualFileFromVFS (VFS vfs) $ filePathToUri' nf -- Take a snapshot of the current LSP VFS vfsSnapshot :: Maybe (LSP.LanguageContextEnv a) -> IO VFS -vfsSnapshot Nothing = pure $ VFS mempty "" +vfsSnapshot Nothing = pure $ VFS mempty vfsSnapshot (Just lspEnv) = LSP.runLspT lspEnv LSP.getVirtualFiles @@ -375,9 +429,9 @@ let typ = typeRep (Proxy :: Proxy a) x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readTVarIO globals case x of - Just x - | Just x <- fromDynamic x -> pure x - | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")" + Just y + | Just z <- fromDynamic y -> pure z + | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep y) ++ ")" Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ getIdeGlobalAction :: forall a . (HasCallStack, IsIdeGlobal a) => Action a @@ -392,8 +446,8 @@ getIdeOptions :: Action IdeOptions getIdeOptions = do GlobalIdeOptions x <- getIdeGlobalAction - env <- lspEnv <$> getShakeExtras - case env of + mbEnv <- lspEnv <$> getShakeExtras + case mbEnv of Nothing -> return x Just env -> do config <- liftIO $ LSP.runLspT env HLS.getClientConfig @@ -417,7 +471,7 @@ | otherwise = do pmap <- readTVarIO persistentKeys mv <- runMaybeT $ do - liftIO $ Logger.logDebug (logger s) $ T.pack $ "LOOKUP PERSISTENT FOR: " ++ show k + liftIO $ logWith (shakeRecorder s) Debug $ LogLookupPersistentKey (T.pack $ show k) f <- MaybeT $ pure $ lookupKeyMap (newKey k) pmap (dv,del,ver) <- MaybeT $ runIdeAction "lastValueIO" s $ f file MaybeT $ pure $ (,del,ver) <$> fromDynamic dv @@ -425,14 +479,14 @@ Nothing -> atomicallyNamed "lastValueIO 1" $ do STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) state return Nothing - Just (v,del,ver) -> do - actual_version <- case ver of + Just (v,del,mbVer) -> do + actual_version <- case mbVer of Just ver -> pure (Just $ VFSVersion ver) Nothing -> (Just . ModificationTime <$> getModTime (fromNormalizedFilePath file)) `catch` (\(_ :: IOException) -> pure Nothing) atomicallyNamed "lastValueIO 2" $ do STM.focus (Focus.alter (alterValue $ Stale (Just del) actual_version (toDyn v))) (toKey k file) state - Just . (v,) . addDelta del <$> mappingForVersion positionMapping file actual_version + Just . (v,) . addOldDelta del <$> mappingForVersion positionMapping file actual_version -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics alterValue new Nothing = Just (ValueWithDiagnostics new mempty) -- If it wasn't in the map, give it empty diagnostics @@ -444,11 +498,11 @@ atomicallyNamed "lastValueIO 4" (STM.lookup (toKey k file) state) >>= \case Nothing -> readPersistent - Just (ValueWithDiagnostics v _) -> case v of + Just (ValueWithDiagnostics value _) -> case value of Succeeded ver (fromDynamic -> Just v) -> atomicallyNamed "lastValueIO 5" $ Just . (v,) <$> mappingForVersion positionMapping file ver Stale del ver (fromDynamic -> Just v) -> - atomicallyNamed "lastValueIO 6" $ Just . (v,) . maybe id addDelta del <$> mappingForVersion positionMapping file ver + atomicallyNamed "lastValueIO 6" $ Just . (v,) . maybe id addOldDelta del <$> mappingForVersion positionMapping file ver Failed p | not p -> readPersistent _ -> pure Nothing @@ -484,6 +538,33 @@ -- ^ Closes the Shake session } +-- Note [Root Directory] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- We keep track of the root directory explicitly, which is the directory of the project root. +-- We might be setting it via these options with decreasing priority: +-- +-- 1. from LSP workspace root, `resRootPath` in `LanguageContextEnv`. +-- 2. command line (--cwd) +-- 3. default to the current directory. +-- +-- Using `getCurrentDirectory` makes it more difficult to run the tests, as we spawn one thread of HLS per test case. +-- If we modify the global Variable CWD, via `setCurrentDirectory`, all other test threads are suddenly affected, +-- forcing us to run all integration tests sequentially. +-- +-- Also, there might be a race condition if we depend on the current directory, as some plugin might change it. +-- e.g. stylish's `loadConfig`. https://github.com/haskell/haskell-language-server/issues/4234 +-- +-- But according to https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_workspaceFolders +-- The root dir is deprecated, that means we should cleanup dependency on the project root(Or $CWD) thing gradually, +-- so multi-workspaces can actually be supported when we use absolute path everywhere(might also need some high level design). +-- That might not be possible unless we have everything adapted to it, like 'hlint' and 'evaluation of template haskell'. +-- But we should still be working towards the goal. +-- +-- We can drop it in the future once: +-- 1. We can get rid all the usages of root directory in the codebase. +-- 2. LSP version we support actually removes the root directory from the protocol. +-- + -- | A Shake database plus persistent store. Can be thought of as storing -- mappings from @(FilePath, k)@ to @RuleResult k@. data IdeState = IdeState @@ -492,6 +573,8 @@ ,shakeExtras :: ShakeExtras ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) ,stopMonitoring :: IO () + -- | See Note [Root Directory] + ,rootDir :: FilePath } @@ -520,26 +603,17 @@ -- | Delete the value stored for a given ide build key +-- and return the key that was deleted. deleteValue :: Shake.ShakeValue k => ShakeExtras -> k -> NormalizedFilePath - -> STM () -deleteValue ShakeExtras{dirtyKeys, state} key file = do + -> STM [Key] +deleteValue ShakeExtras{state} key file = do STM.delete (toKey key file) state - modifyTVar' dirtyKeys $ insertKeySet (toKey key file) + return [toKey key file] -recordDirtyKeys - :: Shake.ShakeValue k - => ShakeExtras - -> k - -> [NormalizedFilePath] - -> STM (IO ()) -recordDirtyKeys ShakeExtras{dirtyKeys} key file = do - modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x (toKey key <$> file) - return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do - addEvent (fromString $ unlines $ "dirty " <> show key : map fromNormalizedFilePath file) -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. getValues :: @@ -580,29 +654,32 @@ -> Maybe (LSP.LanguageContextEnv Config) -> Config -> IdePlugins IdeState - -> Logger -> Debouncer NormalizedUri -> Maybe FilePath -> IdeReportProgress -> IdeTesting -> WithHieDb - -> IndexQueue + -> ThreadQueue -> ShakeOptions -> Monitoring -> Rules () + -> FilePath + -- ^ Root directory, this one might be picking up from `LanguageContextEnv`'s `resRootPath` + -- , see Note [Root Directory] -> IO IdeState -shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer +shakeOpen recorder lspEnv defaultConfig idePlugins debouncer shakeProfileDir (IdeReportProgress reportProgress) - ideTesting@(IdeTesting testing) - withHieDb indexQueue opts monitoring rules = mdo - let log :: Logger.Priority -> Log -> IO () - log = logWith recorder + ideTesting + withHieDb threadQueue opts monitoring rules rootDir = mdo + -- see Note [Serializing runs in separate thread] + let indexQueue = tIndexQueue threadQueue + restartQueue = tRestartQueue threadQueue + loaderQueue = tLoaderQueue threadQueue -#if MIN_VERSION_ghc(9,3,0) - ideNc <- initNameCache 'r' knownKeyNames +#if MIN_VERSION_ghc(9,13,0) + ideNc <- newNameCache #else - us <- mkSplitUniqSupply 'r' - ideNc <- newIORef (initNameCache us knownKeyNames) + ideNc <- initNameCache 'r' knownKeyNames #endif shakeExtras <- do globals <- newTVarIO HMap.empty @@ -610,36 +687,39 @@ diagnostics <- STM.newIO hiddenDiagnostics <- STM.newIO publishedDiagnostics <- STM.newIO + semanticTokensCache <- STM.newIO positionMapping <- STM.newIO - knownTargetsVar <- newTVarIO $ hashed HMap.empty + knownTargetsVar <- newTVarIO $ hashed emptyKnownTargets let restartShakeSession = shakeRestart recorder ideState persistentKeys <- newTVarIO mempty indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 - indexProgressToken <- newVar Nothing + semanticTokensId <- newTVarIO 0 + indexProgressReporting <- progressReportingNoTrace + (liftM2 (+) (length <$> readTVar indexPending) (readTVar indexCompleted)) + (readTVar indexCompleted) + lspEnv "Indexing" optProgressStyle let hiedbWriter = HieDbWriter{..} exportsMap <- newTVarIO mempty -- lazily initialize the exports map with the contents of the hiedb -- TODO: exceptions can be swallowed here? _ <- async $ do - log Debug LogCreateHieDbExportsMapStart + logWith recorder Debug LogCreateHieDbExportsMapStart em <- createExportsMapHieDb withHieDb atomically $ modifyTVar' exportsMap (<> em) - log Debug $ LogCreateHieDbExportsMapFinish (ExportsMap.size em) + logWith recorder Debug $ LogCreateHieDbExportsMapFinish (ExportsMap.size em) - progress <- do - let (before, after) = if testing then (0,0.1) else (0.1,0.1) + progress <- if reportProgress - then delayedProgressReporting before after lspEnv optProgressStyle - else noProgressReporting + then progressReporting lspEnv "Processing" optProgressStyle + else noPerFileProgressReporting actionQueue <- newQueue let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv - dirtyKeys <- newTVarIO mempty -- Take one VFS snapshot at the start vfsVar <- newTVarIO =<< vfsSnapshot lspEnv - pure ShakeExtras{..} + pure ShakeExtras{shakeRecorder = recorder, ..} shakeDb <- shakeNewDatabase opts { shakeExtra = newShakeExtra shakeExtras } @@ -680,13 +760,13 @@ -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO () -shakeSessionInit recorder ide@IdeState{..} = do +shakeSessionInit recorder IdeState{..} = do -- Take a snapshot of the VFS - it should be empty as we've received no notifications -- till now, but it can't hurt to be in sync with the `lsp` library. vfs <- vfsSnapshot (lspEnv shakeExtras) initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit" putMVar shakeSession initSession - logDebug (ideLogger ide) "Shake session initialized" + logWith recorder Debug LogSessionInitialised shakeShut :: IdeState -> IO () shakeShut IdeState{..} = do @@ -696,6 +776,7 @@ for_ runner cancelShakeSession void $ shakeDatabaseProfile shakeDb progressStop $ progress shakeExtras + progressStop $ indexProgressReporting $ hiedbWriter shakeExtras stopMonitoring @@ -721,31 +802,36 @@ extras <- ask liftIO $ shakeEnqueue extras a + -- | Restart the current 'ShakeSession' with the given system actions. -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued. -shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO () -shakeRestart recorder IdeState{..} vfs reason acts = - withMVar' - shakeSession - (\runner -> do - let log = logWith recorder - (stopTime,()) <- duration $ logErrorAfter 10 recorder $ cancelShakeSession runner - res <- shakeDatabaseProfile shakeDb - backlog <- readTVarIO $ dirtyKeys shakeExtras - queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras +shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () +shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = + void $ awaitRunInThread (restartQueue shakeExtras) $ do + withMVar' + shakeSession + (\runner -> do + (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner + keys <- ioActionBetweenShakeSession + -- it is every important to update the dirty keys after we enter the critical section + -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] + atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys + res <- shakeDatabaseProfile shakeDb + backlog <- readTVarIO $ dirtyKeys shakeExtras + queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras - -- this log is required by tests - log Debug $ LogBuildSessionRestart reason queue backlog stopTime res - ) - -- It is crucial to be masked here, otherwise we can get killed - -- between spawning the new thread and updating shakeSession. - -- See https://github.com/haskell/ghcide/issues/79 - (\() -> do - (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) + -- this log is required by tests + logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res + ) + -- It is crucial to be masked here, otherwise we can get killed + -- between spawning the new thread and updating shakeSession. + -- See https://github.com/haskell/ghcide/issues/79 + (\() -> do + (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) where - logErrorAfter :: Seconds -> Recorder (WithPriority Log) -> IO () -> IO () - logErrorAfter seconds recorder action = flip withAsync (const action) $ do + logErrorAfter :: Seconds -> IO () -> IO () + logErrorAfter seconds action = flip withAsync (const action) $ do sleep seconds logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) @@ -755,16 +841,16 @@ -- -- Appropriate for user actions other than edits. shakeEnqueue :: ShakeExtras -> DelayedAction a -> IO (IO a) -shakeEnqueue ShakeExtras{actionQueue, logger} act = do +shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do (b, dai) <- instantiateDelayedAction act atomicallyNamed "actionQueue - push" $ pushQueue dai actionQueue - let wait' b = - waitBarrier b `catches` + let wait' barrier = + waitBarrier barrier `catches` [ Handler(\BlockedIndefinitelyOnMVar -> fail $ "internal bug: forever blocked on MVar for " <> actionName act) , Handler (\e@AsyncCancelled -> do - logPriority logger Debug $ T.pack $ actionName act <> " was cancelled" + logWith shakeRecorder Debug $ LogCancelledAction (T.pack $ actionName act) atomicallyNamed "actionQueue - abort" $ abortQueue dai actionQueue throw e) @@ -888,15 +974,14 @@ garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key] garbageCollectKeys label maxAge checkParents agedKeys = do start <- liftIO offsetTime - ShakeExtras{state, dirtyKeys, lspEnv, logger, ideTesting} <- getShakeExtras + ShakeExtras{state, dirtyKeys, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras (n::Int, garbage) <- liftIO $ foldM (removeDirtyKey dirtyKeys state) (0,[]) agedKeys t <- liftIO start when (n>0) $ liftIO $ do - logDebug logger $ T.pack $ - label <> " of " <> show n <> " keys (took " <> showDuration t <> ")" + logWith shakeRecorder Debug $ LogShakeGarbageCollection (T.pack label) n t when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $ - LSP.sendNotification (SCustomMethod "ghcide/GC") + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC")) (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage) return garbage @@ -958,13 +1043,23 @@ => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping)) useWithStale key file = runIdentity <$> usesWithStale key (Identity file) --- | Request a Rule result, it not available return the last computed result which may be stale. --- Errors out if none available. +-- |Request a Rule result, it not available return the last computed result +-- which may be stale. +-- +-- Throws an `BadDependency` exception which is caught by the rule system if +-- none available. +-- +-- WARNING: Not suitable for PluginHandlers. Use `useWithStaleE` instead. useWithStale_ :: IdeRule k v => k -> NormalizedFilePath -> Action (v, PositionMapping) useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file) --- | Plural version of 'useWithStale_' +-- |Plural version of 'useWithStale_' +-- +-- Throws an `BadDependency` exception which is caught by the rule system if +-- none available. +-- +-- WARNING: Not suitable for PluginHandlers. usesWithStale_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f (v, PositionMapping)) usesWithStale_ key files = do res <- usesWithStale key files @@ -978,7 +1073,7 @@ -- -- Run via 'runIdeAction'. newtype IdeAction a = IdeAction { runIdeActionT :: (ReaderT ShakeExtras IO) a } - deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad) + deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad, Semigroup) runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a runIdeAction _herald s i = runReaderT (runIdeActionT i) s @@ -987,13 +1082,8 @@ askShake = ask -#if MIN_VERSION_ghc(9,3,0) mkUpdater :: NameCache -> NameCacheUpdater mkUpdater = id -#else -mkUpdater :: IORef NameCache -> NameCacheUpdater -mkUpdater ref = NCU (upNameCache ref) -#endif -- | A (maybe) stale result now, and an up to date one later data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: IO (Maybe a) } @@ -1013,7 +1103,7 @@ -- Async trigger the key to be built anyway because we want to -- keep updating the value in the key. - wait <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ fromNormalizedFilePath file) Debug $ use key file + waitValue <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ fromNormalizedFilePath file) Debug $ use key file s@ShakeExtras{state} <- askShake r <- liftIO $ atomicallyNamed "useStateFast" $ getValues state key file @@ -1024,23 +1114,35 @@ res <- lastValueIO s key file case res of Nothing -> do - a <- wait + a <- waitValue pure $ FastResult ((,zeroMapping) <$> a) (pure a) - Just _ -> pure $ FastResult res wait + Just _ -> pure $ FastResult res waitValue -- Otherwise, use the computed value even if it's out of date. Just _ -> do res <- lastValueIO s key file - pure $ FastResult res wait + pure $ FastResult res waitValue useNoFile :: IdeRule k v => k -> Action (Maybe v) useNoFile key = use key emptyFilePath +-- Requests a rule if available. +-- +-- Throws an `BadDependency` exception which is caught by the rule system if +-- none available. +-- +-- WARNING: Not suitable for PluginHandlers. Use `useE` instead. use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v use_ key file = runIdentity <$> uses_ key (Identity file) useNoFile_ :: IdeRule k v => k -> Action v useNoFile_ key = use_ key emptyFilePath +-- |Plural version of `use_` +-- +-- Throws an `BadDependency` exception which is caught by the rule system if +-- none available. +-- +-- WARNING: Not suitable for PluginHandlers. Use `usesE` instead. uses_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (f v) uses_ key files = do res <- uses key files @@ -1063,6 +1165,23 @@ -- whether the rule succeeded or not. traverse (lastValue key) files +-- we use separate fingerprint rules to trigger the rebuild of the rule +useWithSeparateFingerprintRule + :: (IdeRule k v, IdeRule k1 Fingerprint) + => k1 -> k -> NormalizedFilePath -> Action (Maybe v) +useWithSeparateFingerprintRule fingerKey key file = do + _ <- use fingerKey file + useWithoutDependency key emptyFilePath + +-- we use separate fingerprint rules to trigger the rebuild of the rule +useWithSeparateFingerprintRule_ + :: (IdeRule k v, IdeRule k1 Fingerprint) + => k1 -> k -> NormalizedFilePath -> Action v +useWithSeparateFingerprintRule_ fingerKey key file = do + useWithSeparateFingerprintRule fingerKey key file >>= \case + Just v -> return v + Nothing -> liftIO $ throwIO $ BadDependency (show key) + useWithoutDependency :: IdeRule k v => k -> NormalizedFilePath -> Action (Maybe v) useWithoutDependency key file = @@ -1087,7 +1206,7 @@ extras <- getShakeExtras let diagnostics ver diags = do traceDiagnostics diags - updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags + updateFileDiagnostics recorder file ver (newKey key) extras diags defineEarlyCutoff' diagnostics (==) key file old mode $ const $ op key file defineEarlyCutoff recorder (RuleNoDiagnostics op) = addRule $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file mode traceA $ \traceDiagnostics -> do let diagnostics _ver diags = do @@ -1106,7 +1225,7 @@ extras <- getShakeExtras let diagnostics ver diags = do traceDiagnostics diags - updateFileDiagnostics recorder file ver (newKey key) extras . map (\(_,y,z) -> (y,z)) $ diags + updateFileDiagnostics recorder file ver (newKey key) extras diags defineEarlyCutoff' diagnostics (==) key file old mode $ op key file defineNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action v) -> Rules () @@ -1116,12 +1235,12 @@ defineEarlyCutOffNoFile :: IdeRule k v => Recorder (WithPriority Log) -> (k -> Action (BS.ByteString, v)) -> Rules () defineEarlyCutOffNoFile recorder f = defineEarlyCutoff recorder $ RuleNoDiagnostics $ \k file -> do - if file == emptyFilePath then do (hash, res) <- f k; return (Just hash, Just res) else + if file == emptyFilePath then do (hashString, res) <- f k; return (Just hashString, Just res) else fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file" defineEarlyCutoff' :: forall k v. IdeRule k v - => (TextDocumentVersion -> [FileDiagnostic] -> Action ()) -- ^ update diagnostics + => (Maybe Int32 -> [FileDiagnostic] -> Action ()) -- ^ update diagnostics -- | compare current and previous for freshness -> (BS.ByteString -> BS.ByteString -> Bool) -> k @@ -1130,20 +1249,21 @@ -> RunMode -> (Value v -> Action (Maybe BS.ByteString, IdeResult v)) -> Action (RunResult (A (RuleResult k))) -defineEarlyCutoff' doDiagnostics cmp key file old mode action = do +defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras options <- getIdeOptions - (if optSkipProgress options key then id else inProgress progress file) $ do - val <- case old of + let trans g x = withRunInIO $ \run -> g (run x) + (if optSkipProgress options key then id else trans (inProgress progress file)) $ do + val <- case mbOld of Just old | mode == RunDependenciesSame -> do - v <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file - case v of + mbValue <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file + case mbValue of -- No changes in the dependencies and we have -- an existing successful result. Just (v@(Succeeded _ x), diags) -> do ver <- estimateFileVersionUnsafely key (Just x) file doDiagnostics (vfsVersion =<< ver) $ Vector.toList diags - return $ Just $ RunResult ChangedNothing old $ A v + return $ Just $ RunResult ChangedNothing old (A v) $ return () _ -> return Nothing _ -> -- assert that a "clean" rule is never a cache miss @@ -1157,19 +1277,18 @@ Just (Succeeded ver v, _) -> Stale Nothing ver v Just (Stale d ver v, _) -> Stale d ver v Just (Failed b, _) -> Failed b - (bs, (diags, res)) <- actionCatch + (mbBs, (diags, mbRes)) <- actionCatch (do v <- action staleV; liftIO $ evaluate $ force v) $ \(e :: SomeException) -> do - pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing)) + pure (Nothing, ([ideErrorText file (T.pack $ show (key, file) ++ show e) | not $ isBadDependency e],Nothing)) - ver <- estimateFileVersionUnsafely key res file - (bs, res) <- case res of + ver <- estimateFileVersionUnsafely key mbRes file + (bs, res) <- case mbRes of Nothing -> do - pure (toShakeValue ShakeStale bs, staleV) - Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded ver v) - liftIO $ atomicallyNamed "define - write" $ setValues state key file res (Vector.fromList diags) + pure (toShakeValue ShakeStale mbBs, staleV) + Just v -> pure (maybe ShakeNoCutoff ShakeResult mbBs, Succeeded ver v) doDiagnostics (vfsVersion =<< ver) diags - let eq = case (bs, fmap decodeShakeValue old) of + let eq = case (bs, fmap decodeShakeValue mbOld) of (ShakeResult a, Just (ShakeResult b)) -> cmp a b (ShakeStale a, Just (ShakeStale b)) -> cmp a b -- If we do not have a previous result @@ -1177,18 +1296,19 @@ _ -> False return $ RunResult (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) - (encodeShakeValue bs) $ - A res - liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (deleteKeySet $ toKey key file) + (encodeShakeValue bs) + (A res) $ do + -- this hook needs to be run in the same transaction as the key is marked clean + -- see Note [Housekeeping rule cache and dirty key outside of hls-graph] + setValues state key file res (Vector.fromList diags) + modifyTVar' dirtyKeys (deleteKeySet $ toKey key file) return res where -- Highly unsafe helper to compute the version of a file -- without creating a dependency on the GetModificationTime rule -- (and without creating cycles in the build graph). estimateFileVersionUnsafely - :: forall k v - . IdeRule k v - => k + :: k -> Maybe v -> NormalizedFilePath -> Action (Maybe FileVersion) @@ -1205,6 +1325,32 @@ -- * creating bogus "file does not exists" diagnostics | otherwise = useWithoutDependency (GetModificationTime_ False) fp +-- Note [Housekeeping rule cache and dirty key outside of hls-graph] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Hls-graph contains its own internal running state for each key in the shakeDatabase. +-- ShakeExtras contains `state` field (rule result cache) and `dirtyKeys` (keys that became +-- dirty in between build sessions) that is not visible to the hls-graph +-- Essentially, we need to keep the rule cache and dirty key and hls-graph's internal state +-- in sync. + +-- 1. A dirty key collected in a session should not be removed from dirty keys in the same session. +-- Since if we clean out the dirty key in the same session, +-- 1.1. we will lose the chance to dirty its reverse dependencies. Since it only happens during session restart. +-- 1.2. a key might be marked as dirty in ShakeExtras while it's being recomputed by hls-graph which could lead to it's premature removal from dirtyKeys. +-- See issue https://github.com/haskell/haskell-language-server/issues/4093 for more details. + +-- 2. When a key is marked clean in the hls-graph's internal running +-- state, the rule cache and dirty keys are updated in the same transaction. +-- otherwise, some situations like the following can happen: +-- thread 1: hls-graph session run a key +-- thread 1: defineEarlyCutoff' run the action for the key +-- thread 1: the action is done, rule cache and dirty key are updated +-- thread 2: we restart the hls-graph session, thread 1 is killed, the +-- hls-graph's internal state is not updated. +-- This is problematic with early cut off because we are having a new rule cache matching the +-- old hls-graph's internal state, which might case it's reverse dependency to skip the recomputation. +-- See https://github.com/haskell/haskell-language-server/issues/4194 for more details. + traceA :: A v -> String traceA (A Failed{}) = "Failed" traceA (A Stale{}) = "Stale" @@ -1213,105 +1359,97 @@ updateFileDiagnostics :: MonadIO m => Recorder (WithPriority Log) -> NormalizedFilePath - -> TextDocumentVersion + -> Maybe Int32 -> Key -> ShakeExtras - -> [(ShowDiagnostic,Diagnostic)] -- ^ current results + -> [FileDiagnostic] -- ^ current results -> m () -updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 = +updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 = do liftIO $ withTrace ("update diagnostics " <> fromString(fromNormalizedFilePath fp)) $ \ addTag -> do addTag "key" (show k) - let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current + let (currentShown, currentHidden) = partition ((== ShowDiag) . fdShouldShowDiagnostic) current uri = filePathToUri' fp addTagUnsafe :: String -> String -> String -> a -> a addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v - update :: (forall a. String -> String -> a -> a) -> [Diagnostic] -> STMDiagnosticStore -> STM [Diagnostic] - update addTagUnsafe new store = addTagUnsafe "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafe uri ver (renderKey k) new store - current = second diagsFromRule <$> current0 + update :: (forall a. String -> String -> a -> a) -> [FileDiagnostic] -> STMDiagnosticStore -> STM [FileDiagnostic] + update addTagUnsafeMethod new store = addTagUnsafeMethod "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafeMethod uri ver (renderKey k) new store + current = map (fdLspDiagnosticL %~ diagsFromRule) current0 addTag "version" (show ver) mask_ $ do -- Mask async exceptions to ensure that updated diagnostics are always -- published. Otherwise, we might never publish certain diagnostics if -- an exception strikes between modifyVar but before -- publishDiagnosticsNotification. - newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") (map snd currentShown) diagnostics - _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") (map snd currentHidden) hiddenDiagnostics - let uri = filePathToUri' fp + newDiags <- liftIO $ atomicallyNamed "diagnostics - update" $ update (addTagUnsafe "shown ") currentShown diagnostics + _ <- liftIO $ atomicallyNamed "diagnostics - hidden" $ update (addTagUnsafe "hidden ") currentHidden hiddenDiagnostics + let uri' = filePathToUri' fp let delay = if null newDiags then 0.1 else 0 - registerEvent debouncer delay uri $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do - join $ mask_ $ do - lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri publishedDiagnostics - let action = when (lastPublish /= newDiags) $ case lspEnv of + registerEvent debouncer delay uri' $ withTrace ("report diagnostics " <> fromString (fromNormalizedFilePath fp)) $ \tag -> do + join $ mask_ $ do + lastPublish <- atomicallyNamed "diagnostics - publish" $ STM.focus (Focus.lookupWithDefault [] <* Focus.insert newDiags) uri' publishedDiagnostics + let action = when (lastPublish /= newDiags) $ case lspEnv of Nothing -> -- Print an LSP event. - logWith recorder Info $ LogDiagsDiffButNoLspEnv (map (fp, ShowDiag,) newDiags) + logWith recorder Info $ LogDiagsDiffButNoLspEnv newDiags Just env -> LSP.runLspT env $ do liftIO $ tag "count" (show $ Prelude.length newDiags) liftIO $ tag "key" (show k) - LSP.sendNotification LSP.STextDocumentPublishDiagnostics $ - LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) (List newDiags) - return action + LSP.sendNotification SMethod_TextDocumentPublishDiagnostics $ + LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) (map fdLspDiagnostic newDiags) + return action where diagsFromRule :: Diagnostic -> Diagnostic diagsFromRule c@Diagnostic{_range} - | coerce ideTesting = c - {_relatedInformation = - Just $ List [ - DiagnosticRelatedInformation + | coerce ideTesting = c & L.relatedInformation ?~ + [ DiagnosticRelatedInformation (Location (filePathToUri $ fromNormalizedFilePath fp) _range ) (T.pack $ show k) - ] - } + ] | otherwise = c -newtype Priority = Priority Double - -setPriority :: Priority -> Action () -setPriority (Priority p) = reschedule p - -ideLogger :: IdeState -> Logger -ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger +ideLogger :: IdeState -> Recorder (WithPriority Log) +ideLogger IdeState{shakeExtras=ShakeExtras{shakeRecorder}} = shakeRecorder -actionLogger :: Action Logger -actionLogger = do - ShakeExtras{logger} <- getShakeExtras - return logger +actionLogger :: Action (Recorder (WithPriority Log)) +actionLogger = shakeRecorder <$> getShakeExtras -------------------------------------------------------------------------------- -type STMDiagnosticStore = STM.Map NormalizedUri StoreItem +type STMDiagnosticStore = STM.Map NormalizedUri StoreItem' +data StoreItem' = StoreItem' (Maybe Int32) FileDiagnosticsBySource +type FileDiagnosticsBySource = Map.Map (Maybe T.Text) (SL.SortedList FileDiagnostic) -getDiagnosticsFromStore :: StoreItem -> [Diagnostic] -getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags +getDiagnosticsFromStore :: StoreItem' -> [FileDiagnostic] +getDiagnosticsFromStore (StoreItem' _ diags) = concatMap SL.fromSortedList $ Map.elems diags updateSTMDiagnostics :: (forall a. String -> String -> a -> a) -> STMDiagnosticStore -> NormalizedUri -> - TextDocumentVersion -> - DiagnosticsBySource -> - STM [LSP.Diagnostic] + Maybe Int32 -> + FileDiagnosticsBySource -> + STM [FileDiagnostic] updateSTMDiagnostics addTag store uri mv newDiagsBySource = getDiagnosticsFromStore . fromJust <$> STM.focus (Focus.alter update *> Focus.lookup) uri store where - update (Just(StoreItem mvs dbs)) + update (Just(StoreItem' mvs dbs)) | addTag "previous version" (show mvs) $ addTag "previous count" (show $ Prelude.length $ filter (not.null) $ Map.elems dbs) False = undefined - | mvs == mv = Just (StoreItem mv (newDiagsBySource <> dbs)) - update _ = Just (StoreItem mv newDiagsBySource) + | mvs == mv = Just (StoreItem' mv (newDiagsBySource <> dbs)) + update _ = Just (StoreItem' mv newDiagsBySource) -- | Sets the diagnostics for a file and compilation step -- if you want to clear the diagnostics call this with an empty list setStageDiagnostics :: (forall a. String -> String -> a -> a) -> NormalizedUri - -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited + -> Maybe Int32 -- ^ the time that the file these diagnostics originate from was last edited -> T.Text - -> [LSP.Diagnostic] + -> [FileDiagnostic] -> STMDiagnosticStore - -> STM [LSP.Diagnostic] + -> STM [FileDiagnostic] setStageDiagnostics addTag uri ver stage diags ds = updateSTMDiagnostics addTag ds uri ver updatedDiags where !updatedDiags = Map.singleton (Just stage) $! SL.toSortedList diags @@ -1320,22 +1458,41 @@ STMDiagnosticStore -> STM [FileDiagnostic] getAllDiagnostics = - fmap (concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT + fmap (concatMap (\(_,v) -> getDiagnosticsFromStore v)) . ListT.toList . STM.listT -updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> STM () -updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = +updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> STM () +updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = STM.focus (Focus.alter f) uri positionMapping where uri = toNormalizedUri _uri - f = Just . f' . fromMaybe mempty - f' mappingForUri = snd $ - -- Very important to use mapAccum here so that the tails of - -- each mapping can be shared, otherwise quadratic space is - -- used which is evident in long running sessions. - EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc))) - zeroMapping - (EM.insert actual_version (shared_change, zeroMapping) mappingForUri) - shared_change = mkDelta changes - actual_version = case _version of - Nothing -> error "Nothing version from server" -- This is a violation of the spec - Just v -> v + f = Just . updatePositionMappingHelper _version changes . fromMaybe mempty + + +updatePositionMappingHelper :: + Int32 + -> [TextDocumentContentChangeEvent] + -> EnumMap Int32 (PositionDelta, PositionMapping) + -> EnumMap Int32 (PositionDelta, PositionMapping) +updatePositionMappingHelper ver changes mappingForUri = snd $ + -- Very important to use mapAccum here so that the tails of + -- each mapping can be shared, otherwise quadratic space is + -- used which is evident in long running sessions. + EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addOldDelta delta acc in (new, (delta, acc))) + zeroMapping + (EM.insert ver (mkDelta changes, zeroMapping) mappingForUri) + +-- | sends a signal whenever shake session is run/restarted +-- being used in cabal and hlint plugin tests to know when its time +-- to look for file diagnostics +kickSignal :: KnownSymbol s => Bool -> Maybe (LSP.LanguageContextEnv c) -> [NormalizedFilePath] -> Proxy s -> Action () +kickSignal testing lspEnv files msg = when testing $ liftIO $ mRunLspT lspEnv $ + LSP.sendNotification (LSP.SMethod_CustomMethod msg) $ + toJSON $ map fromNormalizedFilePath files + +-- | Add kick start/done signal to rule +runWithSignal :: (KnownSymbol s0, KnownSymbol s1, IdeRule k v) => Proxy s0 -> Proxy s1 -> [NormalizedFilePath] -> k -> Action () +runWithSignal msgStart msgEnd files rule = do + ShakeExtras{ideTesting = Options.IdeTesting testing, lspEnv} <- getShakeExtras + kickSignal testing lspEnv files msgStart + void $ uses rule files + kickSignal testing lspEnv files msgEnd diff --git a/src/Development/IDE/Core/Tracing.hs b/src/Development/IDE/Core/Tracing.hs --- a/src/Development/IDE/Core/Tracing.hs +++ b/src/Development/IDE/Core/Tracing.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE PatternSynonyms #-} -{-# HLINT ignore #-} + module Development.IDE.Core.Tracing ( otTracedHandler , otTracedAction @@ -10,7 +7,7 @@ , otTracedGarbageCollection , withTrace , withEventTrace - , withTelemetryLogger + , withTelemetryRecorder ) where @@ -29,9 +26,9 @@ import Development.IDE.Types.Diagnostics (FileDiagnostic, showDiagnostics) import Development.IDE.Types.Location (Uri (..)) -import Development.IDE.Types.Logger (Logger (Logger)) +import Ide.Logger import Ide.Types (PluginId (..)) -import Language.LSP.Types (NormalizedFilePath, +import Language.LSP.Protocol.Types (NormalizedFilePath, fromNormalizedFilePath) import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent, beginSpan, endSpan, setTag, @@ -54,17 +51,21 @@ | 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 -> +withTelemetryRecorder :: (MonadIO m, MonadMask m) => (Recorder (WithPriority (Doc a)) -> m c) -> m c +withTelemetryRecorder 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) + k $ telemetryLogRecorder sp +-- | Returns a logger that produces telemetry events in a single span. +telemetryLogRecorder :: SpanInFlight -> Recorder (WithPriority (Doc a)) +telemetryLogRecorder sp = Recorder $ \WithPriority {..} -> + liftIO $ addEvent sp (fromString $ show priority) (encodeUtf8 $ trim $ renderStrict $ layoutCompact payload) + 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 @@ -111,7 +112,7 @@ ExitCaseSuccess res -> do setTag sp "result" (pack $ result $ runValue res) setTag sp "changed" $ case res of - RunResult x _ _ -> fromString $ show x + RunResult x _ _ _ -> fromString $ show x endSpan sp) (\sp -> act (liftIO . setTag sp "diagnostics" . encodeUtf8 . showDiagnostics )) | otherwise = act (\_ -> return ()) diff --git a/src/Development/IDE/Core/UseStale.hs b/src/Development/IDE/Core/UseStale.hs --- a/src/Development/IDE/Core/UseStale.hs +++ b/src/Development/IDE/Core/UseStale.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} module Development.IDE.Core.UseStale ( Age(..) diff --git a/src/Development/IDE/Core/WorkerThread.hs b/src/Development/IDE/Core/WorkerThread.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/Core/WorkerThread.hs @@ -0,0 +1,128 @@ +{- +Module : Development.IDE.Core.WorkerThread +Author : @soulomoon +SPDX-License-Identifier: Apache-2.0 + +Description : This module provides an API for managing worker threads in the IDE. +see Note [Serializing runs in separate thread] +-} +module Development.IDE.Core.WorkerThread + ( LogWorkerThread (..), + withWorkerQueue, + awaitRunInThread, + TaskQueue, + isEmptyTaskQueue, + writeTaskQueue, + withWorkerQueueSimple + ) +where + +import Control.Concurrent.Async (withAsync) +import Control.Concurrent.STM +import Control.Concurrent.Strict (newBarrier, signalBarrier, + waitBarrier) +import Control.Exception.Safe (SomeException, finally, throwIO, + try) +import Control.Monad.Cont (ContT (ContT)) +import qualified Data.Text as T +import Ide.Logger + +data LogWorkerThread + = LogThreadEnding !T.Text + | LogThreadEnded !T.Text + | LogSingleWorkStarting !T.Text + | LogSingleWorkEnded !T.Text + deriving (Show) + +instance Pretty LogWorkerThread where + pretty = \case + LogThreadEnding t -> "Worker thread ending:" <+> pretty t + LogThreadEnded t -> "Worker thread ended:" <+> pretty t + LogSingleWorkStarting t -> "Worker starting a unit of work: " <+> pretty t + LogSingleWorkEnded t -> "Worker ended a unit of work: " <+> pretty t + +{- +Note [Serializing runs in separate thread] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We often want to take long-running actions using some resource that cannot be shared. +In this instance it is useful to have a queue of jobs to run using the resource. +Like the db writes, session loading in session loader, shake session restarts. + +Originally we used various ways to implement this, but it was hard to maintain and error prone. +Moreover, we can not stop these threads uniformly when we are shutting down the server. +-} +data TaskQueue a = TaskQueue (TQueue a) + +data ExitOrTask t = Exit | Task t + +newTaskQueueIO :: IO (TaskQueue a) +newTaskQueueIO = TaskQueue <$> newTQueueIO + +-- | 'withWorkerQueueSimple' is a simplified version of 'withWorkerQueue' +-- for the common case where the worker function is just 'id'. +withWorkerQueueSimple :: Recorder (WithPriority LogWorkerThread) -> T.Text -> ContT () IO (TaskQueue (IO ())) +withWorkerQueueSimple recorder title = withWorkerQueue recorder title id + +-- | 'withWorkerQueue' creates a new 'TQueue', and launches a worker +-- thread which polls the queue for requests and runs the given worker +-- function on them. +withWorkerQueue :: Recorder (WithPriority LogWorkerThread) -> T.Text -> (t -> IO ()) -> ContT () IO (TaskQueue t) +withWorkerQueue recorder title workerAction = ContT $ \mainAction -> do + q <- newTaskQueueIO + -- Use a TMVar as a stop flag to coordinate graceful shutdown. + -- The worker thread checks this flag before dequeuing each job; if set, it exits immediately, + -- ensuring that no new work is started after shutdown is requested. + -- This mechanism is necessary because some downstream code may swallow async exceptions, + -- making 'cancel' unreliable for stopping the thread in all cases. + -- If 'cancel' does interrupt the thread (e.g., while blocked in STM or in a cooperative job), + -- the thread exits immediately and never checks the TMVar; in such cases, the stop flag is redundant. + b <- newEmptyTMVarIO + withAsync (writerThread q b) $ \_ -> do + mainAction q + -- if we want to debug the exact location the worker swallows an async exception, we can + -- temporarily comment out the `finally` clause. + `finally` atomically (putTMVar b ()) + logWith recorder Debug (LogThreadEnding title) + logWith recorder Debug (LogThreadEnded title) + where + writerThread q b = + -- See above: check stop flag before dequeuing, exit if set, otherwise run next job. + do + task <- atomically $ do + task <- tryReadTaskQueue q + isEm <- isEmptyTMVar b + case (isEm, task) of + (False, _) -> return Exit -- stop flag set, exit + (_, Just t) -> return $ Task t -- got a task, run it + (_, Nothing) -> retry -- no task, wait + case task of + Exit -> return () + Task t -> do + logWith recorder Debug $ LogSingleWorkStarting title + workerAction t + logWith recorder Debug $ LogSingleWorkEnded title + writerThread q b + + +-- | 'awaitRunInThread' queues up an 'IO' action to be run by a worker thread, +-- and then blocks until the result is computed. If the action throws an +-- non-async exception, it is rethrown in the calling thread. +awaitRunInThread :: TaskQueue (IO ()) -> IO result -> IO result +awaitRunInThread (TaskQueue q) act = do + -- Take an action from TQueue, run it and + -- use barrier to wait for the result + barrier <- newBarrier + atomically $ writeTQueue q (try act >>= signalBarrier barrier) + resultOrException <- waitBarrier barrier + case resultOrException of + Left e -> throwIO (e :: SomeException) + Right r -> return r + +writeTaskQueue :: TaskQueue a -> a -> STM () +writeTaskQueue (TaskQueue q) = writeTQueue q + +isEmptyTaskQueue :: TaskQueue a -> STM Bool +isEmptyTaskQueue (TaskQueue q) = isEmptyTQueue q + +tryReadTaskQueue :: TaskQueue a -> STM (Maybe a) +tryReadTaskQueue (TaskQueue q) = tryReadTQueue q diff --git a/src/Development/IDE/GHC/CPP.hs b/src/Development/IDE/GHC/CPP.hs --- a/src/Development/IDE/GHC/CPP.hs +++ b/src/Development/IDE/GHC/CPP.hs @@ -18,16 +18,18 @@ import Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Compat.Util import GHC - -#if MIN_VERSION_ghc(9,0,0) -import qualified GHC.Driver.Pipeline as Pipeline import GHC.Settings -#elif MIN_VERSION_ghc (8,10,0) -import qualified DriverPipeline as Pipeline -import ToolSettings +import qualified GHC.SysTools.Cpp as Pipeline + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + + +#if MIN_VERSION_ghc(9,10,2) +import qualified GHC.SysTools.Tasks as Pipeline #endif -#if MIN_VERSION_ghc(9,3,0) -import qualified GHC.Driver.Pipeline.Execute as Pipeline + +#if MIN_VERSION_ghc(9,11,0) +import qualified GHC.SysTools.Tasks as Pipeline #endif addOptP :: String -> DynFlags -> DynFlags @@ -37,13 +39,25 @@ } where fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss - alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } + alterToolSettings g dynFlags = dynFlags { toolSettings = g (toolSettings dynFlags) } -doCpp :: HscEnv -> Bool -> FilePath -> FilePath -> IO () -doCpp env raw input_fn output_fn = -#if MIN_VERSION_ghc (9,2,0) - Pipeline.doCpp (hsc_logger env) (hsc_tmpfs env) (hsc_dflags env) (hsc_unit_env env) raw input_fn output_fn +doCpp :: HscEnv -> FilePath -> FilePath -> IO () +doCpp env input_fn output_fn = + -- See GHC commit a2f53ac8d968723417baadfab5be36a020ea6850 + -- this function/Pipeline.doCpp previously had a raw parameter + -- always set to True that corresponded to these settings + let cpp_opts = Pipeline.CppOpts + { cppLinePragmas = True + +#if MIN_VERSION_ghc(9,10,2) + , sourceCodePreprocessor = Pipeline.SCPHsCpp +#elif MIN_VERSION_ghc(9,10,0) + , useHsCpp = True #else - Pipeline.doCpp (hsc_dflags env) raw input_fn output_fn + , cppUseCc = False #endif + + } in + + Pipeline.doCpp (hsc_logger env) (hsc_tmpfs env) (hsc_dflags env) (hsc_unit_env env) cpp_opts input_fn output_fn diff --git a/src/Development/IDE/GHC/Compat.hs b/src/Development/IDE/GHC/Compat.hs --- a/src/Development/IDE/GHC/Compat.hs +++ b/src/Development/IDE/GHC/Compat.hs @@ -1,55 +1,29 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternSynonyms #-} -{-# OPTIONS -Wno-incomplete-uni-patterns -Wno-dodgy-imports #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat( - mkHomeModLocation, hPutStringBuffer, addIncludePathsQuote, getModuleHash, setUpTypedHoles, - NameCacheUpdater(..), -#if MIN_VERSION_ghc(9,3,0) - getMessages, - renderDiagnosticMessageWithHints, - nameEnvElts, -#else - upNameCache, -#endif lookupNameCache, disableWarningsAsErrors, reLoc, reLocA, - getPsMessages, renderMessages, pattern PFailedWithErrorMessages, - isObjectLinkable, - -#if !MIN_VERSION_ghc(9,0,1) - RefMap, -#endif - -#if MIN_VERSION_ghc(9,2,0) -#if !MIN_VERSION_ghc(9,3,0) - extendModSummaryNoDeps, - emsModSummary, -#endif myCoreToStgExpr, -#endif - Usage(..), - FastStringCompat, bytesFS, mkFastStringByteString, nodeInfo', getNodeIds, + getSourceNodeIds, sourceNodeInfo, generatedNodeInfo, simpleNodeInfoCompat, @@ -57,9 +31,6 @@ nodeAnnotations, mkAstNode, combineRealSrcSpans, - - nonDetOccEnvElts, - isQualifiedImport, GhcVersion(..), ghcVersion, @@ -72,11 +43,8 @@ enrichHie, writeHieFile, readHieFile, - supportsHieFiles, setHieDir, dontWriteHieFiles, - module Compat.HieTypes, - module Compat.HieUtils, -- * Compat modules module Development.IDE.GHC.Compat.Core, module Development.IDE.GHC.Compat.Env, @@ -98,17 +66,15 @@ simplifyExpr, tidyExpr, emptyTidyEnv, + tidyOpenType, corePrepExpr, corePrepPgm, lintInteractiveExpr, icInteractiveModule, HomePackageTable, lookupHpt, -#if MIN_VERSION_ghc(9,3,0) - Dependencies(dep_direct_mods), -#else - Dependencies(dep_mods), -#endif + loadModulesHome, + hugElts, bcoFreeNames, ModIfaceAnnotation, pattern Annotation, @@ -123,21 +89,41 @@ emptyInScopeSet, Unfolding(..), noUnfolding, -#if MIN_VERSION_ghc(9,2,0) +#if !MIN_VERSION_ghc(9,13,0) loadExpr, +#endif byteCodeGen, bc_bcos, loadDecls, hscInterp, expectJust, -#else - coreExprToBCOs, - linkExpr, + extract_cons, + recDotDot, + + + Dependencies(dep_direct_mods), + NameCacheUpdater, + + XModulePs(..), + +#if !MIN_VERSION_ghc(9,7,0) + liftZonkM, + nonDetFoldOccEnv, #endif - ) where -import Data.Bifunctor -import Development.IDE.GHC.Compat.Core hiding (moduleUnitId) +#if MIN_VERSION_ghc(9,7,0) + tcInitTidyEnv, +#endif + + ) where +import Control.Applicative ((<|>)) +import qualified Data.ByteString as BS +import Data.Coerce (coerce) +import Data.List (foldl') +import qualified Data.Map as Map +import qualified Data.Set as S +import Data.String (IsString (fromString)) +import Development.IDE.GHC.Compat.Core import Development.IDE.GHC.Compat.Env import Development.IDE.GHC.Compat.Iface import Development.IDE.GHC.Compat.Logger @@ -146,313 +132,202 @@ import Development.IDE.GHC.Compat.Plugins import Development.IDE.GHC.Compat.Units import Development.IDE.GHC.Compat.Util -import GHC hiding (HasSrcSpan, - ModLocation, - RealSrcSpan, exprType, - getLoc, lookupName) - -import Data.Coerce (coerce) -import Data.String (IsString (fromString)) - +import GHC hiding (ModLocation, + RealSrcSpan, exprType, + getLoc, lookupName) +import Prelude hiding (mod) -#if MIN_VERSION_ghc(9,0,0) -import GHC.Core.Lint (lintInteractiveExpr) -import qualified GHC.Core.Opt.Pipeline as GHC -import GHC.Core.Tidy (tidyExpr) -import GHC.CoreToStg.Prep (corePrepPgm) -import qualified GHC.CoreToStg.Prep as GHC -import GHC.Driver.Hooks (hscCompileCoreExprHook) -#if MIN_VERSION_ghc(9,2,0) -import GHC.Linker.Loader (loadExpr) -import GHC.Linker.Types (isObjectLinkable) -import GHC.Runtime.Context (icInteractiveModule) -import GHC.Unit.Home.ModInfo (HomePackageTable, - lookupHpt) -#if MIN_VERSION_ghc(9,3,0) -import GHC.Unit.Module.Deps (Dependencies(dep_direct_mods), Usage(..)) -#else -import GHC.Unit.Module.Deps (Dependencies(dep_mods), Usage(..)) -#endif -#else -import GHC.CoreToByteCode (coreExprToBCOs) -import GHC.Driver.Types (Dependencies (dep_mods), - HomePackageTable, - icInteractiveModule, - lookupHpt) -import GHC.Runtime.Linker (linkExpr) -#endif -import GHC.ByteCode.Asm (bcoFreeNames) -import GHC.Types.Annotations (AnnTarget (ModuleTarget), - Annotation (..), - extendAnnEnvList) -import GHC.Types.Unique.DFM as UniqDFM -import GHC.Types.Unique.DSet as UniqDSet -import GHC.Types.Unique.Set as UniqSet -#else -import Annotations (AnnTarget (ModuleTarget), - Annotation (..), - extendAnnEnvList) -import ByteCodeAsm (bcoFreeNames) -import ByteCodeGen (coreExprToBCOs) -import CoreLint (lintInteractiveExpr) -import CorePrep (corePrepExpr, - corePrepPgm) -import CoreSyn (CoreExpr, - Unfolding (..), - flattenBinds, - noUnfolding) -import CoreTidy (tidyExpr) -import Hooks (hscCompileCoreExprHook) -import Linker (linkExpr) -import qualified SimplCore as GHC -import UniqDFM -import UniqDSet -import UniqSet -import VarEnv (emptyInScopeSet, - emptyTidyEnv, mkRnEnv2) -#endif +import qualified GHC.Core.Opt.Pipeline as GHC +import GHC.Core.Tidy (tidyExpr) +import GHC.Core.TyCo.Tidy (tidyOpenType) +import GHC.CoreToStg.Prep (corePrepPgm) +import qualified GHC.CoreToStg.Prep as GHC +import GHC.Driver.Hooks (hscCompileCoreExprHook) +import GHC.Iface.Ext.Types hiding + (nodeAnnotations) +import qualified GHC.Iface.Ext.Types as GHC (nodeAnnotations) +import GHC.Iface.Ext.Utils -#if MIN_VERSION_ghc(9,0,0) -import GHC.Data.FastString +import GHC.ByteCode.Asm (bcoFreeNames) import GHC.Core +import GHC.Data.FastString import GHC.Data.StringBuffer -import GHC.Driver.Session hiding (ExposePackage) -import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Driver.Session hiding (ExposePackage) +import GHC.Iface.Ext.Ast (enrichHie) +import GHC.Iface.Ext.Binary +import GHC.Iface.Make (mkIfaceExports) +import GHC.SysTools.Tasks (runPp, runUnlit) +import GHC.Types.Annotations (AnnTarget (ModuleTarget), + Annotation (..), + extendAnnEnvList) +import qualified GHC.Types.Avail as Avail +import GHC.Types.Unique.DFM as UniqDFM +import GHC.Types.Unique.DSet as UniqDSet +import GHC.Types.Unique.Set as UniqSet import GHC.Types.Var.Env -import GHC.Utils.Error -#if MIN_VERSION_ghc(9,2,0) -import GHC.Driver.Env as Env -import GHC.Unit.Module.ModIface -import GHC.Unit.Module.ModSummary -#else -import GHC.Driver.Types -#endif -import GHC.Iface.Env -import GHC.Iface.Make (mkIfaceExports) -import qualified GHC.SysTools.Tasks as SysTools -import qualified GHC.Types.Avail as Avail -#else -import FastString -import qualified Avail -import DynFlags hiding (ExposePackage) -import HscTypes -import MkIface hiding (writeIfaceFile) -import StringBuffer (hPutStringBuffer) -import qualified SysTools -#endif - -import Compat.HieAst (enrichHie) -import Compat.HieBin -import Compat.HieTypes hiding (nodeAnnotations) -import qualified Compat.HieTypes as GHC (nodeAnnotations) -import Compat.HieUtils -import qualified Data.ByteString as BS -import Data.IORef - -import Data.List (foldl') -import qualified Data.Map as Map -import qualified Data.Set as S - -#if MIN_VERSION_ghc(9,2,0) import GHC.Builtin.Uniques import GHC.ByteCode.Types +import GHC.Core.Lint.Interactive (interactiveInScope) import GHC.CoreToStg import GHC.Data.Maybe -import GHC.Linker.Loader (loadDecls) -import GHC.Runtime.Interpreter +import GHC.Driver.Config.Core.Lint.Interactive (lintInteractiveExpr) +import GHC.Driver.Config.Core.Opt.Simplify (initSimplifyExprOpts) +import GHC.Driver.Config.CoreToStg (initCoreToStgOpts) +import GHC.Driver.Config.CoreToStg.Prep (initCorePrepConfig) +import GHC.Driver.Config.Stg.Pipeline +import GHC.Driver.Env as Env +import GHC.Iface.Env +import GHC.Linker.Loader (loadDecls +#if !MIN_VERSION_ghc(9,13,0) + , loadExpr +#endif + ) +import GHC.Runtime.Context (icInteractiveModule) import GHC.Stg.Pipeline import GHC.Stg.Syntax import GHC.StgToByteCode import GHC.Types.CostCentre import GHC.Types.IPE +import GHC.Types.SrcLoc (combineRealSrcSpans) +#if MIN_VERSION_ghc(9,13,0) +import GHC.Unit.Home.PackageTable (HomePackageTable, + lookupHpt) +#else +import GHC.Unit.Home.ModInfo (HomePackageTable, + lookupHpt) #endif +import GHC.Unit.Module.Deps (Dependencies (dep_direct_mods), + Usage (..)) +import GHC.Unit.Module.ModIface -#if MIN_VERSION_ghc(9,3,0) -import GHC.Types.Error -import GHC.Driver.Config.Stg.Pipeline -import GHC.Driver.Plugins (PsMessages (..)) +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if MIN_VERSION_ghc(9,13,0) +import GHC.Unit.Home.Graph (addHomeModInfoToHug, unitEnv_assocs) #endif -#if !MIN_VERSION_ghc(9,3,0) -nonDetOccEnvElts :: OccEnv a -> [a] -nonDetOccEnvElts = occEnvElts +#if MIN_VERSION_ghc(9,7,0) +import GHC.Tc.Zonk.TcType (tcInitTidyEnv) #endif -type ModIfaceAnnotation = Annotation +#if !MIN_VERSION_ghc(9,7,0) +liftZonkM :: a -> a +liftZonkM = id -#if MIN_VERSION_ghc(9,3,0) -nameEnvElts :: NameEnv a -> [a] -nameEnvElts = nonDetNameEnvElts +nonDetFoldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b +nonDetFoldOccEnv = foldOccEnv #endif -#if MIN_VERSION_ghc(9,2,0) + +type ModIfaceAnnotation = Annotation + + myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext -#if MIN_VERSION_ghc(9,3,0) -> Bool -#endif -> Module -> ModLocation -> CoreExpr -> IO ( Id -#if MIN_VERSION_ghc(9,3,0) ,[CgStgTopBinding] -- output program -#else - ,[StgTopBinding] -- output program -#endif , InfoTableProvMap , CollectedCCs ) myCoreToStgExpr logger dflags ictxt -#if MIN_VERSION_ghc(9,3,0) for_bytecode -#endif this_mod ml prepd_expr = do {- Create a temporary binding (just because myCoreToStg needs a binding for the stg2stg step) -} let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel") (mkPseudoUniqueE 0) - Many + ManyTy (exprType prepd_expr) (stg_binds, prov_map, collected_ccs) <- myCoreToStg logger dflags ictxt -#if MIN_VERSION_ghc(9,3,0) for_bytecode -#endif this_mod ml [NonRec bco_tmp_id prepd_expr] return (bco_tmp_id, stg_binds, prov_map, collected_ccs) myCoreToStg :: Logger -> DynFlags -> InteractiveContext -#if MIN_VERSION_ghc(9,3,0) -> Bool -#endif -> Module -> ModLocation -> CoreProgram -#if MIN_VERSION_ghc(9,3,0) -> IO ( [CgStgTopBinding] -- output program -#else - -> IO ( [StgTopBinding] -- output program -#endif , InfoTableProvMap , CollectedCCs ) -- CAF cost centre info (declared and used) myCoreToStg logger dflags ictxt -#if MIN_VERSION_ghc(9,3,0) for_bytecode -#endif this_mod ml prepd_binds = do let (stg_binds, denv, cost_centre_info) = {-# SCC "Core2Stg" #-} - coreToStg dflags this_mod ml prepd_binds + coreToStg + (initCoreToStgOpts dflags) + this_mod ml prepd_binds -#if MIN_VERSION_ghc(9,4,2) - (stg_binds2,_) +#if MIN_VERSION_ghc(9,8,0) + (unzip -> (stg_binds2,_),_) #else - stg_binds2 + (stg_binds2,_) #endif <- {-# SCC "Stg2Stg" #-} -#if MIN_VERSION_ghc(9,3,0) - stg2stg logger ictxt (initStgPipelineOpts dflags for_bytecode) this_mod stg_binds -#else - stg2stg logger dflags ictxt this_mod stg_binds -#endif + stg2stg logger + (interactiveInScope ictxt) + (initStgPipelineOpts dflags for_bytecode) this_mod stg_binds return (stg_binds2, denv, cost_centre_info) -#endif - -#if !MIN_VERSION_ghc(9,2,0) -reLoc :: Located a -> Located a -reLoc = id - -reLocA :: Located a -> Located a -reLocA = id +#if MIN_VERSION_ghc(9,9,0) +reLocA :: (HasLoc (GenLocated a e), HasAnnotation b) + => GenLocated a e -> GenLocated b e +reLocA = reLoc #endif getDependentMods :: ModIface -> [ModuleName] -#if MIN_VERSION_ghc(9,3,0) -getDependentMods = map (gwib_mod . snd) . S.toList . dep_direct_mods . mi_deps -#elif MIN_VERSION_ghc(9,0,0) -getDependentMods = map gwib_mod . dep_mods . mi_deps +#if MIN_VERSION_ghc(9,13,0) +getDependentMods = map (gwib_mod . (\(_,_,x) -> x)) . S.toList . dep_direct_mods . mi_deps #else -getDependentMods = map fst . dep_mods . mi_deps +getDependentMods = map (gwib_mod . snd) . S.toList . dep_direct_mods . mi_deps #endif simplifyExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr -#if MIN_VERSION_ghc(9,0,0) -simplifyExpr _ = GHC.simplifyExpr +simplifyExpr _ env = GHC.simplifyExpr (Development.IDE.GHC.Compat.Env.hsc_logger env) (ue_eps (Development.IDE.GHC.Compat.Env.hsc_unit_env env)) (initSimplifyExprOpts (hsc_dflags env) (hsc_IC env)) corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr -corePrepExpr _ = GHC.corePrepExpr -#else -simplifyExpr df _ = GHC.simplifyExpr df -#endif +corePrepExpr _ env expr = do + cfg <- initCorePrepConfig env + GHC.corePrepExpr (Development.IDE.GHC.Compat.Env.hsc_logger env) cfg expr renderMessages :: PsMessages -> (Bag WarnMsg, Bag ErrMsg) renderMessages msgs = -#if MIN_VERSION_ghc(9,3,0) - let renderMsgs extractor = (fmap . fmap) renderDiagnosticMessageWithHints . getMessages $ extractor msgs + let renderMsgs extractor = (fmap . fmap) GhcPsMessage . getMessages $ extractor msgs in (renderMsgs psWarnings, renderMsgs psErrors) -#else - msgs -#endif -#if MIN_VERSION_ghc(9,2,0) -pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope DecoratedSDoc)) -> ParseResult a -pattern PFailedWithErrorMessages msgs -#if MIN_VERSION_ghc(9,3,0) - <- PFailed (const . fmap (fmap renderDiagnosticMessageWithHints) . getMessages . getPsErrorMessages -> msgs) -#else - <- PFailed (const . fmap pprError . getErrorMessages -> msgs) -#endif -#else -pattern PFailedWithErrorMessages :: (DynFlags -> ErrorMessages) -> ParseResult a +pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope GhcMessage)) -> ParseResult a pattern PFailedWithErrorMessages msgs - <- PFailed (getErrorMessages -> msgs) -#endif + <- PFailed (const . fmap (fmap GhcPsMessage) . getMessages . getPsErrorMessages -> msgs) {-# COMPLETE POk, PFailedWithErrorMessages #-} -supportsHieFiles :: Bool -supportsHieFiles = True - hieExportNames :: HieFile -> [(SrcSpan, Name)] hieExportNames = nameListFromAvails . hie_exports -#if MIN_VERSION_ghc(9,3,0) type NameCacheUpdater = NameCache -#else -lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name) --- Lookup up the (Module,OccName) in the NameCache --- If you find it, return it; if not, allocate a fresh original name and extend --- the NameCache. --- Reason: this may the first occurrence of (say) Foo.bar we have encountered. --- If we need to explore its value we will load Foo.hi; but meanwhile all we --- need is a Name for it. -lookupNameCache mod occ name_cache = - case lookupOrigNameCache (nsNames name_cache) mod occ of { - Just name -> (name_cache, name); - Nothing -> - case takeUniqFromSupply (nsUniqs name_cache) of { - (uniq, us) -> - let - name = mkExternalName uniq mod occ noSrcSpan - new_cache = extendNameCache (nsNames name_cache) mod occ name - in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }} - -upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c -upNameCache = updNameCache -#endif - -#if !MIN_VERSION_ghc(9,0,1) -type RefMap a = Map.Map Identifier [(Span, IdentifierDetails a)] -#endif - mkHieFile' :: ModSummary -> [Avail.AvailInfo] +#if MIN_VERSION_ghc(9,11,0) + -> (HieASTs Type, NameEntityInfo) +#else -> HieASTs Type +#endif -> BS.ByteString -> Hsc HieFile -mkHieFile' ms exports asts src = do +mkHieFile' ms exports +#if MIN_VERSION_ghc(9,11,0) + (asts, entityInfo) +#else + asts +#endif + src = do let Just src_file = ml_hs_file $ ms_location ms (asts',arr) = compressTypes asts return $ HieFile @@ -460,6 +335,9 @@ , hie_module = ms_mod ms , hie_types = arr , hie_asts = asts' +#if MIN_VERSION_ghc(9,11,0) + , hie_entity_infos = entityInfo +#endif -- mkIfaceExports sorts the AvailInfos for stability , hie_exports = mkIfaceExports exports , hie_hs_src = src @@ -475,7 +353,7 @@ dontWriteHieFiles :: DynFlags -> DynFlags dontWriteHieFiles d = gopt_unset d Opt_WriteHie -setUpTypedHoles ::DynFlags -> DynFlags +setUpTypedHoles :: DynFlags -> DynFlags setUpTypedHoles df = flip gopt_unset Opt_AbstractRefHoleFits -- too spammy $ flip gopt_unset Opt_ShowDocsOfHoleFits -- not used @@ -488,9 +366,13 @@ $ flip gopt_unset Opt_SortValidHoleFits $ flip gopt_unset Opt_UnclutterValidHoleFits $ df - { refLevelHoleFits = Just 1 -- becomes slow at higher levels - , maxRefHoleFits = Just 10 -- quantity does not impact speed - , maxValidHoleFits = Nothing -- quantity does not impact speed + { refLevelHoleFits = refLevelHoleFits df <|> Just 1 -- becomes slow at higher levels + + -- Sometimes GHC can emit a lot of hole fits, this causes editors to be slow + -- or just crash, we limit the hole fits to 10. The number was chosen + -- arbirtarily by the author. + , maxRefHoleFits = maxRefHoleFits df <|> Just 10 + , maxValidHoleFits = maxValidHoleFits df <|> Just 10 } @@ -500,7 +382,11 @@ getModuleHash :: ModIface -> Fingerprint +#if MIN_VERSION_ghc(9,13,0) +getModuleHash = mi_mod_hash +#else getModuleHash = mi_mod_hash . mi_final_exts +#endif disableWarningsAsErrors :: DynFlags -> DynFlags @@ -512,9 +398,10 @@ isQualifiedImport ImportDecl{} = True isQualifiedImport _ = False - +-- | Like getNodeIds but with generated node removed +getSourceNodeIds :: HieAST a -> Map.Map Identifier (IdentifierDetails a) +getSourceNodeIds = Map.foldl' combineNodeIds Map.empty . Map.filterWithKey (\k _ -> k == SourceInfo) . getSourcedNodeInfo . sourcedNodeInfo -#if MIN_VERSION_ghc(9,0,0) getNodeIds :: HieAST a -> Map.Map Identifier (IdentifierDetails a) getNodeIds = Map.foldl' combineNodeIds Map.empty . getSourcedNodeInfo . sourcedNodeInfo @@ -532,78 +419,41 @@ NodeInfo (S.union as bs) (mergeSorted ai bi) (Map.unionWith (<>) ad bd) where mergeSorted :: Ord a => [a] -> [a] -> [a] - mergeSorted la@(a:as) lb@(b:bs) = case compare a b of - LT -> a : mergeSorted as lb - EQ -> a : mergeSorted as bs - GT -> b : mergeSorted la bs - mergeSorted as [] = as - mergeSorted [] bs = bs - -#else - -getNodeIds :: HieAST a -> NodeIdentifiers a -getNodeIds = nodeIdentifiers . nodeInfo --- import qualified FastString as FS - --- nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex -nodeInfo' :: Ord a => HieAST a -> NodeInfo a -nodeInfo' = nodeInfo --- type Unit = UnitId --- moduleUnit :: Module -> Unit --- moduleUnit = moduleUnitId --- unhelpfulSpanFS :: FS.FastString -> FS.FastString --- unhelpfulSpanFS = id -#endif + mergeSorted la@(a:axs) lb@(b:bxs) = case compare a b of + LT -> a : mergeSorted axs lb + EQ -> a : mergeSorted axs bxs + GT -> b : mergeSorted la bxs + mergeSorted axs [] = axs + mergeSorted [] bxs = bxs sourceNodeInfo :: HieAST a -> Maybe (NodeInfo a) -#if MIN_VERSION_ghc(9,0,0) sourceNodeInfo = Map.lookup SourceInfo . getSourcedNodeInfo . sourcedNodeInfo -#else -sourceNodeInfo = Just . nodeInfo -#endif generatedNodeInfo :: HieAST a -> Maybe (NodeInfo a) -#if MIN_VERSION_ghc(9,0,0) generatedNodeInfo = Map.lookup GeneratedInfo . getSourcedNodeInfo . sourcedNodeInfo -#else -generatedNodeInfo = sourceNodeInfo -- before ghc 9.0, we don't distinguish the source -#endif data GhcVersion - = GHC810 - | GHC90 - | GHC92 - | GHC94 - deriving (Eq, Ord, Show) + = GHC96 + | GHC98 + | GHC910 + | GHC912 + | GHC914 + deriving (Eq, Ord, Show, Enum) ghcVersionStr :: String ghcVersionStr = VERSION_ghc ghcVersion :: GhcVersion -#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) -ghcVersion = GHC94 -#elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) -ghcVersion = GHC92 -#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) -ghcVersion = GHC90 -#elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) -ghcVersion = GHC810 -#endif - -runUnlit :: Logger -> DynFlags -> [Option] -> IO () -runUnlit = -#if MIN_VERSION_ghc(9,2,0) - SysTools.runUnlit -#else - const SysTools.runUnlit -#endif - -runPp :: Logger -> DynFlags -> [Option] -> IO () -runPp = -#if MIN_VERSION_ghc(9,2,0) - SysTools.runPp +#if MIN_VERSION_GLASGOW_HASKELL(9,14,0,0) +ghcVersion = GHC914 +#elif MIN_VERSION_GLASGOW_HASKELL(9,12,0,0) +ghcVersion = GHC912 +#elif MIN_VERSION_GLASGOW_HASKELL(9,10,0,0) +ghcVersion = GHC910 +#elif MIN_VERSION_GLASGOW_HASKELL(9,8,0,0) +ghcVersion = GHC98 #else - const SysTools.runPp +ghcVersion = GHC96 #endif simpleNodeInfoCompat :: FastStringCompat -> FastStringCompat -> NodeInfo a @@ -613,43 +463,49 @@ isAnnotationInNodeInfo p = S.member p . nodeAnnotations nodeAnnotations :: NodeInfo a -> S.Set (FastStringCompat, FastStringCompat) -#if MIN_VERSION_ghc(9,2,0) nodeAnnotations = S.map (\(NodeAnnotation ctor typ) -> (coerce ctor, coerce typ)) . GHC.nodeAnnotations -#else -nodeAnnotations = S.map (bimap coerce coerce) . GHC.nodeAnnotations -#endif -#if MIN_VERSION_ghc(9,2,0) newtype FastStringCompat = FastStringCompat LexicalFastString -#else -newtype FastStringCompat = FastStringCompat FastString -#endif deriving (Show, Eq, Ord) instance IsString FastStringCompat where -#if MIN_VERSION_ghc(9,2,0) fromString = FastStringCompat . LexicalFastString . fromString -#else - fromString = FastStringCompat . fromString -#endif mkAstNode :: NodeInfo a -> Span -> [HieAST a] -> HieAST a -#if MIN_VERSION_ghc(9,0,0) mkAstNode n = Node (SourcedNodeInfo $ Map.singleton GeneratedInfo n) + +-- | Load modules, quickly. Input doesn't need to be desugared. +-- A module must be loaded before dependent modules can be typechecked. +-- This variant of loadModuleHome will *never* cause recompilation, it just +-- modifies the session. +-- The order modules are loaded is important when there are hs-boot files. +-- In particular you should make sure to load the .hs version of a file after the +-- .hs-boot version. +loadModulesHome + :: [HomeModInfo] + -> HscEnv +#if MIN_VERSION_ghc(9,13,0) + -> IO HscEnv +loadModulesHome mod_infos e = do + let hug = hsc_HUG (e { hsc_type_env_vars = emptyKnotVars }) + mapM_ (`addHomeModInfoToHug` hug) mod_infos + pure (e { hsc_type_env_vars = emptyKnotVars }) #else -mkAstNode = Node + -> HscEnv +loadModulesHome mod_infos e = + hscUpdateHUG (\hug -> foldl' (flip addHomeModInfoToHug) hug mod_infos) (e { hsc_type_env_vars = emptyKnotVars }) #endif -combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan -#if MIN_VERSION_ghc(9,2,0) -combineRealSrcSpans = SrcLoc.combineRealSrcSpans -#else -combineRealSrcSpans span1 span2 - = mkRealSrcSpan (mkRealSrcLoc file line_start col_start) (mkRealSrcLoc file line_end col_end) - where - (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) - (srcSpanStartLine span2, srcSpanStartCol span2) - (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) - (srcSpanEndLine span2, srcSpanEndCol span2) - file = srcSpanFile span1 +#if MIN_VERSION_ghc(9,13,0) +hugElts :: HomeUnitGraph -> [(UnitId, HomeUnitEnv)] +hugElts = unitEnv_assocs #endif + +recDotDot :: HsRecFields (GhcPass p) arg -> Maybe Int +recDotDot x = + unRecFieldsDotDot <$> + unLoc <$> rec_dotdot x + +extract_cons :: DataDefnCons a -> [a] +extract_cons (NewTypeCon x) = [x] +extract_cons (DataTypeCons _ xs) = xs diff --git a/src/Development/IDE/GHC/Compat/CmdLine.hs b/src/Development/IDE/GHC/Compat/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/CmdLine.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE CPP #-} + +-- | Compat module Interface file relevant code. +module Development.IDE.GHC.Compat.CmdLine ( + processCmdLineP + , CmdLineP (..) + , getCmdLineState + , putCmdLineState + , Flag(..) + , OptKind(..) + , EwM + , defFlag + , liftEwM + ) where + +import GHC.Driver.CmdLine +import GHC.Driver.Session (CmdLineP (..), getCmdLineState, + processCmdLineP, putCmdLineState) + diff --git a/src/Development/IDE/GHC/Compat/Core.hs b/src/Development/IDE/GHC/Compat/Core.hs --- a/src/Development/IDE/GHC/Compat/Core.hs +++ b/src/Development/IDE/GHC/Compat/Core.hs @@ -1,12 +1,7 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} --- TODO: remove -{-# OPTIONS -Wno-dodgy-imports -Wno-unused-imports #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} --- | Compat Core module that handles the GHC module hierarchy re-organisation +-- | Compat Core module that handles the GHC module hierarchy re-organization -- by re-exporting everything we care about. -- -- This module provides no other compat mechanisms, except for simple @@ -39,14 +34,10 @@ lookupType, needWiredInHomeIface, loadWiredInHomeIface, + readIface, loadSysInterface, importDecl, -#if MIN_VERSION_ghc(8,8,0) CommandLineOption, -#endif -#if !MIN_VERSION_ghc(9,2,0) - staticPlugins, -#endif sPgm_F, settings, gopt, @@ -67,41 +58,32 @@ pattern ExposePackage, parseDynamicFlagsCmdLine, parseDynamicFilePragma, -#if !MIN_VERSION_ghc(9,3,0) - WarnReason(..), -#endif wWarningFlags, updOptLevel, -- slightly unsafe setUnsafeGlobalDynFlags, -- * Linear Haskell -#if !MIN_VERSION_ghc(9,0,0) - Scaled, - unrestricted, -#endif scaledThing, -- * Interface Files IfaceExport, IfaceTyCon(..), ModIface, ModIface_(..), +#if MIN_VERSION_ghc(9,11,0) + pattern ModIface, + set_mi_top_env, +#if !MIN_VERSION_ghc(9,13,0) + set_mi_usages, +#endif +#endif HscSource(..), WhereFrom(..), loadInterface, -#if !MIN_VERSION_ghc(9,3,0) - SourceModified(..), -#endif loadModuleInterface, RecompileRequired(..), mkPartialIface, mkFullIface, - checkOldIface, -#if MIN_VERSION_ghc(9,0,0) IsBootInterface(..), -#else - pattern IsBoot, - pattern NotBoot, -#endif -- * Fixity LexicalFixity(..), Fixity (..), @@ -118,10 +100,6 @@ -- * ModDetails ModDetails(..), -- * HsExpr, -#if !MIN_VERSION_ghc(9,2,0) - pattern HsLet, - pattern LetStmt, -#endif -- * Var Type ( TyCoRep.TyVarTy, @@ -139,21 +117,11 @@ pattern ConPatIn, conPatDetails, mapConPatDetail, -#if !MIN_VERSION_ghc(9,2,0) - Development.IDE.GHC.Compat.Core.splitForAllTyCoVars, -#endif - mkVisFunTys, - Development.IDE.GHC.Compat.Core.mkInfForAllTys, -- * Specs ImpDeclSpec(..), ImportSpec(..), -- * SourceText SourceText(..), -#if !MIN_VERSION_ghc(9,2,0) - rationalFromFractionalLit, -#endif - -- * Name - tyThingParent_maybe, -- * Ways Way, wayGeneralFlags, @@ -165,7 +133,9 @@ pattern AvailTC, Avail.availName, Avail.availNames, +#if !MIN_VERSION_ghc(9,7,0) Avail.availNamesWithSelectors, +#endif Avail.availsToNameSet, -- * TcGblEnv TcGblEnv(..), @@ -192,15 +162,15 @@ hscInteractive, hscSimplify, hscTypecheckRename, + hscUpdateHPT, Development.IDE.GHC.Compat.Core.makeSimpleDetails, -- * Typecheck utils - Development.IDE.GHC.Compat.Core.tcSplitForAllTyVars, - Development.IDE.GHC.Compat.Core.tcSplitForAllTyVarBinder_maybe, + tcSplitForAllTyVars, + tcSplitForAllTyVarBinder_maybe, typecheckIface, Development.IDE.GHC.Compat.Core.mkIfaceTc, Development.IDE.GHC.Compat.Core.mkBootModDetailsTc, Development.IDE.GHC.Compat.Core.initTidyOpts, - hscUpdateHPT, driverNoStop, tidyProgram, ImportedModsVal(..), @@ -211,19 +181,14 @@ SrcLoc.Located, SrcLoc.unLoc, getLoc, - getLocA, - locA, - noLocA, + GHC.getLocA, + GHC.locA, + GHC.noLocA, unLocA, LocatedAn, - LocatedA, -#if MIN_VERSION_ghc(9,2,0) + GHC.LocatedA, GHC.AnnListItem(..), GHC.NameAnn(..), -#else - AnnListItem, - NameAnn, -#endif SrcLoc.RealLocated, SrcLoc.GenLocated(..), SrcLoc.SrcSpan(SrcLoc.UnhelpfulSpan), @@ -233,8 +198,7 @@ pattern RealSrcLoc, SrcLoc.SrcLoc(SrcLoc.UnhelpfulLoc), BufSpan, -#if MIN_VERSION_ghc(9,2,0) - SrcSpanAnn', +#if !MIN_VERSION_ghc(9,9,0) GHC.SrcAnn, #endif SrcLoc.leftmost_smallest, @@ -263,21 +227,24 @@ SrcLoc.noSrcSpan, SrcLoc.noSrcLoc, SrcLoc.noLoc, - SrcLoc.mapLoc, + SrcLoc.srcSpanToRealSrcSpan, + mapLoc, -- * Finder FindResult(..), mkHomeModLocation, - addBootSuffixLocnOut, findObjectLinkableMaybe, InstalledFindResult(..), -- * Module and Package ModuleOrigin(..), PackageName(..), -- * Linker +#if MIN_VERSION_ghc(9,11,0) + LinkablePart(..), +#else Unlinked(..), +#endif Linkable(..), unload, - initDynLinker, -- * Hooks Hooks, runMetaHook, @@ -294,7 +261,7 @@ -- * Driver-Make Target(..), TargetId(..), - mkModuleGraph, + mkSimpleTarget, -- * GHCi initObjLinker, loadDLL, @@ -316,8 +283,6 @@ Role(..), -- * Panic Plain.PlainGhcException, - panic, - panicDoc, -- * Other GHC.CoreModule(..), GHC.SafeHaskellMode(..), @@ -326,11 +291,8 @@ gre_imp, gre_lcl, gre_par, -#if MIN_VERSION_ghc(9,2,0) collectHsBindsBinders, -#endif -- * Util Module re-exports -#if MIN_VERSION_ghc(9,0,0) module GHC.Builtin.Names, module GHC.Builtin.Types, module GHC.Builtin.Types.Prim, @@ -342,9 +304,6 @@ module GHC.Core.FamInstEnv, module GHC.Core.InstEnv, module GHC.Types.Unique.FM, -#if !MIN_VERSION_ghc(9,2,0) - module GHC.Core.Ppr.TyThing, -#endif module GHC.Core.PatSyn, module GHC.Core.Predicate, module GHC.Core.TyCon, @@ -358,8 +317,8 @@ module GHC.HsToCore.Monad, module GHC.Iface.Syntax, + module GHC.Iface.Recomp, -#if MIN_VERSION_ghc(9,2,0) module GHC.Hs.Decls, module GHC.Hs.Expr, module GHC.Hs.Doc, @@ -369,7 +328,6 @@ module GHC.Hs.Type, module GHC.Hs.Utils, module Language.Haskell.Syntax, -#endif module GHC.Rename.Names, module GHC.Rename.Splice, @@ -383,477 +341,282 @@ module GHC.Types.Basic, module GHC.Types.Id, - module GHC.Types.Name , + module GHC.Types.Name, module GHC.Types.Name.Set, - module GHC.Types.Name.Cache, module GHC.Types.Name.Env, module GHC.Types.Name.Reader, module GHC.Utils.Error, -#if MIN_VERSION_ghc(9,2,0) +#if !MIN_VERSION_ghc(9,7,0) module GHC.Types.Avail, +#endif module GHC.Types.SourceFile, module GHC.Types.SourceText, module GHC.Types.TyThing, module GHC.Types.TyThing.Ppr, -#endif module GHC.Types.Unique.Supply, module GHC.Types.Var, module GHC.Unit.Module, -#else - module BasicTypes, - module Class, - module Coercion, - module Predicate, - module ConLike, - module CoreUtils, - module DataCon, - module DsExpr, - module DsMonad, - module ErrUtils, - module FamInst, - module FamInstEnv, - module HeaderInfo, - module Id, - module InstEnv, - module IfaceSyn, - module Module, - module Name, - module NameCache, - module NameEnv, - module NameSet, - module PatSyn, - module PprTyThing, - module PrelInfo, - module PrelNames, - module RdrName, - module RnSplice, - module RnNames, - module TcEnv, - module TcEvidence, - module TcType, - module TcRnTypes, - module TcRnDriver, - module TcRnMonad, - module TyCon, - module TysPrim, - module TysWiredIn, - module Type, - module Unify, - module UniqFM, - module UniqSupply, - module Var, -#endif + module GHC.Unit.Module.Graph, -- * Syntax re-exports -#if MIN_VERSION_ghc(9,0,0) module GHC.Hs, + module GHC.Hs.Binds, module GHC.Parser, module GHC.Parser.Header, module GHC.Parser.Lexer, -#else - module GHC.Hs, - module ExtractDocs, - module Parser, - module Lexer, -#endif -#if MIN_VERSION_ghc(9,3,0) + module GHC.Utils.Panic, CompileReason(..), hsc_type_env_vars, - hscUpdateHUG, hscUpdateHPT, hsc_HUG, + hscUpdateHUG, hsc_HUG, GhcMessage(..), getKey, module GHC.Driver.Env.KnotVars, - module GHC.Iface.Recomp, module GHC.Linker.Types, - module GHC.Unit.Module.Graph, module GHC.Types.Unique.Map, module GHC.Utils.TmpFs, - module GHC.Utils.Panic, module GHC.Unit.Finder.Types, module GHC.Unit.Env, module GHC.Driver.Phases, -#endif -# if !MIN_VERSION_ghc(9,4,0) - pattern HsFieldBind, - hfbAnn, - hfbLHS, - hfbRHS, - hfbPun, -#endif -#if !MIN_VERSION_ghc_boot_th(9,4,1) - Extension(.., NamedFieldPuns), -#else Extension(..), + mkCgInteractiveGuts, + justBytecode, + justObjects, + emptyHomeModInfoLinkable, + homeModInfoByteCode, + homeModInfoObject, + groupOrigin, + isVisibleFunArg, +#if MIN_VERSION_ghc(9,8,0) + lookupGlobalRdrEnv #endif - UniqFM, ) where import qualified GHC -#if MIN_VERSION_ghc(9,3,0) -import GHC.Iface.Recomp (CompileReason(..)) -import GHC.Driver.Env.Types (hsc_type_env_vars) -import GHC.Driver.Env (hscUpdateHUG, hscUpdateHPT, hsc_HUG) -import GHC.Driver.Env.KnotVars -import GHC.Iface.Recomp -import GHC.Linker.Types -import GHC.Unit.Module.Graph -import GHC.Driver.Errors.Types -import GHC.Types.Unique.Map -import GHC.Types.Unique -import GHC.Utils.TmpFs -import GHC.Utils.Panic -import GHC.Unit.Finder.Types -import GHC.Unit.Env -import GHC.Driver.Phases -#endif +-- NOTE(ozkutuk): Cpp clashes Phase.Cpp, so we hide it. +-- Not the greatest solution, but gets the job done +-- (until the CPP extension is actually needed). +import GHC.LanguageExtensions.Type hiding (Cpp) -#if MIN_VERSION_ghc(9,0,0) -import GHC.Builtin.Names hiding (Unique, printName) +import GHC.Builtin.Names hiding (Unique, printName) import GHC.Builtin.Types import GHC.Builtin.Types.Prim import GHC.Builtin.Utils +import GHC.Core (CoreProgram) import GHC.Core.Class import GHC.Core.Coercion import GHC.Core.ConLike -import GHC.Core.DataCon hiding (dataConExTyCoVars) -import qualified GHC.Core.DataCon as DataCon -import GHC.Core.FamInstEnv hiding (pprFamInst) +import GHC.Core.DataCon hiding (dataConExTyCoVars) +import qualified GHC.Core.DataCon as DataCon +import GHC.Core.FamInstEnv hiding (pprFamInst) import GHC.Core.InstEnv -import GHC.Types.Unique.FM hiding (UniqFM) -import qualified GHC.Types.Unique.FM as UniqFM -#if MIN_VERSION_ghc(9,3,0) -import qualified GHC.Driver.Config.Tidy as GHC -import qualified GHC.Data.Strict as Strict -#endif -#if MIN_VERSION_ghc(9,2,0) -import GHC.Data.Bag -import GHC.Core.Multiplicity (scaledThing) -#else -import GHC.Core.Ppr.TyThing hiding (pprFamInst) -import GHC.Core.TyCo.Rep (scaledThing) -#endif import GHC.Core.PatSyn import GHC.Core.Predicate import GHC.Core.TyCo.Ppr -import qualified GHC.Core.TyCo.Rep as TyCoRep +import qualified GHC.Core.TyCo.Rep as TyCoRep import GHC.Core.TyCon -import GHC.Core.Type hiding (mkInfForAllTys) +import GHC.Core.Type import GHC.Core.Unify import GHC.Core.Utils - - -#if MIN_VERSION_ghc(9,2,0) -import GHC.Driver.Env -#else -import GHC.Driver.Finder hiding (mkHomeModLocation) -import GHC.Driver.Types -import GHC.Driver.Ways -#endif -import GHC.Driver.CmdLine (Warn (..)) +import GHC.Driver.CmdLine (Warn (..)) import GHC.Driver.Hooks -import GHC.Driver.Main as GHC +import GHC.Driver.Main as GHC import GHC.Driver.Monad import GHC.Driver.Phases import GHC.Driver.Pipeline import GHC.Driver.Plugins -import GHC.Driver.Session hiding (ExposePackage) -import qualified GHC.Driver.Session as DynFlags -#if MIN_VERSION_ghc(9,2,0) -import GHC.Hs (HsModule (..), SrcSpanAnn') -import GHC.Hs.Decls hiding (FunDep) -import GHC.Hs.Doc -import GHC.Hs.Expr -import GHC.Hs.Extension -import GHC.Hs.ImpExp -import GHC.Hs.Pat -import GHC.Hs.Type -import GHC.Hs.Utils hiding (collectHsBindsBinders) -import qualified GHC.Hs.Utils as GHC -#endif -#if !MIN_VERSION_ghc(9,2,0) -import GHC.Hs hiding (HsLet, LetStmt) -#endif +import GHC.Driver.Session hiding (ExposePackage) +import qualified GHC.Driver.Session as DynFlags +import GHC.Hs.Binds import GHC.HsToCore.Docs import GHC.HsToCore.Expr import GHC.HsToCore.Monad import GHC.Iface.Load -import GHC.Iface.Make (mkFullIface, mkPartialIface) -import GHC.Iface.Make as GHC +import GHC.Iface.Make as GHC import GHC.Iface.Recomp import GHC.Iface.Syntax -import GHC.Iface.Tidy as GHC +import GHC.Iface.Tidy as GHC import GHC.IfaceToCore import GHC.Parser -import GHC.Parser.Header hiding (getImports) -#if MIN_VERSION_ghc(9,2,0) -import qualified GHC.Linker.Loader as Linker -import GHC.Linker.Types -import GHC.Parser.Lexer hiding (initParserState, getPsMessages) -import GHC.Parser.Annotation (EpAnn (..)) -import GHC.Platform.Ways -import GHC.Runtime.Context (InteractiveImport (..)) -#else -import GHC.Parser.Lexer -import qualified GHC.Runtime.Linker as Linker -#endif -import GHC.Rename.Fixity (lookupFixityRn) +import GHC.Parser.Header hiding (getImports) +import GHC.Rename.Fixity (lookupFixityRn) import GHC.Rename.Names import GHC.Rename.Splice -import qualified GHC.Runtime.Interpreter as GHCi +import qualified GHC.Runtime.Interpreter as GHCi import GHC.Tc.Instance.Family import GHC.Tc.Module import GHC.Tc.Types -import GHC.Tc.Types.Evidence hiding ((<.>)) +import GHC.Tc.Types.Evidence hiding ((<.>)) import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Monad hiding (Applicative (..), IORef, - MonadFix (..), MonadIO (..), - allM, anyM, concatMapM, - mapMaybeM, (<$>)) -import GHC.Tc.Utils.TcType as TcType -import qualified GHC.Types.Avail as Avail -#if MIN_VERSION_ghc(9,2,0) -import GHC.Types.Avail (greNamePrintableName) -import GHC.Types.Fixity (LexicalFixity (..), Fixity (..), defaultFixity) -#endif -#if MIN_VERSION_ghc(9,2,0) -import GHC.Types.Meta -#endif +import GHC.Tc.Utils.Monad hiding (Applicative (..), IORef, + MonadFix (..), MonadIO (..), allM, + anyM, concatMapM, mapMaybeM, foldMapM, + (<$>)) +import GHC.Tc.Utils.TcType as TcType +import qualified GHC.Types.Avail as Avail import GHC.Types.Basic import GHC.Types.Id -import GHC.Types.Name hiding (varName) +import GHC.Types.Name hiding (varName) import GHC.Types.Name.Cache import GHC.Types.Name.Env -import GHC.Types.Name.Reader hiding (GRE, gre_name, gre_imp, gre_lcl, gre_par) -import qualified GHC.Types.Name.Reader as RdrName -#if MIN_VERSION_ghc(9,2,0) +import GHC.Types.Name.Reader hiding (GRE, gre_imp, gre_lcl, + gre_name, gre_par) +import qualified GHC.Types.Name.Reader as RdrName +import GHC.Types.SrcLoc (BufPos, BufSpan, + SrcLoc (UnhelpfulLoc), + SrcSpan (UnhelpfulSpan)) +import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Unique.FM +import GHC.Types.Unique.Supply +import GHC.Types.Var (Var (varName), setTyVarUnique, + setVarUnique) + +import qualified GHC.Types.Var as TypesVar +import GHC.Unit.Info (PackageName (..)) +import GHC.Unit.Module hiding (ModLocation (..), UnitId, + moduleUnit, toUnitId) +import qualified GHC.Unit.Module as Module +import GHC.Unit.State (ModuleOrigin (..)) +import GHC.Utils.Error (Severity (..), emptyMessages) +import GHC.Utils.Panic hiding (try) +import qualified GHC.Utils.Panic.Plain as Plain + + +import Data.Foldable (toList) +import GHC.Core.Multiplicity (scaledThing) +import qualified GHC.Data.Strict as Strict +import qualified GHC.Driver.Config.Finder as GHC +import qualified GHC.Driver.Config.Tidy as GHC +import GHC.Driver.Env +import GHC.Driver.Env as GHCi +import GHC.Driver.Env.KnotVars +import GHC.Driver.Errors.Types +import GHC.Hs (HsModule (..)) +import GHC.Hs.Decls hiding (FunDep) +import GHC.Hs.Doc +import GHC.Hs.Expr +import GHC.Hs.Extension +import GHC.Hs.ImpExp +import GHC.Hs.Pat +import GHC.Hs.Type +import GHC.Hs.Utils hiding (collectHsBindsBinders) +import qualified GHC.Linker.Loader as Linker +import GHC.Linker.Types +import GHC.Parser.Annotation (EpAnn (..)) +import GHC.Parser.Lexer hiding (getPsMessages, + initParserState) +import GHC.Platform.Ways +import GHC.Runtime.Context (InteractiveImport (..)) +import GHC.Types.Fixity (Fixity (..), LexicalFixity (..), + defaultFixity) +import GHC.Types.Meta import GHC.Types.Name.Set -import GHC.Types.SourceFile (HscSource (..), -#if !MIN_VERSION_ghc(9,3,0) - SourceModified(..) -#endif - ) +import GHC.Types.SourceFile (HscSource (..)) import GHC.Types.SourceText -import GHC.Types.Target (Target (..), TargetId (..)) +import GHC.Types.Target (Target (..), TargetId (..)) import GHC.Types.TyThing import GHC.Types.TyThing.Ppr -#else -import GHC.Types.Name.Set -#endif -import GHC.Types.SrcLoc (BufPos, BufSpan, - SrcLoc (UnhelpfulLoc), - SrcSpan (UnhelpfulSpan)) -import qualified GHC.Types.SrcLoc as SrcLoc -import GHC.Types.Unique.Supply -import GHC.Types.Var (Var (varName), setTyVarUnique, - setVarUnique) -#if MIN_VERSION_ghc(9,2,0) -import GHC.Unit.Finder hiding (mkHomeModLocation) +import GHC.Types.Unique +import GHC.Types.Unique.Map +import GHC.Unit.Env +import GHC.Unit.Finder hiding (mkHomeModLocation) +import qualified GHC.Unit.Finder as GHC +import GHC.Unit.Finder.Types import GHC.Unit.Home.ModInfo +#if MIN_VERSION_ghc(9,13,0) +import GHC.Unit.Home.PackageTable (addToHpt, addListToHpt) #endif -import GHC.Unit.Info (PackageName (..)) -import GHC.Unit.Module hiding (ModLocation (..), UnitId, - addBootSuffixLocnOut, moduleUnit, - toUnitId) -import qualified GHC.Unit.Module as Module -#if MIN_VERSION_ghc(9,2,0) -import GHC.Unit.Module.Graph (mkModuleGraph) +import GHC.Unit.Module.Graph import GHC.Unit.Module.Imported import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModGuts -import GHC.Unit.Module.ModIface (IfaceExport, ModIface (..), - ModIface_ (..), mi_fix) -import GHC.Unit.Module.ModSummary (ModSummary (..)) +import GHC.Unit.Module.ModIface (IfaceExport, ModIface, + ModIface_ (..), mi_fix +#if MIN_VERSION_ghc(9,11,0) + , pattern ModIface + , set_mi_top_env +#if !MIN_VERSION_ghc(9,13,0) + , set_mi_usages #endif -import GHC.Unit.State (ModuleOrigin (..)) -import GHC.Utils.Error (Severity (..), emptyMessages) -import GHC.Utils.Panic hiding (try) -import qualified GHC.Utils.Panic.Plain as Plain -#else -import qualified Avail -import BasicTypes hiding (Version) -import Class -import CmdLineParser (Warn (..)) -import ConLike -import CoreUtils -import DataCon hiding (dataConExTyCoVars) -import qualified DataCon -import DriverPhases -import DriverPipeline -import DsExpr -import DsMonad hiding (foldrM) -import DynFlags hiding (ExposePackage) -import qualified DynFlags -import ErrUtils hiding (logInfo, mkWarnMsg) -import ExtractDocs -import FamInst -import FamInstEnv -import Finder hiding (mkHomeModLocation) -import GHC.Hs hiding (HsLet, LetStmt) -import qualified GHCi -import GhcMonad -import HeaderInfo hiding (getImports) -import Hooks -import HscMain as GHC -import HscTypes -import Id -import IfaceSyn -import InstEnv -import Lexer hiding (getSrcLoc) -import qualified Linker -import LoadIface -import MkIface as GHC -import Module hiding (ModLocation (..), UnitId, - addBootSuffixLocnOut, - moduleUnitId) -import qualified Module -import Name hiding (varName) -import NameCache -import NameEnv -import NameSet -import Packages -import Panic hiding (try) -import qualified PlainPanic as Plain -import Parser -import PatSyn -import RnFixity -import Plugins -import PprTyThing hiding (pprFamInst) -import PrelInfo -import PrelNames hiding (Unique, printName) -import RdrName hiding (GRE, gre_name, gre_imp, gre_lcl, gre_par) -import qualified RdrName -import RnNames -import RnSplice -import qualified SrcLoc -import TcEnv -import TcEvidence hiding ((<.>)) -import TcIface -import TcRnDriver -import TcRnMonad hiding (Applicative (..), IORef, - MonadFix (..), MonadIO (..), - allM, anyM, concatMapM, foldrM, - mapMaybeM, (<$>)) -import TcRnTypes -import TcType -import qualified TcType -import TidyPgm as GHC -import qualified TyCoRep -import TyCon -import Type -import TysPrim -import TysWiredIn -import Unify -import UniqFM hiding (UniqFM) -import qualified UniqFM -import UniqSupply -import Var (Var (varName), setTyVarUnique, - setVarUnique, varType) - -import Coercion (coercionKind) -import Predicate -import SrcLoc (Located, SrcLoc (UnhelpfulLoc), - SrcSpan (UnhelpfulSpan)) #endif + ) +import GHC.Unit.Module.ModSummary (ModSummary (..)) +import GHC.Utils.Error (mkPlainErrorMsgEnvelope) +import GHC.Utils.Panic +import GHC.Utils.TmpFs +import Language.Haskell.Syntax hiding (FunDep) -import Data.List (isSuffixOf) -import System.FilePath - +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] -#if MIN_VERSION_ghc(9,2,0) -import Language.Haskell.Syntax hiding (FunDep) -#endif -#if MIN_VERSION_ghc(9,3,0) -import GHC.Driver.Env as GHCi +#if MIN_VERSION_ghc(9,11,0) +import System.OsPath #endif -import Data.Foldable (toList) - -#if MIN_VERSION_ghc(9,3,0) -import qualified GHC.Unit.Finder as GHC -import qualified GHC.Driver.Config.Finder as GHC -#elif MIN_VERSION_ghc(9,2,0) -import qualified GHC.Unit.Finder as GHC -#elif MIN_VERSION_ghc(9,0,0) -import qualified GHC.Driver.Finder as GHC -#else -import qualified Finder as GHC +#if MIN_VERSION_ghc(9,13,0) +import qualified System.FilePath as FP #endif --- NOTE(ozkutuk): Cpp clashes Phase.Cpp, so we hide it. --- Not the greatest solution, but gets the job done --- (until the CPP extension is actually needed). -import GHC.LanguageExtensions.Type hiding (Cpp) +#if !MIN_VERSION_ghc(9,7,0) +import GHC.Types.Avail (greNamePrintableName) +#endif +#if !MIN_VERSION_ghc(9,9,0) +import GHC.Hs (SrcSpanAnn') +#endif mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation -#if MIN_VERSION_ghc(9,3,0) -mkHomeModLocation df mn f = pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn f +#if MIN_VERSION_ghc(9,13,0) +mkHomeModLocation df mn f = + let (basename, ext) = FP.splitExtension f + osBasename = unsafeEncodeUtf basename + osExt = unsafeEncodeUtf ext + hscSrc = case ext of + ".hs-boot" -> HsBootFile + ".hsig" -> HsigFile + _ -> HsSrcFile + in pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn osBasename osExt hscSrc +#elif MIN_VERSION_ghc(9,11,0) +mkHomeModLocation df mn f = + let osf = unsafeEncodeUtf f + in pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn osf #else -mkHomeModLocation = GHC.mkHomeModLocation -#endif - - -#if !MIN_VERSION_ghc(9,0,0) -type BufSpan = () -type BufPos = () +mkHomeModLocation df mn f = pure $ GHC.mkHomeModLocation (GHC.initFinderOpts df) mn f #endif -#if MIN_VERSION_ghc(9,3,0) pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan -#else -pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan -#endif -#if MIN_VERSION_ghc(9,3,0) pattern RealSrcSpan x y <- SrcLoc.RealSrcSpan x ((\case Strict.Nothing -> Nothing; Strict.Just a -> Just a) -> y) where RealSrcSpan x y = SrcLoc.RealSrcSpan x (case y of Nothing -> Strict.Nothing; Just a -> Strict.Just a) -#elif MIN_VERSION_ghc(9,0,0) -pattern RealSrcSpan x y = SrcLoc.RealSrcSpan x y -#else -pattern RealSrcSpan x y <- ((,Nothing) -> (SrcLoc.RealSrcSpan x, y)) where - RealSrcSpan x _ = SrcLoc.RealSrcSpan x -#endif {-# COMPLETE RealSrcSpan, UnhelpfulSpan #-} -#if MIN_VERSION_ghc(9,3,0) pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Strict.Maybe BufPos-> SrcLoc.SrcLoc -#else -pattern RealSrcLoc :: SrcLoc.RealSrcLoc -> Maybe BufPos-> SrcLoc.SrcLoc -#endif -#if MIN_VERSION_ghc(9,0,0) pattern RealSrcLoc x y = SrcLoc.RealSrcLoc x y -#else -pattern RealSrcLoc x y <- ((,Nothing) -> (SrcLoc.RealSrcLoc x, y)) where - RealSrcLoc x _ = SrcLoc.RealSrcLoc x -#endif {-# COMPLETE RealSrcLoc, UnhelpfulLoc #-} pattern AvailTC :: Name -> [Name] -> [FieldLabel] -> Avail.AvailInfo -#if __GLASGOW_HASKELL__ >= 902 +#if __GLASGOW_HASKELL__ >= 907 +pattern AvailTC n names pieces <- Avail.AvailTC n ((,[]) -> (names,pieces)) +#else pattern AvailTC n names pieces <- Avail.AvailTC n ((\gres -> foldr (\gre (names, pieces) -> case gre of Avail.NormalGreName name -> (name: names, pieces) Avail.FieldGreName label -> (names, label:pieces)) ([], []) gres) -> (names, pieces)) -#else -pattern AvailTC n names pieces <- Avail.AvailTC n names pieces #endif pattern AvailName :: Name -> Avail.AvailInfo -#if __GLASGOW_HASKELL__ >= 902 -pattern AvailName n <- Avail.Avail (Avail.NormalGreName n) -#else +#if __GLASGOW_HASKELL__ >= 907 pattern AvailName n <- Avail.Avail n +#else +pattern AvailName n <- Avail.Avail (Avail.NormalGreName n) #endif pattern AvailFL :: FieldLabel -> Avail.AvailInfo -#if __GLASGOW_HASKELL__ >= 902 -pattern AvailFL fl <- Avail.Avail (Avail.FieldGreName fl) +#if __GLASGOW_HASKELL__ >= 907 +pattern AvailFL fl <- (const Nothing -> Just fl) -- this pattern always fails as this field was removed in 9.7 #else --- pattern synonym that is never populated -pattern AvailFL x <- Avail.Avail (const (True, undefined) -> (False, x)) +pattern AvailFL fl <- Avail.Avail (Avail.FieldGreName fl) #endif {-# COMPLETE AvailTC, AvailName, AvailFL #-} @@ -869,12 +632,11 @@ pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr #endif -pattern FunTy :: Type -> Type -> Type -pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} - -#if MIN_VERSION_ghc(9,0,0) --- type HasSrcSpan x a = (GenLocated SrcSpan a ~ x) --- type HasSrcSpan x = () :: Constraint +isVisibleFunArg :: Development.IDE.GHC.Compat.Core.FunTyFlag -> Bool +isVisibleFunArg = TypesVar.isVisibleFunArg +type FunTyFlag = TypesVar.FunTyFlag +pattern FunTy :: Development.IDE.GHC.Compat.Core.FunTyFlag -> Type -> Type -> Type +pattern FunTy af arg res <- TyCoRep.FunTy {ft_af = af, ft_arg = arg, ft_res = res} class HasSrcSpan a where getLoc :: a -> SrcSpan @@ -885,299 +647,124 @@ instance HasSrcSpan (SrcLoc.GenLocated SrcSpan a) where getLoc = GHC.getLoc -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,9,0) +instance HasSrcSpan (EpAnn a) where + getLoc = GHC.getHasLoc +#endif + +#if MIN_VERSION_ghc(9,9,0) +instance HasSrcSpan (SrcLoc.GenLocated (EpAnn ann) a) where + getLoc (L l _) = getLoc l +instance HasSrcSpan (SrcLoc.GenLocated (GHC.EpaLocation) a) where + getLoc = GHC.getHasLoc +#else instance HasSrcSpan (SrcSpanAnn' ann) where - getLoc = locA + getLoc = GHC.locA instance HasSrcSpan (SrcLoc.GenLocated (SrcSpanAnn' ann) a) where getLoc (L l _) = l +#endif pattern L :: HasSrcSpan a => SrcSpan -> e -> SrcLoc.GenLocated a e pattern L l a <- GHC.L (getLoc -> l) a {-# COMPLETE L #-} -#endif -#else -type HasSrcSpan = SrcLoc.HasSrcSpan -getLoc :: SrcLoc.HasSrcSpan a => a -> SrcLoc.SrcSpan -getLoc = SrcLoc.getLoc -#endif - --- | Add the @-boot@ suffix to all output file paths associated with the --- module, not including the input file itself -addBootSuffixLocnOut :: GHC.ModLocation -> GHC.ModLocation -addBootSuffixLocnOut = Module.addBootSuffixLocnOut - -#if !MIN_VERSION_ghc(9,0,0) --- Linear Haskell -type Scaled a = a -scaledThing :: Scaled a -> a -scaledThing = id - -unrestricted :: a -> Scaled a -unrestricted = id -#endif - -mkInfForAllTys :: [TyVar] -> Type -> Type -mkInfForAllTys = -#if MIN_VERSION_ghc(9,0,0) - TcType.mkInfForAllTys -#else - mkInvForAllTys -#endif - -#if !MIN_VERSION_ghc(9,2,0) -splitForAllTyCoVars :: Type -> ([TyCoVar], Type) -splitForAllTyCoVars = - splitForAllTys -#endif - -tcSplitForAllTyVars :: Type -> ([TyVar], Type) -tcSplitForAllTyVars = -#if MIN_VERSION_ghc(9,2,0) - TcType.tcSplitForAllTyVars -#else - tcSplitForAllTys -#endif - - -tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (TyVarBinder, Type) -tcSplitForAllTyVarBinder_maybe = -#if MIN_VERSION_ghc(9,2,0) - TcType.tcSplitForAllTyVarBinder_maybe -#else - tcSplitForAllTy_maybe -#endif - - -#if !MIN_VERSION_ghc(9,0,0) -pattern NotBoot, IsBoot :: IsBootInterface -pattern NotBoot = False -pattern IsBoot = True -#endif - -#if MIN_VERSION_ghc(9,0,0) -- This is from the old api, but it still simplifies pattern ConPatIn :: SrcLoc.Located (ConLikeP GhcPs) -> HsConPatDetails GhcPs -> Pat GhcPs -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,9,0) +pattern ConPatIn con args <- ConPat _ (L _ (SrcLoc.noLoc -> con)) args + where + ConPatIn con args = ConPat GHC.noAnn (GHC.noLocA $ SrcLoc.unLoc con) args +#else pattern ConPatIn con args <- ConPat EpAnnNotUsed (L _ (SrcLoc.noLoc -> con)) args where ConPatIn con args = ConPat EpAnnNotUsed (GHC.noLocA $ SrcLoc.unLoc con) args -#else -pattern ConPatIn con args = ConPat NoExtField con args #endif -#endif conPatDetails :: Pat p -> Maybe (HsConPatDetails p) -#if MIN_VERSION_ghc(9,0,0) conPatDetails (ConPat _ _ args) = Just args conPatDetails _ = Nothing -#else -conPatDetails (ConPatIn _ args) = Just args -conPatDetails _ = Nothing -#endif mapConPatDetail :: (HsConPatDetails p -> Maybe (HsConPatDetails p)) -> Pat p -> Maybe (Pat p) -#if MIN_VERSION_ghc(9,0,0) mapConPatDetail f pat@(ConPat _ _ args) = (\args' -> pat { pat_args = args'}) <$> f args mapConPatDetail _ _ = Nothing -#else -mapConPatDetail f (ConPatIn ss args) = ConPatIn ss <$> f args -mapConPatDetail _ _ = Nothing -#endif -initDynLinker, initObjLinker :: HscEnv -> IO () -initDynLinker = -#if !MIN_VERSION_ghc(9,0,0) - Linker.initDynLinker -#else - -- It errors out in GHC 9.0 and doesn't exist in 9.2 - const $ return () -#endif - +initObjLinker :: HscEnv -> IO () initObjLinker env = -#if !MIN_VERSION_ghc(9,2,0) - GHCi.initObjLinker env -#else GHCi.initObjLinker (GHCi.hscInterp env) -#endif loadDLL :: HscEnv -> String -> IO (Maybe String) -loadDLL env = -#if !MIN_VERSION_ghc(9,2,0) - GHCi.loadDLL env +loadDLL env str = do + res <- GHCi.loadDLL (GHCi.hscInterp env) str +#if MIN_VERSION_ghc(9,11,0) || (MIN_VERSION_ghc(9, 8, 3) && !MIN_VERSION_ghc(9, 9, 0)) || (MIN_VERSION_ghc(9, 10, 2) && !MIN_VERSION_ghc(9, 11, 0)) + pure $ + case res of + Left err_msg -> Just err_msg + Right _ -> Nothing #else - GHCi.loadDLL (GHCi.hscInterp env) + pure res #endif unload :: HscEnv -> [Linkable] -> IO () unload hsc_env linkables = Linker.unload -#if MIN_VERSION_ghc(9,2,0) (GHCi.hscInterp hsc_env) -#endif hsc_env linkables -#if !MIN_VERSION_ghc(9,3,0) -setOutputFile :: FilePath -> DynFlags -> DynFlags -setOutputFile f d = d { -#if MIN_VERSION_ghc(9,2,0) - outputFile_ = Just f -#else - outputFile = Just f -#endif - } -#endif isSubspanOfA :: LocatedAn la a -> LocatedAn lb b -> Bool -#if MIN_VERSION_ghc(9,2,0) isSubspanOfA a b = SrcLoc.isSubspanOf (GHC.getLocA a) (GHC.getLocA b) -#else -isSubspanOfA a b = SrcLoc.isSubspanOf (GHC.getLoc a) (GHC.getLoc b) -#endif -#if MIN_VERSION_ghc(9,2,0) type LocatedAn a = GHC.LocatedAn a -#else -type LocatedAn a = GHC.Located -#endif -#if MIN_VERSION_ghc(9,2,0) -type LocatedA = GHC.LocatedA -#else -type LocatedA = GHC.Located -#endif - -#if MIN_VERSION_ghc(9,2,0) -locA :: SrcSpanAnn' a -> SrcSpan -locA = GHC.locA -#else -locA = id -#endif - -#if MIN_VERSION_ghc(9,2,0) unLocA :: forall pass a. XRec (GhcPass pass) a -> a unLocA = unXRec @(GhcPass pass) -#else -unLocA = id -#endif -#if MIN_VERSION_ghc(9,2,0) -getLocA :: SrcLoc.GenLocated (SrcSpanAnn' a) e -> SrcSpan -getLocA = GHC.getLocA -#else --- getLocA :: HasSrcSpan a => a -> SrcSpan -getLocA x = GHC.getLoc x -#endif -noLocA :: a -> LocatedAn an a -#if MIN_VERSION_ghc(9,2,0) -noLocA = GHC.noLocA -#else -noLocA = GHC.noLoc -#endif - -#if !MIN_VERSION_ghc(9,2,0) -type AnnListItem = SrcLoc.SrcSpan -#endif - -#if !MIN_VERSION_ghc(9,2,0) -type NameAnn = SrcLoc.SrcSpan -#endif - pattern GRE :: Name -> Parent -> Bool -> [ImportSpec] -> RdrName.GlobalRdrElt {-# COMPLETE GRE #-} -#if MIN_VERSION_ghc(9,2,0) pattern GRE{gre_name, gre_par, gre_lcl, gre_imp} <- RdrName.GRE - {gre_name = (greNamePrintableName -> gre_name) - ,gre_par, gre_lcl, gre_imp = (toList -> gre_imp)} +#if MIN_VERSION_ghc(9,7,0) + {gre_name = gre_name #else -pattern GRE{gre_name, gre_par, gre_lcl, gre_imp} = RdrName.GRE{..} + {gre_name = (greNamePrintableName -> gre_name) #endif + ,gre_par, gre_lcl, gre_imp = (toList -> gre_imp)} -#if MIN_VERSION_ghc(9,2,0) -collectHsBindsBinders :: CollectPass p => Bag (XRec p (HsBindLR p idR)) -> [IdP p] +collectHsBindsBinders :: CollectPass p => LHsBindsLR p idR -> [IdP p] collectHsBindsBinders x = GHC.collectHsBindsBinders CollNoDictBinders x -#endif -#if !MIN_VERSION_ghc(9,2,0) -pattern HsLet xlet localBinds expr <- GHC.HsLet xlet (SrcLoc.unLoc -> localBinds) expr -pattern LetStmt xlet localBinds <- GHC.LetStmt xlet (SrcLoc.unLoc -> localBinds) -#endif -#if !MIN_VERSION_ghc(9,2,0) -rationalFromFractionalLit :: FractionalLit -> Rational -rationalFromFractionalLit = fl_value -#endif makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails makeSimpleDetails hsc_env = GHC.makeSimpleDetails -#if MIN_VERSION_ghc(9,3,0) (hsc_logger hsc_env) -#else - hsc_env -#endif -mkIfaceTc hsc_env sf details ms tcGblEnv = - GHC.mkIfaceTc hsc_env sf details -#if MIN_VERSION_ghc(9,3,0) - ms -#endif - tcGblEnv +mkIfaceTc :: HscEnv -> GHC.SafeHaskellMode -> ModDetails -> ModSummary -> Maybe CoreProgram -> TcGblEnv -> IO ModIface +mkIfaceTc hscEnv shm md _ms _mcp = + GHC.mkIfaceTc hscEnv shm md _ms _mcp -- mcp::Maybe CoreProgram is only used in GHC >= 9.6 mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails mkBootModDetailsTc session = GHC.mkBootModDetailsTc -#if MIN_VERSION_ghc(9,3,0) (hsc_logger session) -#else - session -#endif -#if !MIN_VERSION_ghc(9,3,0) -type TidyOpts = HscEnv -#endif initTidyOpts :: HscEnv -> IO TidyOpts initTidyOpts = -#if MIN_VERSION_ghc(9,3,0) GHC.initTidyOpts -#else - pure -#endif -driverNoStop = -#if MIN_VERSION_ghc(9,3,0) - NoStop -#else - StopLn -#endif - -#if !MIN_VERSION_ghc(9,3,0) -hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv -hscUpdateHPT k session = session { hsc_HPT = k (hsc_HPT session) } -#endif - -#if !MIN_VERSION_ghc(9,2,0) -match :: HsRecField' id arg -> ((), id, arg, Bool) -match (HsRecField lhs rhs pun) = ((), SrcLoc.unLoc lhs, rhs, pun) +driverNoStop :: StopPhase +driverNoStop = NoStop -pattern HsFieldBind :: () -> id -> arg -> Bool -> HsRecField' id arg -pattern HsFieldBind {hfbAnn, hfbLHS, hfbRHS, hfbPun} <- (match -> (hfbAnn, hfbLHS, hfbRHS, hfbPun)) where - HsFieldBind _ lhs rhs pun = HsRecField (SrcLoc.noLoc lhs) rhs pun -#elif !MIN_VERSION_ghc(9,4,0) -pattern HsFieldBind :: XHsRecField id -> id -> arg -> Bool -> HsRecField' id arg -pattern HsFieldBind {hfbAnn, hfbLHS, hfbRHS, hfbPun} <- HsRecField hfbAnn (SrcLoc.unLoc -> hfbLHS) hfbRHS hfbPun where - HsFieldBind ann lhs rhs pun = HsRecField ann (SrcLoc.noLoc lhs) rhs pun -#endif +groupOrigin :: MatchGroup GhcRn body -> Origin +mapLoc :: (a -> b) -> SrcLoc.GenLocated l a -> SrcLoc.GenLocated l b +mapLoc = fmap +groupOrigin = mg_ext -#if !MIN_VERSION_ghc_boot_th(9,4,1) -pattern NamedFieldPuns :: Extension -pattern NamedFieldPuns = RecordPuns -#endif +mkSimpleTarget :: DynFlags -> FilePath -> Target +mkSimpleTarget df fp = Target (TargetFile fp Nothing) True (homeUnitId_ df) Nothing -#if MIN_VERSION_ghc(9,0,0) -type UniqFM = UniqFM.UniqFM -#else -type UniqFM k = UniqFM.UniqFM +#if MIN_VERSION_ghc(9,7,0) +lookupGlobalRdrEnv gre_env occ = lookupGRE gre_env (LookupOccName occ AllRelevantGREs) #endif diff --git a/src/Development/IDE/GHC/Compat/Driver.hs b/src/Development/IDE/GHC/Compat/Driver.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Driver.hs @@ -0,0 +1,142 @@ +-- ============================================================================ +-- DO NOT EDIT +-- This module copies parts of the driver code in GHC.Driver.Main to provide +-- `hscTypecheckRenameWithDiagnostics`. +-- Issue to add this function: https://gitlab.haskell.org/ghc/ghc/-/issues/24996 +-- MR to add this function: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12891 +-- ============================================================================ + +{-# LANGUAGE CPP #-} + +module Development.IDE.GHC.Compat.Driver + ( hscTypecheckRenameWithDiagnostics + ) where + +#if MIN_VERSION_ghc(9,11,0) + +import GHC.Driver.Main (hscTypecheckRenameWithDiagnostics) + +#else + +import Control.Monad +import GHC.Core +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Driver.Env +import GHC.Driver.Errors.Types +import GHC.Driver.Main +import GHC.Driver.Session +import GHC.Hs +import GHC.Hs.Dump +import GHC.Iface.Ext.Ast (mkHieFile) +import GHC.Iface.Ext.Binary (hie_file_result, readHieFile, + writeHieFile) +import GHC.Iface.Ext.Debug (diffFile, validateScopes) +import GHC.Iface.Ext.Types (getAsts, hie_asts, hie_module) +import GHC.Tc.Module +import GHC.Tc.Utils.Monad +import GHC.Types.SourceFile +import GHC.Types.SrcLoc +import GHC.Unit +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModSummary +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Panic.Plain + +hscTypecheckRenameWithDiagnostics :: HscEnv -> ModSummary -> HsParsedModule + -> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage) +hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module = + runHsc' hsc_env $ hsc_typecheck True mod_summary (Just rdr_module) + +-- ============================================================================ +-- DO NOT EDIT - Refer to top of file +-- ============================================================================ +hsc_typecheck :: Bool -- ^ Keep renamed source? + -> ModSummary -> Maybe HsParsedModule + -> Hsc (TcGblEnv, RenamedStuff) +hsc_typecheck keep_rn mod_summary mb_rdr_module = do + hsc_env <- getHscEnv + let hsc_src = ms_hsc_src mod_summary + dflags = hsc_dflags hsc_env + home_unit = hsc_home_unit hsc_env + outer_mod = ms_mod mod_summary + mod_name = moduleName outer_mod + outer_mod' = mkHomeModule home_unit mod_name + inner_mod = homeModuleNameInstantiation home_unit mod_name + src_filename = ms_hspp_file mod_summary + real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 + keep_rn' = gopt Opt_WriteHie dflags || keep_rn + massert (isHomeModule home_unit outer_mod) + tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod) + then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc + else + do hpm <- case mb_rdr_module of + Just hpm -> return hpm + Nothing -> hscParse' mod_summary + tc_result0 <- tcRnModule' mod_summary keep_rn' hpm + if hsc_src == HsigFile + then + do (iface, _) <- liftIO $ hscSimpleIface hsc_env Nothing tc_result0 mod_summary + ioMsgMaybe $ hoistTcRnMessage $ + tcRnMergeSignatures hsc_env hpm tc_result0 iface + else return tc_result0 + rn_info <- extract_renamed_stuff mod_summary tc_result + return (tc_result, rn_info) + +-- ============================================================================ +-- DO NOT EDIT - Refer to top of file +-- ============================================================================ +extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff +extract_renamed_stuff mod_summary tc_result = do + let rn_info = getRenamedStuff tc_result + + dflags <- getDynFlags + logger <- getLogger + liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer" + FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info) + + -- Create HIE files + when (gopt Opt_WriteHie dflags) $ do + -- I assume this fromJust is safe because `-fwrite-hie-file` + -- enables the option which keeps the renamed source. + hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info) + let out_file = ml_hie_file $ ms_location mod_summary + liftIO $ writeHieFile out_file hieFile + liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) + + -- Validate HIE files + when (gopt Opt_ValidateHie dflags) $ do + hs_env <- Hsc $ \e w -> return (e, w) + liftIO $ do + -- Validate Scopes + case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of + [] -> putMsg logger $ text "Got valid scopes" + xs -> do + putMsg logger $ text "Got invalid scopes" + mapM_ (putMsg logger) xs + -- Roundtrip testing + file' <- readHieFile (hsc_NC hs_env) out_file + case diffFile hieFile (hie_file_result file') of + [] -> + putMsg logger $ text "Got no roundtrip errors" + xs -> do + putMsg logger $ text "Got roundtrip errors" + let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug) + mapM_ (putMsg logger') xs + return rn_info + +-- ============================================================================ +-- DO NOT EDIT - Refer to top of file +-- ============================================================================ +hscSimpleIface :: HscEnv + -> Maybe CoreProgram + -> TcGblEnv + -> ModSummary + -> IO (ModIface, ModDetails) +hscSimpleIface hsc_env mb_core_program tc_result summary + = runHsc hsc_env $ hscSimpleIface' mb_core_program tc_result summary + +#endif diff --git a/src/Development/IDE/GHC/Compat/Env.hs b/src/Development/IDE/GHC/Compat/Env.hs --- a/src/Development/IDE/GHC/Compat/Env.hs +++ b/src/Development/IDE/GHC/Compat/Env.hs @@ -3,43 +3,40 @@ -- | Compat module for the main Driver types, such as 'HscEnv', -- 'UnitEnv' and some DynFlags compat functions. module Development.IDE.GHC.Compat.Env ( - Env.HscEnv(hsc_FC, hsc_NC, hsc_IC, hsc_mod_graph -#if MIN_VERSION_ghc(9,3,0) + Env.HscEnv(hsc_FC, hsc_NC, hsc_IC , hsc_type_env_vars -#else - , hsc_type_env_var -#endif ), + Env.hsc_mod_graph, Env.hsc_HPT, InteractiveContext(..), setInteractivePrintName, setInteractiveDynFlags, Env.hsc_dflags, hsc_EPS, - hsc_logger, - hsc_tmpfs, - hsc_unit_env, - hsc_hooks, + Env.hsc_logger, + Env.hsc_tmpfs, + Env.hsc_unit_env, + Env.hsc_hooks, hscSetHooks, TmpFs, -- * HomeUnit hscHomeUnit, HomeUnit, setHomeUnitId_, - Development.IDE.GHC.Compat.Env.mkHomeModule, + Home.mkHomeModule, -- * Provide backwards Compatible -- types and helper functions. - Logger(..), + Logger, UnitEnv, hscSetUnitEnv, hscSetFlags, initTempFs, -- * Home Unit - Development.IDE.GHC.Compat.Env.homeUnitId_, + Session.homeUnitId_, -- * DynFlags Helper setBytecodeLinkerOptions, setInterpreterLinkerOptions, - Development.IDE.GHC.Compat.Env.safeImportsOn, + Session.safeImportsOn, -- * Ways Ways, Way, @@ -50,202 +47,73 @@ -- * Backend, backwards compatible Backend, setBackend, + ghciBackend, Development.IDE.GHC.Compat.Env.platformDefaultBackend, + workingDirectory, + setWorkingDirectory, + hscSetActiveUnitId, + reexportedModules, ) where -import GHC (setInteractiveDynFlags) +import GHC (setInteractiveDynFlags) -#if MIN_VERSION_ghc(9,0,0) -#if MIN_VERSION_ghc(9,2,0) -import GHC.Driver.Backend as Backend -#if MIN_VERSION_ghc(9,3,0) -import GHC.Driver.Env (HscEnv) -#else -import GHC.Driver.Env (HscEnv, hsc_EPS) -#endif -import qualified GHC.Driver.Env as Env -import qualified GHC.Driver.Session as Session -import GHC.Platform.Ways hiding (hostFullWays) -import qualified GHC.Platform.Ways as Ways +import GHC.Driver.Backend as Backend +import GHC.Driver.Env (HscEnv, hscSetActiveUnitId) +import qualified GHC.Driver.Env as Env +import GHC.Driver.Hooks (Hooks) +import GHC.Driver.Session +import qualified GHC.Driver.Session as Session +import GHC.Platform.Ways import GHC.Runtime.Context -import GHC.Unit.Env (UnitEnv) -import GHC.Unit.Home as Home +import GHC.Unit.Env (UnitEnv) +import GHC.Unit.Home as Home +import GHC.Unit.Types (UnitId) import GHC.Utils.Logger import GHC.Utils.TmpFs -#else -import qualified GHC.Driver.Session as DynFlags -import GHC.Driver.Types (HscEnv, InteractiveContext (..), hsc_EPS, - setInteractivePrintName) -import qualified GHC.Driver.Types as Env -import GHC.Driver.Ways hiding (hostFullWays) -import qualified GHC.Driver.Ways as Ways -#endif -import GHC.Driver.Hooks (Hooks) -import GHC.Driver.Session hiding (mkHomeModule) -import GHC.Unit.Module.Name -import GHC.Unit.Types (Module, Unit, UnitId, mkModule) -#else -import DynFlags -import Hooks -import HscTypes as Env -import Module -#endif -#if MIN_VERSION_ghc(9,0,0) -#if !MIN_VERSION_ghc(9,2,0) -import qualified Data.Set as Set -#endif -#endif -#if !MIN_VERSION_ghc(9,2,0) -import Data.IORef -#endif -#if MIN_VERSION_ghc(9,3,0) hsc_EPS :: HscEnv -> UnitEnv -hsc_EPS = hsc_unit_env -#endif +hsc_EPS = Env.hsc_unit_env -#if !MIN_VERSION_ghc(9,2,0) -type UnitEnv = () -newtype Logger = Logger { log_action :: LogAction } -type TmpFs = () -#endif +setWorkingDirectory :: FilePath -> DynFlags -> DynFlags +setWorkingDirectory p d = d { workingDirectory = Just p } setHomeUnitId_ :: UnitId -> DynFlags -> DynFlags -#if MIN_VERSION_ghc(9,2,0) setHomeUnitId_ uid df = df { Session.homeUnitId_ = uid } -#elif MIN_VERSION_ghc(9,0,0) -setHomeUnitId_ uid df = df { homeUnitId = uid } -#else -setHomeUnitId_ uid df = df { thisInstalledUnitId = toInstalledUnitId uid } -#endif hscSetFlags :: DynFlags -> HscEnv -> HscEnv hscSetFlags df env = env { Env.hsc_dflags = df } initTempFs :: HscEnv -> IO HscEnv initTempFs env = do -#if MIN_VERSION_ghc(9,2,0) tmpFs <- initTmpFs pure env { Env.hsc_tmpfs = tmpFs } -#else - filesToClean <- newIORef emptyFilesToClean - dirsToClean <- newIORef mempty - let dflags = (Env.hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True} - pure $ hscSetFlags dflags env -#endif hscSetUnitEnv :: UnitEnv -> HscEnv -> HscEnv -#if MIN_VERSION_ghc(9,2,0) hscSetUnitEnv ue env = env { Env.hsc_unit_env = ue } -#else -hscSetUnitEnv _ env = env -#endif -hsc_unit_env :: HscEnv -> UnitEnv -hsc_unit_env = -#if MIN_VERSION_ghc(9,2,0) - Env.hsc_unit_env -#else - const () -#endif - -hsc_tmpfs :: HscEnv -> TmpFs -hsc_tmpfs = -#if MIN_VERSION_ghc(9,2,0) - Env.hsc_tmpfs -#else - const () -#endif - -hsc_logger :: HscEnv -> Logger -hsc_logger = -#if MIN_VERSION_ghc(9,2,0) - Env.hsc_logger -#else - Logger . DynFlags.log_action . Env.hsc_dflags -#endif - -hsc_hooks :: HscEnv -> Hooks -hsc_hooks = -#if MIN_VERSION_ghc(9,2,0) - Env.hsc_hooks -#else - hooks . Env.hsc_dflags -#endif - hscSetHooks :: Hooks -> HscEnv -> HscEnv hscSetHooks hooks env = -#if MIN_VERSION_ghc(9,2,0) env { Env.hsc_hooks = hooks } -#else - hscSetFlags ((Env.hsc_dflags env) { hooks = hooks}) env -#endif -homeUnitId_ :: DynFlags -> UnitId -homeUnitId_ = -#if MIN_VERSION_ghc(9,2,0) - Session.homeUnitId_ -#elif MIN_VERSION_ghc(9,0,0) - homeUnitId -#else - thisPackage -#endif - -safeImportsOn :: DynFlags -> Bool -safeImportsOn = -#if MIN_VERSION_ghc(9,2,0) - Session.safeImportsOn -#else - DynFlags.safeImportsOn -#endif - -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) -type HomeUnit = Unit -#elif !MIN_VERSION_ghc(9,0,0) -type HomeUnit = UnitId -#endif - hscHomeUnit :: HscEnv -> HomeUnit hscHomeUnit = -#if MIN_VERSION_ghc(9,2,0) Env.hsc_home_unit -#elif MIN_VERSION_ghc(9,0,0) - homeUnit . Env.hsc_dflags -#else - homeUnitId_ . hsc_dflags -#endif -mkHomeModule :: HomeUnit -> ModuleName -> Module -mkHomeModule = -#if MIN_VERSION_ghc(9,2,0) - Home.mkHomeModule -#else - mkModule -#endif - -- | We don't want to generate object code so we compile to bytecode -- (HscInterpreted) which implies LinkInMemory -- HscInterpreted setBytecodeLinkerOptions :: DynFlags -> DynFlags setBytecodeLinkerOptions df = df { ghcLink = LinkInMemory -#if MIN_VERSION_ghc(9,2,0) - , backend = NoBackend -#else - , hscTarget = HscNothing -#endif + , backend = noBackend , ghcMode = CompManager } setInterpreterLinkerOptions :: DynFlags -> DynFlags setInterpreterLinkerOptions df = df { ghcLink = LinkInMemory -#if MIN_VERSION_ghc(9,2,0) - , backend = Interpreter -#else - , hscTarget = HscInterpreted -#endif + , backend = interpreterBackend , ghcMode = CompManager } @@ -253,53 +121,28 @@ -- Ways helpers -- ------------------------------------------------------- -#if !MIN_VERSION_ghc(9,2,0) && MIN_VERSION_ghc(9,0,0) -type Ways = Set.Set Way -#elif !MIN_VERSION_ghc(9,0,0) -type Ways = [Way] -#endif -hostFullWays :: Ways -hostFullWays = -#if MIN_VERSION_ghc(9,0,0) - Ways.hostFullWays -#else - interpWays -#endif - setWays :: Ways -> DynFlags -> DynFlags -setWays ways flags = -#if MIN_VERSION_ghc(9,2,0) - flags { Session.targetWays_ = ways} -#elif MIN_VERSION_ghc(9,0,0) - flags {ways = ways} -#else - updateWays $ flags {ways = ways} -#endif +setWays newWays flags = + flags { Session.targetWays_ = newWays} -- ------------------------------------------------------- -- Backend helpers -- ------------------------------------------------------- -#if !MIN_VERSION_ghc(9,2,0) -type Backend = HscTarget + +ghciBackend :: Backend +#if MIN_VERSION_ghc(9,6,0) +ghciBackend = interpreterBackend +#else +ghciBackend = Interpreter #endif platformDefaultBackend :: DynFlags -> Backend platformDefaultBackend = -#if MIN_VERSION_ghc(9,2,0) Backend.platformDefaultBackend . targetPlatform -#elif MIN_VERSION_ghc(8,10,0) - defaultObjectTarget -#else - defaultObjectTarget . DynFlags.targetPlatform -#endif setBackend :: Backend -> DynFlags -> DynFlags setBackend backend flags = -#if MIN_VERSION_ghc(9,2,0) flags { backend = backend } -#else - flags { hscTarget = backend } -#endif diff --git a/src/Development/IDE/GHC/Compat/Error.hs b/src/Development/IDE/GHC/Compat/Error.hs new file mode 100644 --- /dev/null +++ b/src/Development/IDE/GHC/Compat/Error.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +module Development.IDE.GHC.Compat.Error ( + -- * Top-level error types and lens for easy access + MsgEnvelope(..), + msgEnvelopeErrorL, + GhcMessage(..), + -- * Error messages for the typechecking and renamer phase + TcRnMessage (..), + TcRnMessageDetailed (..), + Hole(..), + stripTcRnMessageContext, + -- * Parsing error message + PsMessage(..), + -- * Desugaring diagnostic + DsMessage (..), + -- * Driver error message + DriverMessage (..), + -- * General Diagnostics + Diagnostic(..), + -- * GHC Hints + GhcHint (SuggestExtension), + LanguageExtensionHint (..), + -- * Prisms and lenses for error selection + _TcRnMessage, + _TcRnMessageWithCtx, + _GhcPsMessage, + _GhcDsMessage, + _GhcDriverMessage, + _ReportHoleError, + _TcRnIllegalWildcardInType, + _TcRnPartialTypeSignatures, + _TcRnMissingSignature, + _TcRnSolverReport, + _TcRnMessageWithInfo, + _TypeHole, + _ConstraintHole, + reportContextL, + reportContentL, + _MismatchMessage, + _TypeEqMismatchActual, + _TypeEqMismatchExpected, + ) where + +import Control.Lens +import Development.IDE.GHC.Compat (Type) +import GHC.Driver.Errors.Types +import GHC.HsToCore.Errors.Types +import GHC.Tc.Errors.Types +import GHC.Tc.Types.Constraint (Hole (..), HoleSort) +import GHC.Types.Error + +-- | Some 'TcRnMessage's are nested in other constructors for additional context. +-- For example, 'TcRnWithHsDocContext' and 'TcRnMessageWithInfo'. +-- However, in most occasions you don't need the additional context and you just want +-- the error message. @'_TcRnMessage'@ recursively unwraps these constructors, +-- until there are no more constructors with additional context. +-- +-- Use @'_TcRnMessageWithCtx'@ if you need the additional context. You can always +-- strip it later using @'stripTcRnMessageContext'@. +-- +_TcRnMessage :: Fold GhcMessage TcRnMessage +_TcRnMessage = _TcRnMessageWithCtx . to stripTcRnMessageContext + +_TcRnMessageWithCtx :: Prism' GhcMessage TcRnMessage +_TcRnMessageWithCtx = prism' GhcTcRnMessage (\case + GhcTcRnMessage tcRnMsg -> Just tcRnMsg + _ -> Nothing) + +_GhcPsMessage :: Prism' GhcMessage PsMessage +_GhcPsMessage = prism' GhcPsMessage (\case + GhcPsMessage psMsg -> Just psMsg + _ -> Nothing) + +_GhcDsMessage :: Prism' GhcMessage DsMessage +_GhcDsMessage = prism' GhcDsMessage (\case + GhcDsMessage dsMsg -> Just dsMsg + _ -> Nothing) + +_GhcDriverMessage :: Prism' GhcMessage DriverMessage +_GhcDriverMessage = prism' GhcDriverMessage (\case + GhcDriverMessage driverMsg -> Just driverMsg + _ -> Nothing) + +-- | Some 'TcRnMessage's are nested in other constructors for additional context. +-- For example, 'TcRnWithHsDocContext' and 'TcRnMessageWithInfo'. +-- However, in some occasions you don't need the additional context and you just want +-- the error message. @'stripTcRnMessageContext'@ recursively unwraps these constructors, +-- until there are no more constructors with additional context. +-- +stripTcRnMessageContext :: TcRnMessage -> TcRnMessage +stripTcRnMessageContext = \case +#if MIN_VERSION_ghc(9, 6, 1) + TcRnWithHsDocContext _ tcMsg -> stripTcRnMessageContext tcMsg +#endif + TcRnMessageWithInfo _ (TcRnMessageDetailed _ tcMsg) -> stripTcRnMessageContext tcMsg + msg -> msg + +msgEnvelopeErrorL :: Lens' (MsgEnvelope e) e +msgEnvelopeErrorL = lens errMsgDiagnostic (\envelope e -> envelope { errMsgDiagnostic = e } ) + +makePrisms ''TcRnMessage + +makeLensesWith + (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) + ''SolverReportWithCtxt + +makePrisms ''TcSolverReportMsg + +makePrisms ''HoleSort + +-- | Focus 'MismatchMsg' from 'TcSolverReportMsg'. Currently, 'MismatchMsg' can be +-- extracted from 'CannotUnifyVariable' and 'Mismatch' constructors. +_MismatchMessage :: Traversal' TcSolverReportMsg MismatchMsg +_MismatchMessage focus (Mismatch msg t a c) = (\msg' -> Mismatch msg' t a c) <$> focus msg +_MismatchMessage focus (CannotUnifyVariable msg a) = flip CannotUnifyVariable a <$> focus msg +_MismatchMessage _ report = pure report + +-- | Focus 'teq_mismatch_expected' from 'TypeEqMismatch'. +_TypeEqMismatchExpected :: Traversal' MismatchMsg Type +#if MIN_VERSION_ghc(9,10,2) +_TypeEqMismatchExpected focus mismatch@(TypeEqMismatch _ _ _ expected _ _ _) = + (\expected' -> mismatch { teq_mismatch_expected = expected' }) <$> focus expected +#else +_TypeEqMismatchExpected focus mismatch@(TypeEqMismatch _ _ _ _ expected _ _ _) = + (\expected' -> mismatch { teq_mismatch_expected = expected' }) <$> focus expected +#endif +_TypeEqMismatchExpected _ mismatch = pure mismatch + +-- | Focus 'teq_mismatch_actual' from 'TypeEqMismatch'. +_TypeEqMismatchActual :: Traversal' MismatchMsg Type +#if MIN_VERSION_ghc(9,10,2) +_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ actual _ _) = + (\actual' -> mismatch { teq_mismatch_actual = actual' }) <$> focus actual +#else +_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ _ actual _ _) = + (\actual' -> mismatch { teq_mismatch_expected = actual' }) <$> focus actual +#endif +_TypeEqMismatchActual _ mismatch = pure mismatch diff --git a/src/Development/IDE/GHC/Compat/Iface.hs b/src/Development/IDE/GHC/Compat/Iface.hs --- a/src/Development/IDE/GHC/Compat/Iface.hs +++ b/src/Development/IDE/GHC/Compat/Iface.hs @@ -6,41 +6,31 @@ cannotFindModule, ) where +import Development.IDE.GHC.Compat.Env +import Development.IDE.GHC.Compat.Outputable import GHC -#if MIN_VERSION_ghc(9,3,0) import GHC.Driver.Session (targetProfile) -#endif -#if MIN_VERSION_ghc(9,2,0) import qualified GHC.Iface.Load as Iface import GHC.Unit.Finder.Types (FindResult) -#elif MIN_VERSION_ghc(9,0,0) -import qualified GHC.Driver.Finder as Finder -import GHC.Driver.Types (FindResult) -import qualified GHC.Iface.Load as Iface -#else -import Finder (FindResult) -import qualified Finder -import qualified MkIface -#endif -import Development.IDE.GHC.Compat.Env -import Development.IDE.GHC.Compat.Outputable +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] +#if MIN_VERSION_ghc(9,7,0) +import GHC.Iface.Errors.Ppr (missingInterfaceErrorDiagnostic) +import GHC.Iface.Errors.Types (IfaceMessage) +#endif + writeIfaceFile :: HscEnv -> FilePath -> ModIface -> IO () -#if MIN_VERSION_ghc(9,3,0) -writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) fp iface -#elif MIN_VERSION_ghc(9,2,0) -writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (hsc_dflags env) fp iface -#elif MIN_VERSION_ghc(9,0,0) -writeIfaceFile env = Iface.writeIface (hsc_dflags env) +#if MIN_VERSION_ghc(9,11,0) +writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) (Iface.flagsToIfCompression $ hsc_dflags env) fp iface #else -writeIfaceFile env = MkIface.writeIfaceFile (hsc_dflags env) +writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (targetProfile $ hsc_dflags env) fp iface #endif cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc cannotFindModule env modname fr = -#if MIN_VERSION_ghc(9,2,0) - Iface.cannotFindModule env modname fr +#if MIN_VERSION_ghc(9,7,0) + missingInterfaceErrorDiagnostic (defaultDiagnosticOpts @IfaceMessage) $ Iface.cannotFindModule env modname fr #else - Finder.cannotFindModule (hsc_dflags env) modname fr + Iface.cannotFindModule env modname fr #endif diff --git a/src/Development/IDE/GHC/Compat/Logger.hs b/src/Development/IDE/GHC/Compat/Logger.hs --- a/src/Development/IDE/GHC/Compat/Logger.hs +++ b/src/Development/IDE/GHC/Compat/Logger.hs @@ -2,7 +2,7 @@ -- | Compat module for GHC 9.2 Logger infrastructure. module Development.IDE.GHC.Compat.Logger ( putLogHook, - Development.IDE.GHC.Compat.Logger.pushLogHook, + Logger.pushLogHook, -- * Logging stuff LogActionCompat, logActionCompat, @@ -13,57 +13,23 @@ import Development.IDE.GHC.Compat.Env as Env import Development.IDE.GHC.Compat.Outputable -#if MIN_VERSION_ghc(9,0,0) -import GHC.Driver.Session as DynFlags -import GHC.Utils.Outputable -#if MIN_VERSION_ghc(9,2,0) -import GHC.Driver.Env (hsc_logger) -import GHC.Utils.Logger as Logger -#endif -#else -import DynFlags -import Outputable (queryQual) -#endif -#if MIN_VERSION_ghc(9,3,0) + import GHC.Types.Error -#endif +import GHC.Utils.Logger as Logger +import GHC.Utils.Outputable putLogHook :: Logger -> HscEnv -> HscEnv putLogHook logger env = -#if MIN_VERSION_ghc(9,2,0) env { hsc_logger = logger } -#else - hscSetFlags ((hsc_dflags env) { DynFlags.log_action = Env.log_action logger }) env -#endif -pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger -pushLogHook f logger = -#if MIN_VERSION_ghc(9,2,0) - Logger.pushLogHook f logger -#else - logger { Env.log_action = f (Env.log_action logger) } -#endif - -#if MIN_VERSION_ghc(9,3,0) type LogActionCompat = LogFlags -> Maybe DiagnosticReason -> Maybe Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO () -- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test. logActionCompat :: LogActionCompat -> LogAction -logActionCompat logAction logFlags (MCDiagnostic severity wr) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify -logActionCompat logAction logFlags _cls loc = logAction logFlags Nothing Nothing loc alwaysQualify - -#else -#if MIN_VERSION_ghc(9,0,0) -type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO () - --- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test. -logActionCompat :: LogActionCompat -> LogAction -logActionCompat logAction dynFlags wr severity loc = logAction dynFlags wr severity loc alwaysQualify - +#if MIN_VERSION_ghc(9,7,0) +logActionCompat logAction logFlags (MCDiagnostic severity (ResolvedDiagnosticReason wr) _) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify #else -type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO () - -logActionCompat :: LogActionCompat -> LogAction -logActionCompat logAction dynFlags wr severity loc style = logAction dynFlags wr severity loc (queryQual style) -#endif +logActionCompat logAction logFlags (MCDiagnostic severity wr _) loc = logAction logFlags (Just wr) (Just severity) loc alwaysQualify #endif +logActionCompat logAction logFlags _cls loc = logAction logFlags Nothing Nothing loc alwaysQualify + diff --git a/src/Development/IDE/GHC/Compat/Outputable.hs b/src/Development/IDE/GHC/Compat/Outputable.hs --- a/src/Development/IDE/GHC/Compat/Outputable.hs +++ b/src/Development/IDE/GHC/Compat/Outputable.hs @@ -9,229 +9,133 @@ ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, punctuate, printSDocQualifiedUnsafe, printWithoutUniques, - mkPrintUnqualified, + printWithoutUniquesOneLine, mkPrintUnqualifiedDefault, - PrintUnqualified(..), + PrintUnqualified, defaultUserStyle, withPprStyle, -- * Parser errors PsWarning, PsError, -#if MIN_VERSION_ghc(9,3,0) + defaultDiagnosticOpts, + GhcMessage, + DriverMessage, + Messages, + initDiagOpts, + pprMessages, DiagnosticReason(..), renderDiagnosticMessageWithHints, -#else - pprWarning, - pprError, -#endif + pprMsgEnvelopeBagWithLoc, + Error.getMessages, + renderWithContext, + showSDocOneLine, + defaultSDocContext, + errMsgDiagnostic, + unDecorated, + diagnosticMessage, -- * Error infrastructure DecoratedSDoc, MsgEnvelope, ErrMsg, WarnMsg, + SourceError(..), errMsgSpan, errMsgSeverity, formatErrorWithQual, mkWarnMsg, mkSrcErr, srcErrorMessages, + textDoc, ) where - -#if MIN_VERSION_ghc(9,2,0) +import Data.Maybe +import GHC.Driver.Config.Diagnostic import GHC.Driver.Env +import GHC.Driver.Errors.Types (DriverMessage, GhcMessage) import GHC.Driver.Ppr import GHC.Driver.Session -#if !MIN_VERSION_ghc(9,3,0) -import GHC.Parser.Errors -#else import GHC.Parser.Errors.Types -#endif -import qualified GHC.Parser.Errors.Ppr as Ppr -import qualified GHC.Types.Error as Error +import qualified GHC.Types.Error as Error import GHC.Types.Name.Ppr import GHC.Types.Name.Reader import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Unit.State -import GHC.Utils.Error hiding (mkWarnMsg) -import GHC.Utils.Outputable as Out hiding - (defaultUserStyle) -import qualified GHC.Utils.Outputable as Out +import GHC.Utils.Error +import GHC.Utils.Outputable as Out import GHC.Utils.Panic -#elif MIN_VERSION_ghc(9,0,0) -import GHC.Driver.Session -import GHC.Driver.Types as HscTypes -import GHC.Types.Name.Reader (GlobalRdrEnv) -import GHC.Types.SrcLoc -import GHC.Utils.Error as Err hiding (mkWarnMsg) -import qualified GHC.Utils.Error as Err -import GHC.Utils.Outputable as Out hiding - (defaultUserStyle) -import qualified GHC.Utils.Outputable as Out -#else -import Development.IDE.GHC.Compat.Core (GlobalRdrEnv) -import DynFlags -import ErrUtils hiding (mkWarnMsg) -import qualified ErrUtils as Err -import HscTypes -import Outputable as Out hiding - (defaultUserStyle) -import qualified Outputable as Out -import SrcLoc -#endif -#if MIN_VERSION_ghc(9,3,0) -import Data.Maybe -import GHC.Driver.Config.Diagnostic -import GHC.Utils.Logger + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +#if MIN_VERSION_ghc(9,7,0) +import GHC.Types.Error (defaultDiagnosticOpts) #endif +type PrintUnqualified = NamePprCtx + -- | A compatible function to print `Outputable` instances -- without unique symbols. -- -- It print with a user-friendly style like: `a_a4ME` as `a`. printWithoutUniques :: Outputable a => a -> String -printWithoutUniques = -#if MIN_VERSION_ghc(9,2,0) - renderWithContext (defaultSDocContext +printWithoutUniques = printWithoutUniques' renderWithContext + +printWithoutUniquesOneLine :: Outputable a => a -> String +printWithoutUniquesOneLine = printWithoutUniques' showSDocOneLine + +printWithoutUniques' :: Outputable a => (SDocContext -> SDoc -> String) -> a -> String +printWithoutUniques' showSDoc = + showSDoc (defaultSDocContext { sdocStyle = defaultUserStyle , sdocSuppressUniques = True , sdocCanUseUnicode = True }) . ppr -#else - go . ppr - where - go sdoc = oldRenderWithStyle dflags sdoc (oldMkUserStyle dflags neverQualify AllTheWay) - dflags = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques -#endif printSDocQualifiedUnsafe :: PrintUnqualified -> SDoc -> String -#if MIN_VERSION_ghc(9,2,0) printSDocQualifiedUnsafe unqual doc = -- Taken from 'showSDocForUser' renderWithContext (defaultSDocContext { sdocStyle = sty }) doc' where sty = mkUserStyle unqual AllTheWay doc' = pprWithUnitState emptyUnitState doc -#else -printSDocQualifiedUnsafe unqual doc = - showSDocForUser unsafeGlobalDynFlags unqual doc -#endif -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) -oldRenderWithStyle dflags sdoc sty = Out.renderWithStyle (initSDocContext dflags sty) sdoc -oldMkUserStyle _ = Out.mkUserStyle -oldMkErrStyle _ = Out.mkErrStyle -oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc -oldFormatErrDoc dflags = Err.formatErrDoc dummySDocContext - where dummySDocContext = initSDocContext dflags Out.defaultUserStyle -#elif !MIN_VERSION_ghc(9,0,0) -oldRenderWithStyle :: DynFlags -> Out.SDoc -> Out.PprStyle -> String -oldRenderWithStyle = Out.renderWithStyle -oldMkUserStyle :: DynFlags -> Out.PrintUnqualified -> Out.Depth -> Out.PprStyle -oldMkUserStyle = Out.mkUserStyle - -oldMkErrStyle :: DynFlags -> Out.PrintUnqualified -> Out.PprStyle -oldMkErrStyle = Out.mkErrStyle - -oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc -oldFormatErrDoc = Err.formatErrDoc -#endif - -#if !MIN_VERSION_ghc(9,3,0) -pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc -pprWarning = -#if MIN_VERSION_ghc(9,2,0) - Ppr.pprWarning -#else - id -#endif - -pprError :: PsError -> MsgEnvelope DecoratedSDoc -pprError = -#if MIN_VERSION_ghc(9,2,0) - Ppr.pprError -#else - id -#endif -#endif - formatErrorWithQual :: DynFlags -> MsgEnvelope DecoratedSDoc -> String formatErrorWithQual dflags e = -#if MIN_VERSION_ghc(9,2,0) showSDoc dflags (pprNoLocMsgEnvelope e) -#if MIN_VERSION_ghc(9,3,0) pprNoLocMsgEnvelope :: MsgEnvelope DecoratedSDoc -> SDoc -#else -pprNoLocMsgEnvelope :: Error.RenderableDiagnostic e => MsgEnvelope e -> SDoc -#endif pprNoLocMsgEnvelope (MsgEnvelope { errMsgDiagnostic = e , errMsgContext = unqual }) - = sdocWithContext $ \ctx -> + = sdocWithContext $ \_ctx -> withErrStyle unqual $ -#if MIN_VERSION_ghc(9,3,0) - (formatBulleted ctx $ e) +#if MIN_VERSION_ghc(9,7,0) + formatBulleted e #else - (formatBulleted ctx $ Error.renderDiagnostic e) + formatBulleted _ctx e #endif -#else - Out.showSDoc dflags - $ Out.withPprStyle (oldMkErrStyle dflags $ errMsgContext e) - $ oldFormatErrDoc dflags - $ Err.errMsgDoc e -#endif -#if !MIN_VERSION_ghc(9,2,0) -type DecoratedSDoc = () -type MsgEnvelope e = ErrMsg -type PsWarning = ErrMsg -type PsError = ErrMsg -#endif - -#if MIN_VERSION_ghc(9,2,0) -type ErrMsg = MsgEnvelope DecoratedSDoc -#endif -#if MIN_VERSION_ghc(9,3,0) -type WarnMsg = MsgEnvelope DecoratedSDoc -#endif +type ErrMsg = MsgEnvelope GhcMessage +type WarnMsg = MsgEnvelope GhcMessage mkPrintUnqualifiedDefault :: HscEnv -> GlobalRdrEnv -> PrintUnqualified mkPrintUnqualifiedDefault env = -#if MIN_VERSION_ghc(9,2,0) - -- GHC 9.2 version - -- mkPrintUnqualified :: UnitEnv -> GlobalRdrEnv -> PrintUnqualified - mkPrintUnqualified (hsc_unit_env env) -#else - HscTypes.mkPrintUnqualified (hsc_dflags env) -#endif + mkNamePprCtx ptc (hsc_unit_env env) + where + ptc = initPromotionTickContext (hsc_dflags env) -#if MIN_VERSION_ghc(9,3,0) -renderDiagnosticMessageWithHints :: Diagnostic a => a -> DecoratedSDoc -renderDiagnosticMessageWithHints a = Error.unionDecoratedSDoc (diagnosticMessage a) (mkDecorated $ map ppr $ diagnosticHints a) -#endif +renderDiagnosticMessageWithHints :: forall a. Diagnostic a => a -> DecoratedSDoc +renderDiagnosticMessageWithHints a = Error.unionDecoratedSDoc + (diagnosticMessage + (defaultDiagnosticOpts @a) + a) (mkDecorated $ map ppr $ diagnosticHints a) -#if MIN_VERSION_ghc(9,3,0) mkWarnMsg :: DynFlags -> Maybe DiagnosticReason -> b -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc mkWarnMsg df reason _logFlags l st doc = fmap renderDiagnosticMessageWithHints $ mkMsgEnvelope (initDiagOpts df) l st (mkPlainDiagnostic (fromMaybe WarningWithoutFlag reason) [] doc) -#else -mkWarnMsg :: a -> b -> DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc -mkWarnMsg _ _ = -#if MIN_VERSION_ghc(9,2,0) - const Error.mkWarnMsg -#else - Err.mkWarnMsg -#endif -#endif -defaultUserStyle :: PprStyle -#if MIN_VERSION_ghc(9,0,0) -defaultUserStyle = Out.defaultUserStyle -#else -defaultUserStyle = Out.defaultUserStyle unsafeGlobalDynFlags -#endif +textDoc :: String -> SDoc +textDoc = text diff --git a/src/Development/IDE/GHC/Compat/Parser.hs b/src/Development/IDE/GHC/Compat/Parser.hs --- a/src/Development/IDE/GHC/Compat/Parser.hs +++ b/src/Development/IDE/GHC/Compat/Parser.hs @@ -1,176 +1,77 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternSynonyms #-} -{-# HLINT ignore "Unused LANGUAGE pragma" #-} -- | Parser compatibility module. module Development.IDE.GHC.Compat.Parser ( initParserOpts, initParserState, -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) - -- in GHC == 9.2 the type doesn't exist - -- In GHC == 9.0 it is a data-type - -- and GHC < 9.0 it is type-def - -- - -- Export data-type here, otherwise only the simple type. - Anno.ApiAnns(..), -#else - ApiAnns, -#endif -#if MIN_VERSION_ghc(9,0,0) PsSpan(..), -#endif -#if MIN_VERSION_ghc(9,2,0) pattern HsParsedModule, type GHC.HsParsedModule, Development.IDE.GHC.Compat.Parser.hpm_module, Development.IDE.GHC.Compat.Parser.hpm_src_files, - Development.IDE.GHC.Compat.Parser.hpm_annotations, pattern ParsedModule, Development.IDE.GHC.Compat.Parser.pm_parsed_source, type GHC.ParsedModule, Development.IDE.GHC.Compat.Parser.pm_mod_summary, Development.IDE.GHC.Compat.Parser.pm_extra_src_files, - Development.IDE.GHC.Compat.Parser.pm_annotations, -#else - GHC.HsParsedModule(..), - GHC.ParsedModule(..), -#endif - mkApiAnns, -- * API Annotations +#if !MIN_VERSION_ghc(9,11,0) Anno.AnnKeywordId(..), -#if !MIN_VERSION_ghc(9,2,0) - Anno.AnnotationComment(..), #endif pattern EpaLineComment, pattern EpaBlockComment ) where -#if MIN_VERSION_ghc(9,0,0) -#if !MIN_VERSION_ghc(9,2,0) -import qualified GHC.Driver.Types as GHC -#endif +import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.Util import qualified GHC.Parser.Annotation as Anno import qualified GHC.Parser.Lexer as Lexer import GHC.Types.SrcLoc (PsSpan (..)) -#if MIN_VERSION_ghc(9,2,0) -import GHC (Anchor (anchor), - EpAnnComments (priorComments), - EpaComment (EpaComment), - EpaCommentTok (..), - epAnnComments, + + + +import GHC (EpaCommentTok (..), pm_extra_src_files, pm_mod_summary, pm_parsed_source) import qualified GHC -#if MIN_VERSION_ghc(9,3,0) import qualified GHC.Driver.Config.Parser as Config -#else -import qualified GHC.Driver.Config as Config -#endif -import GHC.Hs (LEpaComment, hpm_module, - hpm_src_files) -import GHC.Parser.Lexer hiding (initParserState) -#endif -#else -import qualified ApiAnnotation as Anno -import qualified HscTypes as GHC -import Lexer -import qualified SrcLoc -#endif -import Development.IDE.GHC.Compat.Core -import Development.IDE.GHC.Compat.Util +import GHC.Hs (hpm_module, hpm_src_files) -#if !MIN_VERSION_ghc(9,2,0) -import qualified Data.Map as Map -import qualified GHC -#endif -#if !MIN_VERSION_ghc(9,0,0) -type ParserOpts = DynFlags -#elif !MIN_VERSION_ghc(9,2,0) -type ParserOpts = Lexer.ParserFlags -#endif initParserOpts :: DynFlags -> ParserOpts initParserOpts = -#if MIN_VERSION_ghc(9,2,0) Config.initParserOpts -#elif MIN_VERSION_ghc(9,0,0) - Lexer.mkParserFlags -#else - id -#endif initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState initParserState = -#if MIN_VERSION_ghc(9,2,0) Lexer.initParserState -#elif MIN_VERSION_ghc(9,0,0) - Lexer.mkPStatePure -#else - Lexer.mkPState -#endif -#if MIN_VERSION_ghc(9,2,0) --- GHC 9.2 does not have ApiAnns anymore packaged in ParsedModule. Now the --- annotations are found in the ast. -type ApiAnns = () -#else -type ApiAnns = Anno.ApiAnns -#endif - -#if MIN_VERSION_ghc(9,2,0) -pattern HsParsedModule :: Located HsModule -> [FilePath] -> ApiAnns -> GHC.HsParsedModule +pattern HsParsedModule :: Located (HsModule GhcPs) -> [FilePath] -> GHC.HsParsedModule pattern HsParsedModule { hpm_module , hpm_src_files - , hpm_annotations - } <- ( (,()) -> (GHC.HsParsedModule{..}, hpm_annotations)) + } <- GHC.HsParsedModule{..} where - HsParsedModule hpm_module hpm_src_files hpm_annotations = + HsParsedModule hpm_module hpm_src_files = GHC.HsParsedModule hpm_module hpm_src_files -#endif -#if MIN_VERSION_ghc(9,2,0) -pattern ParsedModule :: ModSummary -> ParsedSource -> [FilePath] -> ApiAnns -> GHC.ParsedModule +pattern ParsedModule :: ModSummary -> ParsedSource -> [FilePath] -> GHC.ParsedModule pattern ParsedModule { pm_mod_summary , pm_parsed_source , pm_extra_src_files - , pm_annotations - } <- ( (,()) -> (GHC.ParsedModule{..}, pm_annotations)) + } <- GHC.ParsedModule{..} where - ParsedModule ms parsed extra_src_files _anns = + ParsedModule ms parsed extra_src_files = GHC.ParsedModule { pm_mod_summary = ms , pm_parsed_source = parsed , pm_extra_src_files = extra_src_files } {-# COMPLETE ParsedModule :: GHC.ParsedModule #-} -#endif -mkApiAnns :: PState -> ApiAnns -#if MIN_VERSION_ghc(9,2,0) -mkApiAnns = const () -#else -mkApiAnns pst = -#if MIN_VERSION_ghc(9,0,1) - -- Copied from GHC.Driver.Main - Anno.ApiAnns { - apiAnnItems = Map.fromListWith (++) $ annotations pst, - apiAnnEofPos = eof_pos pst, - apiAnnComments = Map.fromList (annotations_comments pst), - apiAnnRogueComments = comment_q pst - } -#else - (Map.fromListWith (++) $ annotations pst, - Map.fromList ((SrcLoc.noSrcSpan,comment_q pst) - :annotations_comments pst)) -#endif -#endif -#if !MIN_VERSION_ghc(9,2,0) -pattern EpaLineComment a = Anno.AnnLineComment a -pattern EpaBlockComment a = Anno.AnnBlockComment a -#endif diff --git a/src/Development/IDE/GHC/Compat/Plugins.hs b/src/Development/IDE/GHC/Compat/Plugins.hs --- a/src/Development/IDE/GHC/Compat/Plugins.hs +++ b/src/Development/IDE/GHC/Compat/Plugins.hs @@ -7,8 +7,6 @@ defaultPlugin, PluginWithArgs(..), applyPluginsParsedResultAction, - initializePlugins, - initPlugins, -- * Static plugins StaticPlugin(..), @@ -19,97 +17,33 @@ getPsMessages ) where -#if MIN_VERSION_ghc(9,0,0) -#if MIN_VERSION_ghc(9,2,0) -import qualified GHC.Driver.Env as Env -#endif -import GHC.Driver.Plugins (Plugin (..), - PluginWithArgs (..), - StaticPlugin (..), - defaultPlugin, - withPlugins) -#if MIN_VERSION_ghc(9,3,0) -import GHC.Driver.Plugins (ParsedResult (..), - PsMessages (..), - staticPlugins) -import qualified GHC.Parser.Lexer as Lexer -#else -import Data.Bifunctor (bimap) -#endif -import qualified GHC.Runtime.Loader as Loader -#else -import qualified DynamicLoading as Loader -import Plugins -#endif import Development.IDE.GHC.Compat.Core -import Development.IDE.GHC.Compat.Env (hscSetFlags, hsc_dflags) -import Development.IDE.GHC.Compat.Outputable as Out -import Development.IDE.GHC.Compat.Parser as Parser -import Development.IDE.GHC.Compat.Util (Bag) +import Development.IDE.GHC.Compat.Parser as Parser +import qualified GHC.Driver.Env as Env +import GHC.Driver.Plugins (ParsedResult (..), + Plugin (..), + PluginWithArgs (..), + PsMessages (..), + StaticPlugin (..), + defaultPlugin, + staticPlugins, withPlugins) +import qualified GHC.Parser.Lexer as Lexer -#if !MIN_VERSION_ghc(9,3,0) -type PsMessages = (Bag WarnMsg, Bag ErrMsg) -#endif -getPsMessages :: PState -> DynFlags -> PsMessages -getPsMessages pst dflags = -#if MIN_VERSION_ghc(9,3,0) +getPsMessages :: PState -> PsMessages +getPsMessages pst = uncurry PsMessages $ Lexer.getPsMessages pst -#else -#if MIN_VERSION_ghc(9,2,0) - bimap (fmap pprWarning) (fmap pprError) $ -#endif - getMessages pst -#if !MIN_VERSION_ghc(9,2,0) - dflags -#endif -#endif -applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> Parser.ApiAnns -> ParsedSource -> PsMessages -> IO (ParsedSource, PsMessages) -applyPluginsParsedResultAction env dflags ms hpm_annotations parsed msgs = do +applyPluginsParsedResultAction :: HscEnv -> ModSummary -> ParsedSource -> PsMessages -> IO (ParsedSource, PsMessages) +applyPluginsParsedResultAction env ms parsed msgs = do -- Apply parsedResultAction of plugins let applyPluginAction p opts = parsedResultAction p opts ms -#if MIN_VERSION_ghc(9,3,0) - fmap (\result -> (hpm_module (parsedResultModule result), (parsedResultMessages result))) $ runHsc env $ withPlugins -#else - fmap (\parsed_module -> (hpm_module parsed_module, msgs)) $ runHsc env $ withPlugins -#endif -#if MIN_VERSION_ghc(9,3,0) + fmap (\result -> (hpm_module (parsedResultModule result), parsedResultMessages result)) $ runHsc env $ withPlugins (Env.hsc_plugins env) -#elif MIN_VERSION_ghc(9,2,0) - env -#else - dflags -#endif applyPluginAction -#if MIN_VERSION_ghc(9,3,0) - (ParsedResult (HsParsedModule parsed [] hpm_annotations) msgs) -#else - (HsParsedModule parsed [] hpm_annotations) -#endif + (ParsedResult (HsParsedModule parsed []) msgs) -initializePlugins :: HscEnv -> IO HscEnv -initializePlugins env = do -#if MIN_VERSION_ghc(9,2,0) - Loader.initializePlugins env -#else - newDf <- Loader.initializePlugins env (hsc_dflags env) - pure $ hscSetFlags newDf env -#endif --- | Plugins aren't stored in ModSummary anymore since GHC 9.2, but this --- function still returns it for compatibility with 8.10 -initPlugins :: HscEnv -> ModSummary -> IO (ModSummary, HscEnv) -initPlugins session modSummary = do - session1 <- initializePlugins (hscSetFlags (ms_hspp_opts modSummary) session) - return (modSummary{ms_hspp_opts = hsc_dflags session1}, session1) - hsc_static_plugins :: HscEnv -> [StaticPlugin] -#if MIN_VERSION_ghc(9,3,0) hsc_static_plugins = staticPlugins . Env.hsc_plugins -#elif MIN_VERSION_ghc(9,2,0) -hsc_static_plugins = Env.hsc_static_plugins -#else -hsc_static_plugins = staticPlugins . hsc_dflags -#endif diff --git a/src/Development/IDE/GHC/Compat/Units.hs b/src/Development/IDE/GHC/Compat/Units.hs --- a/src/Development/IDE/GHC/Compat/Units.hs +++ b/src/Development/IDE/GHC/Compat/Units.hs @@ -1,14 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE CPP #-} -- | Compat module for 'UnitState' and 'UnitInfo'. module Development.IDE.GHC.Compat.Units ( -- * UnitState UnitState, -#if MIN_VERSION_ghc(9,3,0) initUnits, -#endif - oldInitUnits, unitState, getUnitName, explicitUnits, @@ -26,7 +22,7 @@ unitExposedModules, unitDepends, unitHaddockInterfaces, - unitInfoId, + mkUnit, unitPackageNameString, unitPackageVersion, -- * UnitId helpers @@ -34,15 +30,12 @@ Unit, unitString, stringToUnit, -#if !MIN_VERSION_ghc(9,0,0) - pattern RealUnit, -#endif definiteUnitId, defUnitId, installedModule, -- * Module toUnitId, - Development.IDE.GHC.Compat.Units.moduleUnitId, + moduleUnitId, moduleUnit, -- * ExternalPackageState ExternalPackageState(..), @@ -50,110 +43,72 @@ filterInplaceUnits, FinderCache, showSDocForUser', + findImportedModule, ) where -import Control.Monad -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map -#if MIN_VERSION_ghc(9,3,0) -import GHC.Unit.Home.ModInfo -#endif -#if MIN_VERSION_ghc(9,0,0) -#if MIN_VERSION_ghc(9,2,0) -import qualified GHC.Data.ShortText as ST -#if !MIN_VERSION_ghc(9,3,0) -import GHC.Driver.Env (hsc_unit_dbs) -#endif -import GHC.Driver.Ppr -import GHC.Unit.Env -import GHC.Unit.External -import GHC.Unit.Finder -#else -import GHC.Driver.Types -#endif -import GHC.Data.FastString -import qualified GHC.Driver.Session as DynFlags -import GHC.Types.Unique.Set -import qualified GHC.Unit.Info as UnitInfo -import GHC.Unit.State (LookupResult, UnitInfo, - UnitState (unitInfoMap)) -import qualified GHC.Unit.State as State -import GHC.Unit.Types hiding (moduleUnit, toUnitId) -import qualified GHC.Unit.Types as Unit -import GHC.Utils.Outputable -#else -import qualified DynFlags -import FastString -import GhcPlugins (SDoc, showSDocForUser) -import HscTypes -import Module hiding (moduleUnitId) -import qualified Module -import Packages (InstalledPackageInfo (haddockInterfaces, packageName), - LookupResult, PackageConfig, - PackageConfigMap, - PackageState, - getPackageConfigMap, - lookupPackage') -import qualified Packages -#endif - +import Data.Either import Development.IDE.GHC.Compat.Core import Development.IDE.GHC.Compat.Env -#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) -import Data.Map (Map) -#endif -import Data.Either -import Data.Version +import Development.IDE.GHC.Compat.Outputable +import Prelude hiding (mod) + +import Control.Monad +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map import qualified GHC +import qualified GHC.Data.ShortText as ST +import qualified GHC.Driver.Session as DynFlags +import GHC.Types.PkgQual (PkgQual (NoPkgQual)) +import GHC.Types.Unique.Set +import GHC.Unit.External +import qualified GHC.Unit.Finder as GHC +import GHC.Unit.Home.ModInfo +import qualified GHC.Unit.Info as UnitInfo +import GHC.Unit.State (LookupResult, UnitInfo, + UnitInfoMap, + UnitState (unitInfoMap), + lookupUnit', mkUnit, + unitDepends, + unitExposedModules, + unitPackageNameString, + unitPackageVersion) +import qualified GHC.Unit.State as State +import GHC.Unit.Types -#if MIN_VERSION_ghc(9,0,0) -type PreloadUnitClosure = UniqSet UnitId -#if MIN_VERSION_ghc(9,2,0) -type UnitInfoMap = State.UnitInfoMap -#else -type UnitInfoMap = Map UnitId UnitInfo -#endif -#else -type UnitState = PackageState -type UnitInfo = PackageConfig -type UnitInfoMap = PackageConfigMap -type PreloadUnitClosure = () -type Unit = UnitId +#if MIN_VERSION_ghc(9,13,0) +import qualified Data.Set as Set +import GHC.Unit.Home.Graph +import GHC.Unit.Home.PackageTable (emptyHomePackageTable) +import GHC.Unit.Module.Graph (emptyMG) #endif -#if !MIN_VERSION_ghc(9,0,0) -unitString :: Unit -> String -unitString = Module.unitIdString - -stringToUnit :: String -> Unit -stringToUnit = Module.stringToUnitId -#endif +type PreloadUnitClosure = UniqSet UnitId unitState :: HscEnv -> UnitState -#if MIN_VERSION_ghc(9,2,0) unitState = ue_units . hsc_unit_env -#elif MIN_VERSION_ghc(9,0,0) -unitState = DynFlags.unitState . hsc_dflags + +createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> IO HomeUnitGraph +createUnitEnvFromFlags unitDflags = do +#if MIN_VERSION_ghc(9,13,0) + let mkEntry dflags = do + hpt <- emptyHomePackageTable + let us = State.emptyUnitState -- placeholder UnitState + pure (homeUnitId_ dflags, mkHomeUnitEnv us Nothing dflags hpt Nothing) + unitEnvList <- mapM mkEntry (NE.toList unitDflags) + pure $ unitEnv_new (Map.fromList unitEnvList) #else -unitState = DynFlags.pkgState . hsc_dflags + let newInternalUnitEnv dflags = mkHomeUnitEnv dflags emptyHomePackageTable Nothing + unitEnvList = NE.map (\dflags -> (homeUnitId_ dflags, newInternalUnitEnv dflags)) unitDflags + pure $ unitEnv_new (Map.fromList (NE.toList unitEnvList)) #endif -#if MIN_VERSION_ghc(9,3,0) -createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> HomeUnitGraph -createUnitEnvFromFlags unitDflags = - let - newInternalUnitEnv dflags = mkHomeUnitEnv dflags emptyHomePackageTable Nothing - unitEnvList = NE.map (\dflags -> (homeUnitId_ dflags, newInternalUnitEnv dflags)) unitDflags - in - unitEnv_new (Map.fromList (NE.toList (unitEnvList))) - initUnits :: [DynFlags] -> HscEnv -> IO HscEnv initUnits unitDflags env = do let dflags0 = hsc_dflags env -- additionally, set checked dflags so we don't lose fixes - let initial_home_graph = createUnitEnvFromFlags (dflags0 NE.:| unitDflags) - home_units = unitEnv_keys initial_home_graph + initial_home_graph <- createUnitEnvFromFlags (dflags0 NE.:| unitDflags) + let home_units = unitEnv_keys initial_home_graph home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv dflags = homeUnitEnv_dflags homeUnitEnv @@ -177,149 +132,46 @@ , ue_home_unit_graph = home_unit_graph , ue_current_unit = homeUnitId_ dflags0 , ue_eps = ue_eps (hsc_unit_env env) +#if MIN_VERSION_ghc(9,13,0) + , ue_module_graph = emptyMG +#endif } pure $ hscSetFlags dflags1 $ hscSetUnitEnv unit_env env -#endif --- | oldInitUnits only needs to modify DynFlags for GHC <9.2 --- For GHC >= 9.2, we need to set the hsc_unit_env also, that is --- done later by initUnits -oldInitUnits :: DynFlags -> IO DynFlags -#if MIN_VERSION_ghc(9,2,0) -oldInitUnits = pure -#elif MIN_VERSION_ghc(9,0,0) -oldInitUnits dflags = do - newFlags <- State.initUnits dflags - pure newFlags -#else -oldInitUnits dflags = do - newFlags <- fmap fst $ Packages.initPackages dflags - pure newFlags -#endif explicitUnits :: UnitState -> [Unit] explicitUnits ue = -#if MIN_VERSION_ghc(9,3,0) map fst $ State.explicitUnits ue -#elif MIN_VERSION_ghc(9,0,0) - State.explicitUnits ue -#else - Packages.explicitPackages ue -#endif listVisibleModuleNames :: HscEnv -> [ModuleName] listVisibleModuleNames env = -#if MIN_VERSION_ghc(9,0,0) State.listVisibleModuleNames $ unitState env -#else - Packages.listVisibleModuleNames $ hsc_dflags env -#endif getUnitName :: HscEnv -> UnitId -> Maybe PackageName getUnitName env i = -#if MIN_VERSION_ghc(9,0,0) State.unitPackageName <$> State.lookupUnitId (unitState env) i -#else - packageName <$> Packages.lookupPackage (hsc_dflags env) (definiteUnitId (defUnitId i)) -#endif lookupModuleWithSuggestions :: HscEnv -> ModuleName -#if MIN_VERSION_ghc(9,3,0) -> GHC.PkgQual -#else - -> Maybe FastString -#endif -> LookupResult lookupModuleWithSuggestions env modname mpkg = -#if MIN_VERSION_ghc(9,0,0) State.lookupModuleWithSuggestions (unitState env) modname mpkg -#else - Packages.lookupModuleWithSuggestions (hsc_dflags env) modname mpkg -#endif getUnitInfoMap :: HscEnv -> UnitInfoMap getUnitInfoMap = -#if MIN_VERSION_ghc(9,2,0) unitInfoMap . ue_units . hsc_unit_env -#elif MIN_VERSION_ghc(9,0,0) - unitInfoMap . unitState -#else - Packages.getPackageConfigMap . hsc_dflags -#endif lookupUnit :: HscEnv -> Unit -> Maybe UnitInfo -#if MIN_VERSION_ghc(9,0,0) lookupUnit env pid = State.lookupUnit (unitState env) pid -#else -lookupUnit env pid = Packages.lookupPackage (hsc_dflags env) pid -#endif -lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo -#if MIN_VERSION_ghc(9,0,0) -lookupUnit' = State.lookupUnit' -#else -lookupUnit' b pcm _ u = Packages.lookupPackage' b pcm u -#endif - preloadClosureUs :: HscEnv -> PreloadUnitClosure -#if MIN_VERSION_ghc(9,2,0) preloadClosureUs = State.preloadClosure . unitState -#elif MIN_VERSION_ghc(9,0,0) -preloadClosureUs = State.preloadClosure . unitState -#else -preloadClosureUs = const () -#endif -unitExposedModules :: UnitInfo -> [(ModuleName, Maybe Module)] -unitExposedModules ue = -#if MIN_VERSION_ghc(9,0,0) - UnitInfo.unitExposedModules ue -#else - Packages.exposedModules ue -#endif - -unitDepends :: UnitInfo -> [UnitId] -#if MIN_VERSION_ghc(9,0,0) -unitDepends = State.unitDepends -#else -unitDepends = fmap (Module.DefiniteUnitId. defUnitId') . Packages.depends -#endif - -unitPackageNameString :: UnitInfo -> String -unitPackageNameString = -#if MIN_VERSION_ghc(9,0,0) - UnitInfo.unitPackageNameString -#else - Packages.packageNameString -#endif - -unitPackageVersion :: UnitInfo -> Version -unitPackageVersion = -#if MIN_VERSION_ghc(9,0,0) - UnitInfo.unitPackageVersion -#else - Packages.packageVersion -#endif - -unitInfoId :: UnitInfo -> Unit -unitInfoId = -#if MIN_VERSION_ghc(9,0,0) - UnitInfo.mkUnit -#else - Packages.packageConfigId -#endif - unitHaddockInterfaces :: UnitInfo -> [FilePath] unitHaddockInterfaces = -#if MIN_VERSION_ghc(9,2,0) fmap ST.unpack . UnitInfo.unitHaddockInterfaces -#elif MIN_VERSION_ghc(9,0,0) - UnitInfo.unitHaddockInterfaces -#else - haddockInterfaces -#endif -- ------------------------------------------------------------------ -- Backwards Compatible UnitState @@ -329,7 +181,6 @@ -- Patterns and helpful definitions -- ------------------------------------------------------------------ -#if MIN_VERSION_ghc(9,2,0) definiteUnitId :: Definite uid -> GenUnit uid definiteUnitId = RealUnit defUnitId :: unit -> Definite unit @@ -337,72 +188,24 @@ installedModule :: unit -> ModuleName -> GenModule unit installedModule = Module -#elif MIN_VERSION_ghc(9,0,0) -definiteUnitId = RealUnit -defUnitId = Definite -installedModule = Module -#else -pattern RealUnit :: Module.DefUnitId -> UnitId -pattern RealUnit x = Module.DefiniteUnitId x - -definiteUnitId :: Module.DefUnitId -> UnitId -definiteUnitId = Module.DefiniteUnitId - -defUnitId :: UnitId -> Module.DefUnitId -defUnitId = Module.DefUnitId . Module.toInstalledUnitId - -defUnitId' :: Module.InstalledUnitId -> Module.DefUnitId -defUnitId' = Module.DefUnitId - -installedModule :: UnitId -> ModuleName -> Module.InstalledModule -installedModule uid modname = Module.InstalledModule (Module.toInstalledUnitId uid) modname -#endif - -toUnitId :: Unit -> UnitId -toUnitId = -#if MIN_VERSION_ghc(9,0,0) - Unit.toUnitId -#else - id -#endif - -moduleUnitId :: Module -> UnitId -moduleUnitId = -#if MIN_VERSION_ghc(9,0,0) - Unit.toUnitId . Unit.moduleUnit -#else - Module.moduleUnitId -#endif - -moduleUnit :: Module -> Unit -moduleUnit = -#if MIN_VERSION_ghc(9,0,0) - Unit.moduleUnit -#else - Module.moduleUnitId -#endif - filterInplaceUnits :: [UnitId] -> [PackageFlag] -> ([UnitId], [PackageFlag]) filterInplaceUnits us packageFlags = partitionEithers (map isInplace packageFlags) where isInplace :: PackageFlag -> Either UnitId PackageFlag isInplace p@(ExposePackage _ (UnitIdArg u) _) = -#if MIN_VERSION_ghc(9,0,0) if toUnitId u `elem` us then Left $ toUnitId u else Right p -#else - if u `elem` us - then Left u - else Right p -#endif isInplace p = Right p -showSDocForUser' :: HscEnv -> GHC.PrintUnqualified -> SDoc -> String -#if MIN_VERSION_ghc(9,2,0) +showSDocForUser' :: HscEnv -> PrintUnqualified -> SDoc -> String showSDocForUser' env = showSDocForUser (hsc_dflags env) (unitState env) -#else -showSDocForUser' env = showSDocForUser (hsc_dflags env) -#endif + +findImportedModule :: HscEnv -> ModuleName -> IO (Maybe Module) +findImportedModule env mn = do + res <- GHC.findImportedModule env mn NoPkgQual + case res of + Found _ mod -> pure . pure $ mod + _ -> pure Nothing diff --git a/src/Development/IDE/GHC/Compat/Util.hs b/src/Development/IDE/GHC/Compat/Util.hs --- a/src/Development/IDE/GHC/Compat/Util.hs +++ b/src/Development/IDE/GHC/Compat/Util.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} -- | GHC Utils and Datastructures re-exports. -- -- Mainly handles module hierarchy re-organisation of GHC @@ -24,9 +23,7 @@ LBooleanFormula, BooleanFormula(..), -- * OverridingBool -#if !MIN_VERSION_ghc(9,3,0) OverridingBool(..), -#endif -- * Maybes MaybeErr(..), orElse, @@ -34,13 +31,12 @@ Pair(..), -- * EnumSet EnumSet, + member, toList, -- * FastString exports FastString, -#if MIN_VERSION_ghc(9,2,0) -- Export here, so we can coerce safely on consumer sites LexicalFastString(..), -#endif uniq, unpackFS, mkFastString, @@ -71,12 +67,11 @@ atEnd, ) where -#if MIN_VERSION_ghc(9,0,0) import Control.Exception.Safe (MonadCatch, catch, try) import GHC.Data.Bag +import GHC.Data.Bool import GHC.Data.BooleanFormula import GHC.Data.EnumSet - import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.Pair @@ -84,33 +79,5 @@ import GHC.Types.Unique import GHC.Types.Unique.DFM import GHC.Utils.Fingerprint -import GHC.Utils.Misc import GHC.Utils.Outputable (pprHsString) import GHC.Utils.Panic hiding (try) -#else -import Bag -import BooleanFormula -import EnumSet -import qualified Exception -import FastString -import Fingerprint -import Maybes -import Outputable (pprHsString) -import Pair -import Panic hiding (try) -import StringBuffer -import UniqDFM -import Unique -import Util -#endif - -#if !MIN_VERSION_ghc(9,0,0) -type MonadCatch = Exception.ExceptionMonad - --- We are using Safe here, which is not equivalent, but probably what we want. -catch :: (Exception.ExceptionMonad m, Exception e) => m a -> (e -> m a) -> m a -catch = Exception.gcatch - -try :: (Exception.ExceptionMonad m, Exception e) => m a -> m (Either e a) -try = Exception.gtry -#endif diff --git a/src/Development/IDE/GHC/CoreFile.hs b/src/Development/IDE/GHC/CoreFile.hs --- a/src/Development/IDE/GHC/CoreFile.hs +++ b/src/Development/IDE/GHC/CoreFile.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} -- | CoreFiles let us serialize Core to a file in order to later recover it -- without reparsing or retypechecking @@ -10,89 +9,40 @@ , typecheckCoreFile , readBinCoreFile , writeBinCoreFile - , getImplicitBinds) where + , getImplicitBinds + ) where import Control.Monad -import Control.Monad.IO.Class -import Data.Foldable import Data.IORef -import Data.List (isPrefixOf) import Data.Maybe -import GHC.Fingerprint - import Development.IDE.GHC.Compat - -#if MIN_VERSION_ghc(9,0,0) +import qualified Development.IDE.GHC.Compat.Util as Util import GHC.Core import GHC.CoreToIface +import GHC.Fingerprint import GHC.Iface.Binary -import GHC.Iface.Env +#if MIN_VERSION_ghc(9,11,0) +import qualified GHC.Iface.Load as Iface +#endif import GHC.Iface.Recomp.Binary (fingerprintBinMem) import GHC.IfaceToCore import GHC.Types.Id.Make +import GHC.Types.TypeEnv import GHC.Utils.Binary +import Prelude hiding (mod) -#if MIN_VERSION_ghc(9,2,0) -import GHC.Types.TypeEnv -#else -import GHC.Driver.Types -#endif -#else -import Binary -import BinFingerprint (fingerprintBinMem) -import BinIface -import CoreSyn -import HscTypes -import IdInfo -import IfaceEnv -import MkId -import TcIface -import ToIface -import Unique -import Var -#endif - -import qualified Development.IDE.GHC.Compat.Util as Util - -- | Initial ram buffer to allocate for writing interface files initBinMemSize :: Int initBinMemSize = 1024 * 1024 data CoreFile = CoreFile - { cf_bindings :: [TopIfaceBinding IfaceId] + { cf_bindings :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -- ^ The actual core file bindings, deserialized lazily , cf_iface_hash :: !Fingerprint } --- | Like IfaceBinding, but lets us serialize internal names as well -data TopIfaceBinding v - = TopIfaceNonRec v IfaceExpr - | TopIfaceRec [(v, IfaceExpr)] - deriving (Functor, Foldable, Traversable) - --- | GHC doesn't export 'tcIdDetails', 'tcIfaceInfo', or 'tcIfaceType', --- but it does export 'tcIfaceDecl' --- so we use `IfaceDecl` as a container for all of these --- invariant: 'IfaceId' is always a 'IfaceId' constructor -type IfaceId = IfaceDecl - -instance Binary (TopIfaceBinding IfaceId) where - put_ bh (TopIfaceNonRec d e) = do - putByte bh 0 - put_ bh d - put_ bh e - put_ bh (TopIfaceRec vs) = do - putByte bh 1 - put_ bh vs - get bh = do - t <- getByte bh - case t of - 0 -> TopIfaceNonRec <$> get bh <*> get bh - 1 -> TopIfaceRec <$> get bh - _ -> error "Binary TopIfaceBinding" - instance Binary CoreFile where put_ bh (CoreFile core fp) = lazyPut bh core >> put_ bh fp get bh = CoreFile <$> lazyGet bh <*> get bh @@ -108,18 +58,20 @@ return (file, fp) -- | Write a core file -writeBinCoreFile :: FilePath -> CoreFile -> IO Fingerprint -writeBinCoreFile core_path fat_iface = do +writeBinCoreFile :: DynFlags -> FilePath -> CoreFile -> IO Fingerprint +writeBinCoreFile _dflags core_path fat_iface = do bh <- openBinMem initBinMemSize let quietTrace = -#if MIN_VERSION_ghc(9,2,0) QuietBinIFace -#else - (const $ pure ()) -#endif - putWithUserData quietTrace bh fat_iface + putWithUserData + quietTrace +#if MIN_VERSION_ghc(9,11,0) + (Iface.flagsToIfCompression _dflags) +#endif + bh + fat_iface -- And send the result to the file writeBinMem bh core_path @@ -134,16 +86,8 @@ :: Fingerprint -- ^ Hash of the interface this was generated from -> CgGuts -> CoreFile -codeGutsToCoreFile hash CgGuts{..} = CoreFile (map (toIfaceTopBind cg_module) $ filter isNotImplictBind cg_binds) hash - --- | Implicit binds can be generated from the interface and are not tidied, --- so we must filter them out -isNotImplictBind :: CoreBind -> Bool -isNotImplictBind bind = any (not . isImplicitId) $ bindBindings bind - -bindBindings :: CoreBind -> [Var] -bindBindings (NonRec b _) = [b] -bindBindings (Rec bnds) = map fst bnds +-- In GHC 9.6, implicit binds are tidied and part of core binds +codeGutsToCoreFile hash CgGuts{..} = CoreFile (map toIfaceTopBind cg_binds) hash getImplicitBinds :: TyCon -> [CoreBind] getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc @@ -161,70 +105,13 @@ | (op, val_index) <- classAllSelIds cls `zip` [0..] ] get_defn :: Id -> CoreBind -get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) - -toIfaceTopBndr :: Module -> Id -> IfaceId -toIfaceTopBndr mod id - = IfaceId (mangleDeclName mod $ getName id) - (toIfaceType (idType id)) - (toIfaceIdDetails (idDetails id)) - (toIfaceIdInfo (idInfo id)) - -toIfaceTopBind :: Module -> Bind Id -> TopIfaceBinding IfaceId -toIfaceTopBind mod (NonRec b r) = TopIfaceNonRec (toIfaceTopBndr mod b) (toIfaceExpr r) -toIfaceTopBind mod (Rec prs) = TopIfaceRec [(toIfaceTopBndr mod b, toIfaceExpr r) | (b,r) <- prs] +get_defn identifier = NonRec identifier templ + where + templ = case maybeUnfoldingTemplate (realIdUnfolding identifier) of + Nothing -> error "get_dfn: no unfolding template" + Just x -> x typecheckCoreFile :: Module -> IORef TypeEnv -> CoreFile -> IfG CoreProgram typecheckCoreFile this_mod type_var (CoreFile prepd_binding _) = initIfaceLcl this_mod (text "typecheckCoreFile") NotBoot $ do tcTopIfaceBindings type_var prepd_binding - --- | Internal names can't be serialized, so we mange them --- to an external name and restore at deserialization time --- This is necessary because we rely on stuffing TopIfaceBindings into --- a IfaceId because we don't have access to 'tcIfaceType' etc.. -mangleDeclName :: Module -> Name -> Name -mangleDeclName mod name - | isExternalName name = name - | otherwise = mkExternalName (nameUnique name) (mangleModule mod) (nameOccName name) (nameSrcSpan name) - --- | Mangle the module name too to avoid conflicts -mangleModule :: Module -> Module -mangleModule mod = mkModule (moduleUnit mod) (mkModuleName $ "GHCIDEINTERNAL" ++ moduleNameString (moduleName mod)) - -isGhcideModule :: Module -> Bool -isGhcideModule mod = "GHCIDEINTERNAL" `isPrefixOf` (moduleNameString $ moduleName mod) - --- Is this a fake external name that we need to make into an internal name? -isGhcideName :: Name -> Bool -isGhcideName = isGhcideModule . nameModule - -tcTopIfaceBindings :: IORef TypeEnv -> [TopIfaceBinding IfaceId] - -> IfL [CoreBind] -tcTopIfaceBindings ty_var ver_decls - = do - int <- mapM (traverse $ tcIfaceId) ver_decls - let all_ids = concatMap toList int - liftIO $ modifyIORef ty_var (flip extendTypeEnvList $ map AnId all_ids) - extendIfaceIdEnv all_ids $ mapM tc_iface_bindings int - -tcIfaceId :: IfaceId -> IfL Id -tcIfaceId = fmap getIfaceId . tcIfaceDecl False <=< unmangle_decl_name - where - unmangle_decl_name ifid@IfaceId{ ifName = name } - -- Check if the name is mangled - | isGhcideName name = do - name' <- newIfaceName (mkVarOcc $ getOccString name) - pure $ ifid{ ifName = name' } - | otherwise = pure ifid - -- invariant: 'IfaceId' is always a 'IfaceId' constructor - getIfaceId (AnId id) = id - getIfaceId _ = error "tcIfaceId: got non Id" - -tc_iface_bindings :: TopIfaceBinding Id -> IfL CoreBind -tc_iface_bindings (TopIfaceNonRec v e) = do - e' <- tcIfaceExpr e - pure $ NonRec v e' -tc_iface_bindings (TopIfaceRec vs) = do - vs' <- traverse (\(v, e) -> (,) <$> pure v <*> tcIfaceExpr e) vs - pure $ Rec vs' diff --git a/src/Development/IDE/GHC/Error.hs b/src/Development/IDE/GHC/Error.hs --- a/src/Development/IDE/GHC/Error.hs +++ b/src/Development/IDE/GHC/Error.hs @@ -1,11 +1,15 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DisambiguateRecordFields #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 module Development.IDE.GHC.Error ( -- * Producing Diagnostic values - diagFromErrMsgs + diagFromGhcErrorMessages + , diagFromErrMsgs , diagFromErrMsg + , diagFromSDocErrMsgs + , diagFromSDocErrMsg , diagFromString , diagFromStrings , diagFromGhcException @@ -17,6 +21,8 @@ , realSrcSpanToRange , realSrcLocToPosition , realSrcSpanToLocation + , realSrcSpanToCodePointRange + , realSrcLocToCodePointPosition , srcSpanToFilename , rangeToSrcSpan , rangeToRealSrcSpan @@ -31,10 +37,13 @@ , toDSeverity ) where +import Control.Lens import Data.Maybe import Data.String (fromString) import qualified Data.Text as T -import Development.IDE.GHC.Compat (DecoratedSDoc, MsgEnvelope, +import Data.Tuple.Extra (uncurry3) +import Development.IDE.GHC.Compat (GhcMessage, MsgEnvelope, + errMsgDiagnostic, errMsgSeverity, errMsgSpan, formatErrorWithQual, srcErrorMessages) @@ -44,31 +53,50 @@ import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import GHC -import Language.LSP.Types (isSubrangeOf) +import Language.LSP.Protocol.Types (isSubrangeOf) +import Language.LSP.VFS (CodePointPosition (CodePointPosition), + CodePointRange (CodePointRange)) -diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic -diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc,ShowDiag,) - Diagnostic - { _range = fromMaybe noRange $ srcSpanToRange loc - , _severity = Just sev - , _source = Just diagSource -- not shown in the IDE, but useful for ghcide developers - , _message = msg - , _code = Nothing - , _relatedInformation = Nothing - , _tags = Nothing - } +diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> Maybe (MsgEnvelope GhcMessage) -> FileDiagnostic +diagFromText diagSource sev loc msg origMsg = + D.ideErrorWithSource + (Just diagSource) (Just sev) + (toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename loc) + msg origMsg + & fdLspDiagnosticL %~ \diag -> diag { D._range = fromMaybe noRange $ srcSpanToRange loc } -- | Produce a GHC-style error from a source span and a message. -diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope DecoratedSDoc -> [FileDiagnostic] -diagFromErrMsg diagSource dflags e = - [ diagFromText diagSource sev (errMsgSpan e) - $ T.pack $ formatErrorWithQual dflags e - | Just sev <- [toDSeverity $ errMsgSeverity e]] +diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope GhcMessage -> [FileDiagnostic] +diagFromErrMsg diagSource dflags origErr = + let err = fmap (\e -> (Compat.renderDiagnosticMessageWithHints e, Just origErr)) origErr + in + diagFromSDocWithOptionalOrigMsg diagSource dflags err -diagFromErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic] +-- | Compatibility function for creating '[FileDiagnostic]' from +-- a 'Compat.Bag' of GHC error messages. +-- The function signature changes based on the GHC version. +-- While this is not desirable, it avoids more CPP statements in code +-- that implements actual logic. +diagFromGhcErrorMessages :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope GhcMessage) -> [FileDiagnostic] +diagFromGhcErrorMessages sourceParser dflags errs = + diagFromErrMsgs sourceParser dflags errs + +diagFromErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope GhcMessage) -> [FileDiagnostic] diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . Compat.bagToList +diagFromSDocErrMsg :: T.Text -> DynFlags -> MsgEnvelope Compat.DecoratedSDoc -> [FileDiagnostic] +diagFromSDocErrMsg diagSource dflags err = + diagFromSDocWithOptionalOrigMsg diagSource dflags (fmap (,Nothing) err) + +diagFromSDocErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope Compat.DecoratedSDoc) -> [FileDiagnostic] +diagFromSDocErrMsgs diagSource dflags = concatMap (diagFromSDocErrMsg diagSource dflags) . Compat.bagToList + +diagFromSDocWithOptionalOrigMsg :: T.Text -> DynFlags -> MsgEnvelope (Compat.DecoratedSDoc, Maybe (MsgEnvelope GhcMessage)) -> [FileDiagnostic] +diagFromSDocWithOptionalOrigMsg diagSource dflags err = + [ diagFromText diagSource sev (errMsgSpan err) (T.pack (formatErrorWithQual dflags (fmap fst err))) (snd (errMsgDiagnostic err)) + | Just sev <- [toDSeverity $ errMsgSeverity err]] + -- | Convert a GHC SrcSpan to a DAML compiler Range srcSpanToRange :: SrcSpan -> Maybe Range srcSpanToRange (UnhelpfulSpan _) = Nothing @@ -84,6 +112,29 @@ realSrcLocToPosition real = Position (fromIntegral $ srcLocLine real - 1) (fromIntegral $ srcLocCol real - 1) +-- Note [Unicode support] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- the current situation is: +-- LSP Positions use UTF-16 code units(Unicode may count as variable columns); +-- GHC use Unicode code points(Unicode count as one column). +-- To support unicode, ideally range should be in lsp standard, +-- and codePoint should be in ghc standard. +-- see https://github.com/haskell/lsp/pull/407 + +-- | Convert a GHC SrcSpan to CodePointRange +-- see Note [Unicode support] +realSrcSpanToCodePointRange :: RealSrcSpan -> CodePointRange +realSrcSpanToCodePointRange real = + CodePointRange + (realSrcLocToCodePointPosition $ Compat.realSrcSpanStart real) + (realSrcLocToCodePointPosition $ Compat.realSrcSpanEnd real) + +-- | Convert a GHC RealSrcLoc to CodePointPosition +-- see Note [Unicode support] +realSrcLocToCodePointPosition :: RealSrcLoc -> CodePointPosition +realSrcLocToCodePointPosition real = + CodePointPosition (fromIntegral $ srcLocLine real - 1) (fromIntegral $ srcLocCol real - 1) + -- | Extract a file name from a GHC SrcSpan (use message for unhelpful ones) -- FIXME This may not be an _absolute_ file name, needs fixing. srcSpanToFilename :: SrcSpan -> Maybe FilePath @@ -128,27 +179,19 @@ -- | Convert a GHC severity to a DAML compiler Severity. Severities below -- "Warning" level are dropped (returning Nothing). toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity -#if !MIN_VERSION_ghc(9,3,0) -toDSeverity SevOutput = Nothing -toDSeverity SevInteractive = Nothing -toDSeverity SevDump = Nothing -toDSeverity SevInfo = Just DsInfo -toDSeverity SevFatal = Just DsError -#else -toDSeverity SevIgnore = Nothing -#endif -toDSeverity SevWarning = Just DsWarning -toDSeverity SevError = Just DsError +toDSeverity SevIgnore = Nothing +toDSeverity SevWarning = Just DiagnosticSeverity_Warning +toDSeverity SevError = Just DiagnosticSeverity_Error -- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given -- (optional) locations and message strings. -diagFromStrings :: T.Text -> D.DiagnosticSeverity -> [(SrcSpan, String)] -> [FileDiagnostic] -diagFromStrings diagSource sev = concatMap (uncurry (diagFromString diagSource sev)) +diagFromStrings :: T.Text -> D.DiagnosticSeverity -> [(SrcSpan, String, Maybe (MsgEnvelope GhcMessage))] -> [FileDiagnostic] +diagFromStrings diagSource sev = concatMap (uncurry3 (diagFromString diagSource sev)) -- | Produce a GHC-style error from a source span and a message. -diagFromString :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> String -> [FileDiagnostic] -diagFromString diagSource sev sp x = [diagFromText diagSource sev sp $ T.pack x] +diagFromString :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> String -> Maybe (MsgEnvelope GhcMessage) -> [FileDiagnostic] +diagFromString diagSource sev sp x origMsg = [diagFromText diagSource sev sp (T.pack x) origMsg] -- | Produces an "unhelpful" source span with the given string. @@ -173,20 +216,16 @@ -- diagnostics catchSrcErrors :: DynFlags -> T.Text -> IO a -> IO (Either [FileDiagnostic] a) catchSrcErrors dflags fromWhere ghcM = do - Compat.handleGhcException (ghcExceptionToDiagnostics dflags) $ - handleSourceError (sourceErrorToDiagnostics dflags) $ + Compat.handleGhcException ghcExceptionToDiagnostics $ + handleSourceError sourceErrorToDiagnostics $ Right <$> ghcM where - ghcExceptionToDiagnostics dflags = return . Left . diagFromGhcException fromWhere dflags - sourceErrorToDiagnostics dflags = return . Left . diagFromErrMsgs fromWhere dflags -#if MIN_VERSION_ghc(9,3,0) - . fmap (fmap Compat.renderDiagnosticMessageWithHints) . Compat.getMessages -#endif - . srcErrorMessages - + ghcExceptionToDiagnostics = return . Left . diagFromGhcException fromWhere dflags + sourceErrorToDiagnostics diag = pure $ Left $ + diagFromErrMsgs fromWhere dflags (Compat.getMessages (srcErrorMessages diag)) diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic] -diagFromGhcException diagSource dflags exc = diagFromString diagSource DsError (noSpan "") (showGHCE dflags exc) +diagFromGhcException diagSource dflags exc = diagFromString diagSource DiagnosticSeverity_Error (noSpan "") (showGHCE dflags exc) Nothing showGHCE :: DynFlags -> GhcException -> String showGHCE dflags exc = case exc of diff --git a/src/Development/IDE/GHC/Orphans.hs b/src/Development/IDE/GHC/Orphans.hs --- a/src/Development/IDE/GHC/Orphans.hs +++ b/src/Development/IDE/GHC/Orphans.hs @@ -1,52 +1,45 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Orphan instances for GHC. -- Note that the 'NFData' instances may not be law abiding. module Development.IDE.GHC.Orphans() where - -#if MIN_VERSION_ghc(9,2,0) -import GHC.Parser.Annotation -#endif -#if MIN_VERSION_ghc(9,0,0) -import GHC.Data.Bag -import GHC.Data.FastString -import qualified GHC.Data.StringBuffer as SB -import GHC.Types.Name.Occurrence -import GHC.Types.SrcLoc -import GHC.Types.Unique (getKey) -import GHC.Unit.Info -import GHC.Utils.Outputable -#else -import Bag -import GhcPlugins -import qualified StringBuffer as SB -import Unique (getKey) -#endif - - import Development.IDE.GHC.Compat import Development.IDE.GHC.Util import Control.DeepSeq +import Control.Monad.Trans.Reader (ReaderT (..)) import Data.Aeson -import Data.Bifunctor (Bifunctor (..)) import Data.Hashable -import Data.String (IsString (fromString)) -import Data.Text (unpack) -#if MIN_VERSION_ghc(9,0,0) +import Data.String (IsString (fromString)) +import Data.Text (unpack) + +import Data.Bifunctor (Bifunctor (..)) import GHC.ByteCode.Types -#else -import ByteCodeTypes -#endif -#if MIN_VERSION_ghc(9,3,0) +import GHC.Data.Bag +import GHC.Data.FastString +import qualified GHC.Data.StringBuffer as SB +import GHC.Iface.Ext.Types +import GHC.Parser.Annotation import GHC.Types.PkgQual +import GHC.Types.SrcLoc +#if MIN_VERSION_ghc(9,13,0) +import GHC.Types.Basic (ImportLevel) #endif +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +import GHC.Unit.Home.ModInfo +import GHC.Unit.Module.Location (ModLocation (..)) +import GHC.Unit.Module.WholeCoreBindings + +-- Orphan instance for Shake.hs +-- https://hub.darcs.net/ross/transformers/issue/86 +deriving instance (Semigroup (m a)) => Semigroup (ReaderT r m a) + -- Orphan instances for types from the GHC API. instance Show CoreModule where show = unpack . printOutputable instance NFData CoreModule where rnf = rwhnf @@ -54,47 +47,58 @@ instance NFData CgGuts where rnf = rwhnf instance Show ModDetails where show = const "" instance NFData ModDetails where rnf = rwhnf +#if !MIN_VERSION_ghc(9,13,0) instance NFData SafeHaskellMode where rnf = rwhnf +#endif instance Show Linkable where show = unpack . printOutputable +#if MIN_VERSION_ghc(9,11,0) +instance NFData Linkable where rnf (Linkable a b c) = rnf a `seq` rnf b `seq` rnf c +instance NFData LinkableObjectSort where rnf = rwhnf +instance NFData LinkablePart where + rnf (DotO a b) = rnf a `seq` rnf b + rnf (DotA f) = rnf f + rnf (DotDLL f) = rnf f + rnf (BCOs a) = seqCompiledByteCode a + rnf (CoreBindings wcb) = rnf wcb + rnf (LazyBCOs a b) = seqCompiledByteCode a `seq` rnf b +#else instance NFData Linkable where rnf (LM a b c) = rnf a `seq` rnf b `seq` rnf c instance NFData Unlinked where - rnf (DotO f) = rnf f - rnf (DotA f) = rnf f - rnf (DotDLL f) = rnf f - rnf (BCOs a b) = seqCompiledByteCode a `seq` liftRnf rwhnf b -instance Show PackageFlag where show = unpack . printOutputable -instance Show InteractiveImport where show = unpack . printOutputable -instance Show PackageName where show = unpack . printOutputable + rnf (DotO f) = rnf f + rnf (DotA f) = rnf f + rnf (DotDLL f) = rnf f + rnf (BCOs a b) = seqCompiledByteCode a `seq` liftRnf rwhnf b + rnf (CoreBindings wcb) = rnf wcb + rnf (LoadedBCOs us) = rnf us +#endif -#if !MIN_VERSION_ghc(9,0,1) -instance Show ComponentId where show = unpack . printOutputable -instance Show SourcePackageId where show = unpack . printOutputable +instance NFData WholeCoreBindings where +#if MIN_VERSION_ghc(9,11,0) + rnf (WholeCoreBindings bs m ml f) = rnf bs `seq` rnf m `seq` rnf ml `seq` rnf f +#else + rnf (WholeCoreBindings bs m ml) = rnf bs `seq` rnf m `seq` rnf ml +#endif -instance Show GhcPlugins.InstalledUnitId where - show = installedUnitIdString +instance NFData ModLocation where +#if MIN_VERSION_ghc(9,11,0) + rnf (OsPathModLocation mf f1 f2 f3 f4 f5) = rnf mf `seq` rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 +#else + rnf (ModLocation mf f1 f2 f3 f4 f5) = rnf mf `seq` rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 +#endif -instance NFData GhcPlugins.InstalledUnitId where rnf = rwhnf . installedUnitIdFS +instance Show PackageFlag where show = unpack . printOutputable +instance Show InteractiveImport where show = unpack . printOutputable +instance Show PackageName where show = unpack . printOutputable -instance Hashable GhcPlugins.InstalledUnitId where - hashWithSalt salt = hashWithSalt salt . installedUnitIdString -#else instance Show UnitId where show = unpack . printOutputable deriving instance Ord SrcSpan deriving instance Ord UnhelpfulSpanReason -#endif instance NFData SB.StringBuffer where rnf = rwhnf instance Show Module where show = moduleNameString . moduleName -#if !MIN_VERSION_ghc(9,3,0) -instance Outputable a => Show (GenLocated SrcSpan a) where show = unpack . printOutputable -#endif - -instance (NFData l, NFData e) => NFData (GenLocated l e) where - rnf (L l e) = rnf l `seq` rnf e - instance Show ModSummary where show = show . ms_mod @@ -104,19 +108,22 @@ instance NFData ModSummary where rnf = rwhnf -#if MIN_VERSION_ghc(9,2,0) instance Ord FastString where compare a b = if a == b then EQ else compare (fs_sbs a) (fs_sbs b) + +#if MIN_VERSION_ghc(9,9,0) +instance NFData (EpAnn a) where + rnf = rwhnf +#else instance NFData (SrcSpanAnn' a) where rnf = rwhnf - -instance Bifunctor (GenLocated) where - bimap f g (L l x) = L (f l) (g x) - deriving instance Functor SrcSpanAnn' #endif +instance Bifunctor GenLocated where + bimap f g (L l x) = L (f l) (g x) + instance NFData ParsedModule where rnf = rwhnf @@ -126,17 +133,7 @@ instance NFData HieFile where rnf = rwhnf -#if !MIN_VERSION_ghc(9,3,0) -deriving instance Eq SourceModified -deriving instance Show SourceModified -instance NFData SourceModified where - rnf = rwhnf -#endif -#if !MIN_VERSION_ghc(9,2,0) -instance Show ModuleName where - show = moduleNameString -#endif instance Hashable ModuleName where hashWithSalt salt = hashWithSalt salt . show @@ -144,8 +141,10 @@ instance NFData a => NFData (IdentifierDetails a) where rnf (IdentifierDetails a b) = rnf a `seq` rnf (length b) +#if !MIN_VERSION_ghc(9,13,0) instance NFData RealSrcSpan where rnf = rwhnf +#endif srcSpanFileTag, srcSpanStartLineTag, srcSpanStartColTag, srcSpanEndLineTag, srcSpanEndColTag :: String @@ -184,9 +183,6 @@ instance Show a => Show (Bag a) where show = show . bagToList -instance NFData HsDocString where - rnf = rwhnf - instance Show ModGuts where show _ = "modguts" instance NFData ModGuts where @@ -195,30 +191,61 @@ instance NFData (ImportDecl GhcPs) where rnf = rwhnf -#if MIN_VERSION_ghc(9,0,1) -instance (NFData HsModule) where -#else instance (NFData (HsModule a)) where -#endif rnf = rwhnf instance Show OccName where show = unpack . printOutputable + + +#if MIN_VERSION_ghc(9,7,0) +instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getUnique $ occNameFS n, getKey $ getUnique $ occNameSpace n) +#else instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getUnique n) +#endif instance Show HomeModInfo where show = show . mi_module . hm_iface +instance Show ModuleGraph where show _ = "ModuleGraph {..}" +instance NFData ModuleGraph where rnf = rwhnf + instance NFData HomeModInfo where rnf (HomeModInfo iface dets link) = rwhnf iface `seq` rnf dets `seq` rnf link -#if MIN_VERSION_ghc(9,3,0) instance NFData PkgQual where rnf NoPkgQual = () rnf (ThisPkg uid) = rnf uid rnf (OtherPkg uid) = rnf uid +#if !MIN_VERSION_ghc(9,13,0) instance NFData UnitId where rnf = rwhnf +#endif instance NFData NodeKey where + rnf = rwhnf + +instance NFData HomeModLinkable where + rnf = rwhnf + +instance NFData (HsExpr (GhcPass Renamed)) where + rnf = rwhnf + +instance NFData (Pat (GhcPass Renamed)) where + rnf = rwhnf + +instance NFData (HsExpr (GhcPass Typechecked)) where + rnf = rwhnf + +instance NFData (Pat (GhcPass Typechecked)) where + rnf = rwhnf + +instance NFData Extension where + rnf = rwhnf + +instance NFData (UniqFM Name [Name]) where + rnf (ufmToIntMap -> m) = rnf m + +#if MIN_VERSION_ghc(9,13,0) +instance NFData ImportLevel where rnf = rwhnf #endif diff --git a/src/Development/IDE/GHC/Util.hs b/src/Development/IDE/GHC/Util.hs --- a/src/Development/IDE/GHC/Util.hs +++ b/src/Development/IDE/GHC/Util.hs @@ -27,28 +27,12 @@ dontWriteHieFiles, disableWarningsAsErrors, printOutputable, - getExtensions + printOutputableOneLine, + getExtensions, + getExtensionsSet, + stripOccNamePrefix, ) where -#if MIN_VERSION_ghc(9,2,0) -import GHC.Data.EnumSet -import GHC.Data.FastString -import GHC.Data.StringBuffer -import GHC.Driver.Env hiding (hscSetFlags) -import GHC.Driver.Monad -import GHC.Driver.Session hiding (ExposePackage) -import GHC.Parser.Lexer -import GHC.Runtime.Context -import GHC.Types.Name.Occurrence -import GHC.Types.Name.Reader -import GHC.Types.SrcLoc -import GHC.Unit.Module.ModDetails -import GHC.Unit.Module.ModGuts -import GHC.Utils.Fingerprint -import GHC.Utils.Outputable -#else -import Development.IDE.GHC.Compat.Util -#endif import Control.Concurrent import Control.Exception as E import Data.Binary.Put (Put, runPut) @@ -56,40 +40,36 @@ import Data.ByteString.Internal (ByteString (..)) import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Lazy as LBS -import Data.Data (Data) import Data.IORef import Data.List.Extra import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T -import Data.Time.Clock.POSIX (POSIXTime, getCurrentTime, - utcTimeToPOSIXSeconds) import Data.Typeable -import qualified Data.Unique as U -import Debug.Trace -import Development.IDE.GHC.Compat as GHC +import Development.IDE.GHC.Compat as GHC hiding (unitState) import qualified Development.IDE.GHC.Compat.Parser as Compat import qualified Development.IDE.GHC.Compat.Units as Compat import Development.IDE.Types.Location import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable -import GHC hiding (ParsedModule (..)) +import GHC hiding (ParsedModule (..), + parser) import GHC.IO.BufferedIO (BufferedIO) import GHC.IO.Device as IODevice import GHC.IO.Encoding import GHC.IO.Exception import GHC.IO.Handle.Internals import GHC.IO.Handle.Types -import GHC.Stack import Ide.PluginUtils (unescape) -import System.Environment.Blank (getEnvDefault) import System.FilePath -import System.IO.Unsafe -import Text.Printf - +import Data.Monoid (First (..)) +import GHC.Data.EnumSet +import GHC.Data.FastString +import GHC.Data.StringBuffer +import GHC.Utils.Fingerprint ---------------------------------------------------------------------- -- GHC setup @@ -189,9 +169,9 @@ -- Will produce an 8 byte unreadable ByteString. fingerprintToBS :: Fingerprint -> BS.ByteString fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do - ptr <- pure $ castPtr ptr - pokeElemOff ptr 0 a - pokeElemOff ptr 1 b + let ptr' = castPtr ptr + pokeElemOff ptr' 0 a + pokeElemOff ptr' 1 b -- | Take the 'Fingerprint' of a 'StringBuffer'. fingerprintFromStringBuffer :: StringBuffer -> IO Fingerprint @@ -256,11 +236,7 @@ -- | This is copied unmodified from GHC since it is not exposed. -- Note the beautiful inline comment! -#if MIN_VERSION_ghc(9,0,0) dupHandle_ :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev -#else -dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev -#endif -> FilePath -> Maybe (MVar Handle__) -> Handle__ @@ -283,7 +259,6 @@ -- Tracing exactprint terms -- | Print a GHC value in `defaultUserStyle` without unique symbols. --- It uses `showSDocUnsafe` with `unsafeGlobalDynFlags` internally. -- -- This is the most common print utility. -- It will do something additionally compared to what the 'Outputable' instance does. @@ -291,12 +266,72 @@ -- 1. print with a user-friendly style: `a_a4ME` as `a`. -- 2. unescape escape sequences of printable unicode characters within a pair of double quotes printOutputable :: Outputable a => a -> T.Text -printOutputable = +printOutputable = printOutputable' printWithoutUniques + +printOutputableOneLine :: Outputable a => a -> T.Text +printOutputableOneLine = printOutputable' printWithoutUniquesOneLine + +printOutputable' :: Outputable a => (a -> String) -> a -> T.Text +printOutputable' print = -- IfaceTyLit from GHC.Iface.Type implements Outputable with 'show'. -- Showing a String escapes non-ascii printable characters. We unescape it here. -- More discussion at https://github.com/haskell/haskell-language-server/issues/3115. - unescape . T.pack . printWithoutUniques + unescape . T.pack . print {-# INLINE printOutputable #-} getExtensions :: ParsedModule -> [Extension] -getExtensions = toList . extensionFlags . ms_hspp_opts . pm_mod_summary +getExtensions = toList . getExtensionsSet + +getExtensionsSet :: ParsedModule -> EnumSet Extension +getExtensionsSet = extensionFlags . ms_hspp_opts . pm_mod_summary + +-- | When e.g. DuplicateRecordFields is enabled, compiler generates +-- names like "$sel:accessor:One" and "$sel:accessor:Two" to +-- disambiguate record selectors +-- https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation +stripOccNamePrefix :: T.Text -> T.Text +stripOccNamePrefix name = T.takeWhile (/=':') $ fromMaybe name $ + getFirst $ foldMap (First . (`T.stripPrefix` name)) + occNamePrefixes + +-- | Prefixes that can occur in a GHC OccName +occNamePrefixes :: [T.Text] +occNamePrefixes = + [ + -- long ones + "$con2tag_" + , "$tag2con_" + , "$maxtag_" + + -- four chars + , "$sel:" + , "$tc'" + + -- three chars + , "$dm" + , "$co" + , "$tc" + , "$cp" + , "$fx" + + -- two chars + , "$W" + , "$w" + , "$m" + , "$b" + , "$c" + , "$d" + , "$i" + , "$s" + , "$f" + , "$r" + , "C:" + , "N:" + , "D:" + , "$p" + , "$L" + , "$f" + , "$t" + , "$c" + , "$m" + ] diff --git a/src/Development/IDE/GHC/Warnings.hs b/src/Development/IDE/GHC/Warnings.hs --- a/src/Development/IDE/GHC/Warnings.hs +++ b/src/Development/IDE/GHC/Warnings.hs @@ -6,15 +6,37 @@ module Development.IDE.GHC.Warnings(withWarnings) where import Control.Concurrent.Strict -import Data.List +import Control.Lens (over) import qualified Data.Text as T import Development.IDE.GHC.Compat import Development.IDE.GHC.Error import Development.IDE.Types.Diagnostics -import Language.LSP.Types (type (|?) (..)) +{- + Note [withWarnings and its dangers] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + withWarnings collects warnings by registering a custom logger which extracts + the SDocs of those warnings. If you receive warnings this way, you will not + get them in a structured form. In the medium term we'd like to remove all + uses of withWarnings to get structured messages everywhere we can. + For the time being, withWarnings is no longer used for anything in the main + typecheckModule codepath, but it is still used for bytecode/object code + generation, as well as a few other places. + + I suspect some of these functions (e.g. codegen) will need deeper changes to + be able to get diagnostics as a list, though I don't have great evidence for + that atm. I haven't taken a look to see if those functions that are wrapped + with this could produce diagnostics another way. + + It would be good for someone to take a look. What we've done so far gives us + diagnostics for renaming and typechecking, and doesn't require us to copy + too much code from GHC or make any deeper changes, and lets us get started + with the bulk of the useful plugin work, but it would be good to have all + diagnostics with structure be collected that way. +-} + -- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some -- parsed module 'pm@') and produce a "decorated" action that will -- harvest any warnings encountered executing the action. The 'phase' @@ -24,42 +46,16 @@ -- https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640 -- which basically says that log_action is taken from the ModSummary when GHC feels like it. -- The given argument lets you refresh a ModSummary log_action -#if MIN_VERSION_ghc(9,3,0) +-- +-- Also, See Note [withWarnings and its dangers] for some commentary on this function. withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(Maybe DiagnosticReason, FileDiagnostic)], a) -#else -withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a) -#endif withWarnings diagSource action = do warnings <- newVar [] let newAction :: DynFlags -> LogActionCompat newAction dynFlags logFlags wr _ loc prUnqual msg = do - let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags wr logFlags loc prUnqual msg + let wr_d = map ((wr,) . over fdLspDiagnosticL (attachReason wr)) $ diagFromSDocErrMsg diagSource dynFlags (mkWarnMsg dynFlags wr logFlags loc prUnqual msg) modifyVar_ warnings $ return . (wr_d:) newLogger env = pushLogHook (const (logActionCompat (newAction (hsc_dflags env)))) (hsc_logger env) res <- action $ \env -> putLogHook (newLogger env) env warns <- readVar warnings return (reverse $ concat warns, res) - where - third3 :: (c -> d) -> (a, b, c) -> (a, b, d) - third3 f (a, b, c) = (a, b, f c) - -#if MIN_VERSION_ghc(9,3,0) -attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic -attachReason Nothing d = d -attachReason (Just wr) d = d{_code = InR <$> showReason wr} - where - showReason = \case - WarningWithFlag flag -> showFlag flag - _ -> Nothing -#else -attachReason :: WarnReason -> Diagnostic -> Diagnostic -attachReason wr d = d{_code = InR <$> showReason wr} - where - showReason = \case - NoReason -> Nothing - Reason flag -> showFlag flag - ErrReason flag -> showFlag =<< flag -#endif - -showFlag :: WarningFlag -> Maybe T.Text -showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags diff --git a/src/Development/IDE/Import/DependencyInformation.hs b/src/Development/IDE/Import/DependencyInformation.hs --- a/src/Development/IDE/Import/DependencyInformation.hs +++ b/src/Development/IDE/Import/DependencyInformation.hs @@ -1,5 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} module Development.IDE.Import.DependencyInformation ( DependencyInformation(..) @@ -10,29 +11,32 @@ , TransitiveDependencies(..) , FilePathId(..) , NamedModuleDep(..) - , ShowableModuleName(..) - , PathIdMap + , ShowableModule(..) + , ShowableModuleEnv(..) + , PathIdMap (..) , emptyPathIdMap , getPathId , lookupPathToId , insertImport , pathToId , idToPath + , idToModLocation , reachableModules , processDependencyInformation , transitiveDeps , transitiveReverseDependencies , immediateReverseDependencies - + , lookupModuleFile , BootIdMap , insertBootId + , lookupFingerprint ) where import Control.DeepSeq import Data.Bifunctor import Data.Coerce import Data.Either -import Data.Graph +import Data.Graph hiding (edges, path) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HMS import Data.IntMap (IntMap) @@ -45,14 +49,16 @@ import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe import Data.Tuple.Extra hiding (first, second) +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util (Fingerprint) +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Orphans () -import GHC.Generics (Generic) - import Development.IDE.Import.FindImports (ArtifactsLocation (..)) import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location +import GHC.Generics (Generic) +import Prelude hiding (mod) -import GHC -- | The imports for a given module. newtype ModuleImports = ModuleImports @@ -90,21 +96,21 @@ case HMS.lookup (artifactFilePath path) pathToIdMap of Nothing -> let !newId = FilePathId nextFreshId - in (newId, insertPathId path newId m) - Just id -> (id, m) + in (newId, insertPathId newId ) + Just fileId -> (fileId, m) where - insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap - insertPathId path id PathIdMap{..} = + insertPathId :: FilePathId -> PathIdMap + insertPathId fileId = PathIdMap - (IntMap.insert (getFilePathId id) path idToPathMap) - (HMS.insert (artifactFilePath path) id pathToIdMap) + (IntMap.insert (getFilePathId fileId) path idToPathMap) + (HMS.insert (artifactFilePath path) fileId pathToIdMap) (succ nextFreshId) insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) } -pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId -pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path +pathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId +pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.!? path lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap @@ -113,7 +119,7 @@ idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation -idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id +idToModLocation PathIdMap{idToPathMap} (FilePathId i) = idToPathMap IntMap.! i type BootIdMap = FilePathIdMap FilePathId @@ -128,32 +134,54 @@ -- corresponding hs file. It is used when topologically sorting as we -- need to add edges between .hs-boot and .hs so that the .hs files -- appear later in the sort. - , rawBootMap :: !BootIdMap - , rawModuleNameMap :: !(FilePathIdMap ShowableModuleName) + , rawModuleMap :: !(FilePathIdMap ShowableModule) } deriving Show data DependencyInformation = DependencyInformation - { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError)) + { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError)) -- ^ Nodes that cannot be processed correctly. - , depModuleNames :: !(FilePathIdMap ShowableModuleName) - , depModuleDeps :: !(FilePathIdMap FilePathIdSet) + , depModules :: !(FilePathIdMap ShowableModule) + , depModuleDeps :: !(FilePathIdMap FilePathIdSet) -- ^ For a non-error node, this contains the set of module immediate dependencies -- in the same package. - , depReverseModuleDeps :: !(IntMap IntSet) + , depReverseModuleDeps :: !(IntMap IntSet) -- ^ Contains a reverse mapping from a module to all those that immediately depend on it. - , depPathIdMap :: !PathIdMap + , depPathIdMap :: !PathIdMap -- ^ Map from FilePath to FilePathId - , depBootMap :: !BootIdMap + , depBootMap :: !BootIdMap -- ^ Map from hs-boot file to the corresponding hs file + , depModuleFiles :: !(ShowableModuleEnv FilePathId) + -- ^ Map from Module to the corresponding non-boot hs file + , depModuleGraph :: !ModuleGraph + , depTransDepsFingerprints :: !(FilePathIdMap Fingerprint) + -- ^ Map from Module to fingerprint of the transitive dependencies of the module. + , depTransReverseDepsFingerprints :: !(FilePathIdMap Fingerprint) + -- ^ Map from FilePathId to the fingerprint of the transitive reverse dependencies of the module. + , depImmediateReverseDepsFingerprints :: !(FilePathIdMap Fingerprint) + -- ^ Map from FilePathId to the fingerprint of the immediate reverse dependencies of the module. } deriving (Show, Generic) -newtype ShowableModuleName = - ShowableModuleName {showableModuleName :: ModuleName} +lookupFingerprint :: NormalizedFilePath -> DependencyInformation -> FilePathIdMap Fingerprint -> Maybe Fingerprint +lookupFingerprint fileId DependencyInformation {..} depFingerprintMap = + do + FilePathId cur_id <- lookupPathToId depPathIdMap fileId + IntMap.lookup cur_id depFingerprintMap + +newtype ShowableModule = + ShowableModule {showableModule :: Module} deriving NFData -instance Show ShowableModuleName where show = moduleNameString . showableModuleName +newtype ShowableModuleEnv a = + ShowableModuleEnv {showableModuleEnv :: ModuleEnv a} +instance Show a => Show (ShowableModuleEnv a) where + show (ShowableModuleEnv x) = show (moduleEnvToList x) +instance NFData a => NFData (ShowableModuleEnv a) where + rnf = rwhnf + +instance Show ShowableModule where show = moduleNameString . moduleName . showableModule + reachableModules :: DependencyInformation -> [NormalizedFilePath] reachableModules DependencyInformation{..} = map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps @@ -215,15 +243,20 @@ SuccessNode _ <> ErrorNode errs = ErrorNode errs SuccessNode a <> SuccessNode _ = SuccessNode a -processDependencyInformation :: RawDependencyInformation -> DependencyInformation -processDependencyInformation RawDependencyInformation{..} = +processDependencyInformation :: RawDependencyInformation -> BootIdMap -> ModuleGraph -> FilePathIdMap Fingerprint -> DependencyInformation +processDependencyInformation RawDependencyInformation{..} rawBootMap mg shallowFingerMap = DependencyInformation { depErrorNodes = IntMap.fromList errorNodes , depModuleDeps = moduleDeps , depReverseModuleDeps = reverseModuleDeps - , depModuleNames = rawModuleNameMap + , depModules = rawModuleMap , depPathIdMap = rawPathIdMap , depBootMap = rawBootMap + , depModuleFiles = ShowableModuleEnv reverseModuleMap + , depModuleGraph = mg + , depTransDepsFingerprints = buildTransDepsFingerprintMap moduleDeps shallowFingerMap + , depTransReverseDepsFingerprints = buildTransDepsFingerprintMap reverseModuleDeps shallowFingerMap + , depImmediateReverseDepsFingerprints = buildImmediateDepsFingerprintMap reverseModuleDeps shallowFingerMap } where resultGraph = buildResultGraph rawImports (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph @@ -240,6 +273,7 @@ foldr (\(p, cs) res -> let new = IntMap.fromList (map (, IntSet.singleton (coerce p)) (coerce cs)) in IntMap.unionWith IntSet.union new res ) IntMap.empty successEdges + reverseModuleMap = mkModuleEnv $ map (\(i,sm) -> (showableModule sm, FilePathId i)) $ IntMap.toList rawModuleMap -- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows: @@ -258,9 +292,9 @@ errorsForCycle files = IntMap.fromListWith (<>) $ coerce $ concatMap (cycleErrorsForFile files) files cycleErrorsForFile :: [FilePathId] -> FilePathId -> [(FilePathId,NodeResult)] - cycleErrorsForFile cycle f = - let entryPoints = mapMaybe (findImport f) cycle - in map (\imp -> (f, ErrorNode (PartOfCycle imp cycle :| []))) entryPoints + cycleErrorsForFile cycles' f = + let entryPoints = mapMaybe (findImport f) cycles' + in map (\imp -> (f, ErrorNode (PartOfCycle imp cycles' :| []))) entryPoints otherErrors = IntMap.map otherErrorsForFile g otherErrorsForFile :: Either ModuleParseError ModuleImports -> NodeResult otherErrorsForFile (Left err) = ErrorNode (ParseError err :| []) @@ -328,7 +362,7 @@ -- | returns all transitive dependencies in topological order. transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies transitiveDeps DependencyInformation{..} file = do - let !fileId = pathToId depPathIdMap file + !fileId <- pathToId depPathIdMap file reachableVs <- -- Delete the starting node IntSet.delete (getFilePathId fileId) . @@ -351,6 +385,10 @@ vs = topSort g +lookupModuleFile :: Module -> DependencyInformation -> Maybe NormalizedFilePath +lookupModuleFile mod DependencyInformation{..} + = idToPath depPathIdMap <$> lookupModuleEnv (showableModuleEnv depModuleFiles) mod + newtype TransitiveDependencies = TransitiveDependencies { transitiveModuleDeps :: [NormalizedFilePath] -- ^ Transitive module dependencies in topological order. @@ -378,3 +416,44 @@ instance Show NamedModuleDep where show NamedModuleDep{..} = show nmdFilePath + + +buildImmediateDepsFingerprintMap :: FilePathIdMap FilePathIdSet -> FilePathIdMap Fingerprint -> FilePathIdMap Fingerprint +buildImmediateDepsFingerprintMap modulesDeps shallowFingers = + IntMap.fromList + $ map + ( \k -> + ( k, + Util.fingerprintFingerprints $ + map + (shallowFingers IntMap.!) + (k : IntSet.toList (IntMap.findWithDefault IntSet.empty k modulesDeps)) + ) + ) + $ IntMap.keys shallowFingers + +-- | Build a map from file path to its full fingerprint. +-- The fingerprint is depend on both the fingerprints of the file and all its dependencies. +-- This is used to determine if a file has changed and needs to be reloaded. +buildTransDepsFingerprintMap :: FilePathIdMap FilePathIdSet -> FilePathIdMap Fingerprint -> FilePathIdMap Fingerprint +buildTransDepsFingerprintMap modulesDeps shallowFingers = go keys IntMap.empty + where + keys = IntMap.keys shallowFingers + go :: [IntSet.Key] -> FilePathIdMap Fingerprint -> FilePathIdMap Fingerprint + go keys acc = + case keys of + [] -> acc + k : ks -> + if IntMap.member k acc + -- already in the map, so we can skip + then go ks acc + -- not in the map, so we need to add it + else + let -- get the dependencies of the current key + deps = IntSet.toList $ IntMap.findWithDefault IntSet.empty k modulesDeps + -- add fingerprints of the dependencies to the accumulator + depFingerprints = go deps acc + -- combine the fingerprints of the dependencies with the current key + combinedFingerprints = Util.fingerprintFingerprints $ shallowFingers IntMap.! k : map (depFingerprints IntMap.!) deps + in -- add the combined fingerprints to the accumulator + go ks (IntMap.insert k combinedFingerprints depFingerprints) diff --git a/src/Development/IDE/Import/FindImports.hs b/src/Development/IDE/Import/FindImports.hs --- a/src/Development/IDE/Import/FindImports.hs +++ b/src/Development/IDE/Import/FindImports.hs @@ -14,21 +14,23 @@ ) where import Control.DeepSeq +import Control.Monad.Extra +import Control.Monad.IO.Class +import Data.List (find, isSuffixOf) +import Data.Maybe +import qualified Data.Set as S import Development.IDE.GHC.Compat as Compat -import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error as ErrUtils import Development.IDE.GHC.Orphans () import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location - --- standard imports -import Control.Monad.Extra -import Control.Monad.IO.Class -import Data.List (isSuffixOf) -import Data.Maybe -import System.FilePath -#if MIN_VERSION_ghc(9,3,0) import GHC.Types.PkgQual +import GHC.Unit.State +import System.FilePath + + +#if MIN_VERSION_ghc(9,11,0) +import GHC.Driver.DynFlags #endif data Import @@ -54,28 +56,39 @@ rnf PackageImport = () modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation -modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source mod +modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source mbMod where isSource HsSrcFile = True isSource _ = False source = case ms of - Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp - Just ms -> isSource (ms_hsc_src ms) - mod = ms_mod <$> ms + Nothing -> "-boot" `isSuffixOf` fromNormalizedFilePath nfp + Just modSum -> isSource (ms_hsc_src modSum) + mbMod = ms_mod <$> ms +data LocateResult + = LocateNotFound + | LocateFoundReexport UnitId + | LocateFoundFile UnitId NormalizedFilePath + -- | locate a module in the file system. Where we go from *daml to Haskell locateModuleFile :: MonadIO m - => [(UnitId, [FilePath])] + => [(UnitId, [FilePath], S.Set ModuleName)] -> [String] -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -> Bool -> ModuleName - -> m (Maybe (UnitId, NormalizedFilePath)) + -> m LocateResult locateModuleFile import_dirss exts targetFor isSource modName = do let candidates import_dirs = [ toNormalizedFilePath' (prefix moduleNameSlashes modName <.> maybeBoot ext) | prefix <- import_dirs , ext <- exts] - firstJustM go (concat [map (uid,) (candidates dirs) | (uid, dirs) <- import_dirss]) + mf <- firstJustM go (concat [map (uid,) (candidates dirs) | (uid, dirs, _) <- import_dirss]) + case mf of + Nothing -> + case find (\(_ , _, reexports) -> S.member modName reexports) import_dirss of + Just (uid,_,_) -> pure $ LocateFoundReexport uid + Nothing -> pure LocateNotFound + Just (uid,file) -> pure $ LocateFoundFile uid file where go (uid, candidate) = fmap ((uid,) <$>) $ targetFor modName candidate maybeBoot ext @@ -86,12 +99,11 @@ -- It only returns Just for unit-ids which are possible to import into the -- current module. In particular, it will return Nothing for 'main' components -- as they can never be imported into another package. -#if MIN_VERSION_ghc(9,3,0) -mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (UnitId, [FilePath]) -mkImportDirs env (i, flags) = Just (i, importPaths flags) +mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (UnitId, ([FilePath], S.Set ModuleName)) +#if MIN_VERSION_ghc(9,11,0) +mkImportDirs _env (i, flags) = Just (i, (importPaths flags, S.fromList $ map reexportTo $ reexportedModules flags)) #else -mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, (UnitId, [FilePath])) -mkImportDirs env (i, flags) = (, (i, importPaths flags)) <$> getUnitName env i +mkImportDirs _env (i, flags) = Just (i, (importPaths flags, reexportedModules flags)) #endif -- | locate a module in either the file system or the package database. Where we go from *daml to @@ -103,73 +115,68 @@ -> [String] -- ^ File extensions -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -- ^ does file exist predicate -> Located ModuleName -- ^ Module name -#if MIN_VERSION_ghc(9,3,0) -> PkgQual -- ^ Package name -#else - -> Maybe FastString -- ^ Package name -#endif -> Bool -- ^ Is boot module -> m (Either [FileDiagnostic] Import) locateModule env comp_info exts targetFor modName mbPkgName isSource = do case mbPkgName of - -- "this" means that we should only look in the current package -#if MIN_VERSION_ghc(9,3,0) - ThisPkg _ -> do -#else - Just "this" -> do -#endif - lookupLocal (homeUnitId_ dflags) (importPaths dflags) + -- 'ThisPkg' just means some home module, not the current unit + ThisPkg uid + | Just (dirs, reexports) <- lookup uid import_paths + -> lookupLocal uid dirs reexports + | otherwise -> return $ Left $ notFoundErr env modName $ LookupNotFound [] -- if a package name is given we only go look for a package -#if MIN_VERSION_ghc(9,3,0) OtherPkg uid - | Just dirs <- lookup uid import_paths - -> lookupLocal uid dirs -#else - Just pkgName - | Just (uid, dirs) <- lookup (PackageName pkgName) import_paths - -> lookupLocal uid dirs -#endif - | otherwise -> lookupInPackageDB env -#if MIN_VERSION_ghc(9,3,0) + | Just (dirs, reexports) <- lookup uid import_paths + -> lookupLocal uid dirs reexports + | otherwise -> lookupInPackageDB NoPkgQual -> do -#else - Nothing -> do -#endif - -- first try to find the module as a file. If we can't find it try to find it in the package - -- database. - -- Here the importPaths for the current modules are added to the front of the import paths from the other components. - -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in - -- each component will end up being found in the wrong place and cause a multi-cradle match failure. - let import_paths' = -#if MIN_VERSION_ghc(9,3,0) - import_paths -#else - map snd import_paths -#endif - mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags) : import_paths') exts targetFor isSource $ unLoc modName + -- Reexports for current unit have to be empty because they only apply to other units depending on the + -- current unit. If we set the reexports to be the actual reexports then we risk looping forever trying + -- to find the module from the perspective of the current unit. + mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags, S.empty) : other_imports) exts targetFor isSource $ unLoc modName case mbFile of - Nothing -> lookupInPackageDB env - Just (uid, file) -> toModLocation uid file + LocateNotFound -> lookupInPackageDB + -- Lookup again with the perspective of the unit reexporting the file + LocateFoundReexport uid -> locateModule (hscSetActiveUnitId uid env) comp_info exts targetFor modName noPkgQual isSource + LocateFoundFile uid file -> toModLocation uid file where dflags = hsc_dflags env import_paths = mapMaybe (mkImportDirs env) comp_info - toModLocation uid file = liftIO $ do - loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) -#if MIN_VERSION_ghc(9,0,0) - let mod = mkModule (RealUnit $ Definite uid) (unLoc modName) -- TODO support backpack holes + other_imports = + -- Instead of bringing all the units into scope, only bring into scope the units + -- this one depends on. + -- This way if you have multiple units with the same module names, we won't get confused + -- For example if unit a imports module M from unit B, when there is also a module M in unit C, + -- and unit a only depends on unit b, without this logic there is the potential to get confused + -- about which module unit a imports. + -- Without multi-component support it is hard to recontruct the dependency environment so + -- unit a will have both unit b and unit c in scope. +#if MIN_VERSION_ghc(9,11,0) + map (\uid -> let this_df = homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue) in (uid, importPaths this_df, S.fromList $ map reexportTo $ reexportedModules this_df)) hpt_deps #else - let mod = mkModule uid (unLoc modName) + map (\uid -> let this_df = homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue) in (uid, importPaths this_df, reexportedModules this_df)) hpt_deps #endif - return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) (Just mod) + ue = hsc_unit_env env + units = homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId_ dflags) ue + hpt_deps :: [UnitId] + hpt_deps = homeUnitDepends units - lookupLocal uid dirs = do - mbFile <- locateModuleFile [(uid, dirs)] exts targetFor isSource $ unLoc modName + toModLocation uid file = liftIO $ do + loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) + let genMod = mkModule (RealUnit $ Definite uid) (unLoc modName) -- TODO support backpack holes + return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) (Just genMod) + + lookupLocal uid dirs reexports = do + mbFile <- locateModuleFile [(uid, dirs, reexports)] exts targetFor isSource $ unLoc modName case mbFile of - Nothing -> return $ Left $ notFoundErr env modName $ LookupNotFound [] - Just (uid, file) -> toModLocation uid file + LocateNotFound -> return $ Left $ notFoundErr env modName $ LookupNotFound [] + -- Lookup again with the perspective of the unit reexporting the file + LocateFoundReexport uid' -> locateModule (hscSetActiveUnitId uid' env) comp_info exts targetFor modName noPkgQual isSource + LocateFoundFile uid' file -> toModLocation uid' file - lookupInPackageDB env = do + lookupInPackageDB = do case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of LookupFound _m _pkgConfig -> return $ Right PackageImport reason -> return $ Left $ notFoundErr env modName reason @@ -180,7 +187,7 @@ mkError' $ ppr' $ cannotFindModule env modName0 $ lookupToFindResult reason where dfs = hsc_dflags env - mkError' = diagFromString "not found" DsError (Compat.getLoc modName) + mkError' doc = diagFromString "not found" DiagnosticSeverity_Error (Compat.getLoc modName) doc Nothing modName0 = unLoc modName ppr' = showSDoc dfs -- We convert the lookup result to a find result to reuse GHC's cannotFindModule pretty printer. @@ -196,7 +203,11 @@ } LookupUnusable unusable -> let unusables' = map get_unusable unusable +#if MIN_VERSION_ghc(9,6,4) && (!MIN_VERSION_ghc(9,8,1) || MIN_VERSION_ghc(9,8,2)) + get_unusable (_m, ModUnusable r) = r +#else get_unusable (m, ModUnusable r) = (moduleUnit m, r) +#endif get_unusable (_, r) = pprPanic "findLookupResult: unexpected origin" (ppr r) in notFound {fr_unusables = unusables'} @@ -212,3 +223,6 @@ , fr_unusables = [] , fr_suggestions = [] } + +noPkgQual :: PkgQual +noPkgQual = NoPkgQual diff --git a/src/Development/IDE/LSP/HoverDefinition.hs b/src/Development/IDE/LSP/HoverDefinition.hs --- a/src/Development/IDE/LSP/HoverDefinition.hs +++ b/src/Development/IDE/LSP/HoverDefinition.hs @@ -1,59 +1,75 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} -- | Display information on hover. module Development.IDE.LSP.HoverDefinition - ( + ( Log(..) -- * For haskell-language-server - hover + , hover + , foundHover , gotoDefinition , gotoTypeDefinition + , gotoImplementation , documentHighlight , references , wsSymbols ) where +import Control.Monad.Except (ExceptT) import Control.Monad.IO.Class +import Data.Maybe (fromMaybe) import Development.IDE.Core.Actions -import Development.IDE.Core.Rules -import Development.IDE.Core.Shake +import qualified Development.IDE.Core.Rules as Shake +import Development.IDE.Core.Shake (IdeAction, IdeState (..), + runIdeAction) import Development.IDE.Types.Location -import Development.IDE.Types.Logger -import qualified Language.LSP.Server as LSP -import Language.LSP.Types +import Ide.Logger +import Ide.Plugin.Error +import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import qualified Data.Text as T -gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentDefinition)) -hover :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Maybe Hover)) -gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentTypeDefinition)) -documentHighlight :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (List DocumentHighlight)) -gotoDefinition = request "Definition" getDefinition (InR $ InL $ List []) (InR . InL . List) -gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InL $ List []) (InR . InL . List) -hover = request "Hover" getAtPoint Nothing foundHover -documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List -references :: IdeState -> ReferenceParams -> LSP.LspM c (Either ResponseError (List Location)) -references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO $ - case uriToFilePath' uri of - Just path -> do - let filePath = toNormalizedFilePath' path - logDebug (ideLogger ide) $ - "References request at position " <> T.pack (showPosition pos) <> - " in file: " <> T.pack path - Right . List <$> (runAction "references" ide $ refsAtPoint filePath pos) - Nothing -> pure $ Left $ ResponseError InvalidParams ("Invalid URI " <> T.pack (show uri)) Nothing +data Log + = LogWorkspaceSymbolRequest !T.Text + | LogRequest !T.Text !Position !NormalizedFilePath + deriving (Show) -wsSymbols :: IdeState -> WorkspaceSymbolParams -> LSP.LspM c (Either ResponseError (List SymbolInformation)) -wsSymbols ide (WorkspaceSymbolParams _ _ query) = liftIO $ do - logDebug (ideLogger ide) $ "Workspace symbols request: " <> query - runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ Right . maybe (List []) List <$> workspaceSymbols query +instance Pretty Log where + pretty = \case + LogWorkspaceSymbolRequest query -> "Workspace symbols request:" <+> pretty query + LogRequest label pos nfp -> + pretty label <+> "request at position" <+> pretty (showPosition pos) <+> + "in file:" <+> pretty (fromNormalizedFilePath nfp) -foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover +gotoDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentDefinition) +hover :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (Hover |? Null) +gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentTypeDefinition) +gotoImplementation :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentImplementation) +documentHighlight :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) ([DocumentHighlight] |? Null) +gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition . InR . map fst) +gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition . InR . map fst) +gotoImplementation = request "Implementation" getImplementationDefinition (InR $ InR Null) (InL . Definition . InR) +hover = request "Hover" getAtPoint (InR Null) foundHover +documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL + +references :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentReferences +references recorder ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do + nfp <- getNormalizedFilePathE uri + liftIO $ logWith recorder Debug $ LogRequest "References" pos nfp + InL <$> (liftIO $ Shake.runAction "references" ide $ refsAtPoint nfp pos) + +wsSymbols :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_WorkspaceSymbol +wsSymbols recorder ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do + logWith recorder Debug $ LogWorkspaceSymbolRequest query + runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ InL . fromMaybe [] <$> workspaceSymbols query + +foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null foundHover (mbRange, contents) = - Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange + InL $ Hover (InL $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator contents) mbRange -- | Respond to and log a hover or go-to-definition request request @@ -61,19 +77,18 @@ -> (NormalizedFilePath -> Position -> IdeAction (Maybe a)) -> b -> (a -> b) + -> Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams - -> LSP.LspM c (Either ResponseError b) -request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do + -> ExceptT PluginError (HandlerM c) b +request label getResults notFound found recorder ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do mbResult <- case uriToFilePath' uri of - Just path -> logAndRunRequest label getResults ide pos path + Just path -> logAndRunRequest recorder label getResults ide pos path Nothing -> pure Nothing - pure $ Right $ maybe notFound found mbResult + pure $ maybe notFound found mbResult -logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b -logAndRunRequest label getResults ide pos path = do +logAndRunRequest :: Recorder (WithPriority Log) -> T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b +logAndRunRequest recorder label getResults ide pos path = do let filePath = toNormalizedFilePath' path - logDebug (ideLogger ide) $ - label <> " request at position " <> T.pack (showPosition pos) <> - " in file: " <> T.pack path + logWith recorder Debug $ LogRequest label pos filePath runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos) diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -1,18 +1,18 @@ - -- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StarIsType #-} - +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} -- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync -- This version removes the daml: handling module Development.IDE.LSP.LanguageServer ( runLanguageServer , setupLSP , Log(..) + , ThreadQueue + , runWithWorkerThreads + , Setup (..) + , ServerLifecycleContext (..) ) where import Control.Concurrent.STM @@ -26,8 +26,9 @@ import Development.IDE.LSP.Server import Development.IDE.Session (runWithDb) import Ide.Types (traceWithSpan) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP -import Language.LSP.Types import System.IO import UnliftIO.Async import UnliftIO.Concurrent @@ -35,18 +36,25 @@ import UnliftIO.Exception import qualified Colog.Core as Colog +import Control.Concurrent.Extra (newBarrier, + signalBarrier, + waitBarrier) import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Trans.Cont (ContT (..), evalContT) +import Data.Foldable (traverse_) import Development.IDE.Core.IdeConfiguration -import Development.IDE.Core.Shake hiding (Log, Priority) +import Development.IDE.Core.Service (shutdown) +import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing +import Development.IDE.Core.WorkerThread import qualified Development.IDE.Session as Session -import Development.IDE.Types.Logger -import qualified Development.IDE.Types.Logger as Logger -import Development.IDE.Types.Shake (WithHieDb) +import Development.IDE.Types.Shake (WithHieDb, + WithHieDbShield (..)) +import Ide.Logger import Language.LSP.Server (LanguageContextEnv, LspServerLog, type (<~>)) -import System.IO.Unsafe (unsafeInterleaveIO) +import System.Timeout (timeout) data Log = LogRegisteringIdeConfig !IdeConfiguration @@ -56,11 +64,30 @@ | LogCancelledRequest !SomeLspId | LogSession Session.Log | LogLspServer LspServerLog + | LogReactorShutdownRequested Bool + | LogShutDownTimeout Int + | LogServerExitWith (Either () Int) + | LogReactorShutdownConfirmed !T.Text deriving Show instance Pretty Log where pretty = \case + LogReactorShutdownRequested b -> + "Requested reactor shutdown; stop signal posted: " <+> pretty b + LogReactorShutdownConfirmed msg -> + "Reactor shutdown confirmed: " <+> pretty msg + LogServerExitWith (Right 0) -> + "Server exited successfully" + LogServerExitWith (Right code) -> + "Server exited with failure code" <+> pretty code + LogServerExitWith (Left ()) -> + "Server forcefully exited due to exception in reactor thread" + LogShutDownTimeout seconds -> + "Shutdown timeout, the server will exit now after waiting for" <+> pretty seconds <+> "seconds" LogRegisteringIdeConfig ideConfig -> + -- This log is also used to identify if HLS starts successfully in vscode-haskell, + -- don't forget to update the corresponding test in vscode-haskell if the text in + -- the next line has been modified. "Registering IDE configuration:" <+> viaShow ideConfig LogReactorThreadException e -> vcat @@ -74,12 +101,47 @@ "Reactor thread stopped" LogCancelledRequest requestId -> "Cancelled request" <+> viaShow requestId - LogSession log -> pretty log - LogLspServer log -> pretty log + LogSession msg -> pretty msg + LogLspServer msg -> pretty msg --- used to smuggle RankNType WithHieDb through dbMVar -newtype WithHieDbShield = WithHieDbShield WithHieDb +-- | Context of the LSP language server. +-- This record encapsulates all the configuration and callback functions +-- needed to set up and run the language server initialization process. +data ServerLifecycleContext config = ServerLifecycleContext + { ctxRecorder :: Recorder (WithPriority Log) + -- ^ Logger for recording server events and diagnostics + , ctxDefaultRoot :: FilePath + -- ^ Default root directory for the workspace, see Note [Root Directory] + , ctxGetHieDbLoc :: FilePath -> IO FilePath + -- ^ Function to determine the HIE database location for a given root path + , ctxGetIdeState :: LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState + -- ^ Function to create and initialize the IDE state with the given environment + , ctxUntilReactorStopSignal :: IO () -> IO () + -- ^ Lifetime control: MVar to signal reactor shutdown + , ctxConfirmReactorShutdown :: T.Text -> IO () + -- ^ Callback to log/confirm reactor shutdown with a reason + , ctxForceShutdown :: IO () + -- ^ Action to forcefully exit the server when exception occurs + , ctxClearReqId :: SomeLspId -> IO () + -- ^ Function to clear/cancel a request by its ID + , ctxWaitForCancel :: SomeLspId -> IO () + -- ^ Function to wait for a request cancellation by its ID + , ctxClientMsgChan :: Chan ReactorMessage + -- ^ Channel for communicating with the reactor message loop + } +data Setup config m a + = MkSetup + { doInitialize :: LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv config, a)) + -- ^ the callback invoked when the language server receives the 'Method_Initialize' request + , staticHandlers :: LSP.Handlers m + -- ^ the statically known handlers of the lsp server + , interpretHandler :: (LanguageContextEnv config, a) -> m <~> IO + -- ^ how to interpret @m@ to 'IO' and how to lift 'IO' into @m@ + , onExit :: [IO ()] + -- ^ a list of 'IO' actions that clean up resources and must be run when the server shuts down + } + runLanguageServer :: forall config a m. (Show config) => Recorder (WithPriority Log) @@ -88,60 +150,74 @@ -> Handle -- output -> config -> (config -> Value -> Either T.Text config) - -> (MVar () - -> IO (LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv config, a)), - LSP.Handlers (m config), - (LanguageContextEnv config, a) -> m config <~> IO)) + -> (config -> m ()) + -> (MVar () -> IO (Setup config m a)) -> IO () -runLanguageServer recorder options inH outH defaultConfig onConfigurationChange setup = do +runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigChange setup = do -- This MVar becomes full when the server thread exits or we receive exit message from client. -- LSP server will be canceled when it's full. clientMsgVar <- newEmptyMVar - (doInitialize, staticHandlers, interpretHandler) <- setup clientMsgVar + MkSetup + { doInitialize, staticHandlers, interpretHandler, onExit } <- setup clientMsgVar let serverDefinition = LSP.ServerDefinition - { LSP.onConfigurationChange = onConfigurationChange + { LSP.parseConfig = parseConfig + , LSP.onConfigChange = onConfigChange , LSP.defaultConfig = defaultConfig + -- TODO: magic string + , LSP.configSection = "haskell" , LSP.doInitialize = doInitialize - , LSP.staticHandlers = staticHandlers + , LSP.staticHandlers = const staticHandlers , LSP.interpretHandler = interpretHandler , LSP.options = modifyOptions options } - let lspCologAction :: MonadIO m2 => Colog.LogAction m2 (Colog.WithSeverity LspServerLog) - lspCologAction = toCologActionWithPrio $ cfilter - -- filter out bad logs in lsp, see: https://github.com/haskell/lsp/issues/447 - (\msg -> priority msg >= Info) - (cmapWithPrio LogLspServer recorder) + let lspCologAction :: forall io. MonadIO io => Colog.LogAction io (Colog.WithSeverity LspServerLog) + lspCologAction = toCologActionWithPrio (cmapWithPrio LogLspServer recorder) - void $ untilMVar clientMsgVar $ - void $ LSP.runServerWithHandles + let runServer = + LSP.runServerWithHandles lspCologAction lspCologAction inH outH serverDefinition + untilMVar' clientMsgVar runServer `finally` sequence_ onExit + >>= logWith recorder Info . LogServerExitWith + setupLSP :: - forall config err. + forall config. Recorder (WithPriority Log) + -> FilePath -- ^ root directory, see Note [Root Directory] -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> LSP.Handlers (ServerM config) - -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState) -> MVar () - -> IO (LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), - LSP.Handlers (ServerM config), - (LanguageContextEnv config, IdeState) -> ServerM config <~> IO) -setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do + -> IO (Setup config (ServerM config) IdeState) +setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar = do -- Send everything over a channel, since you need to wait until after initialise before -- LspFuncs is available clientMsgChan :: Chan ReactorMessage <- newChan -- An MVar to control the lifetime of the reactor loop. -- The loop will be stopped and resources freed when it's full - reactorLifetime <- newEmptyMVar - let stopReactorLoop = void $ tryPutMVar reactorLifetime () + reactorStopSignal <- newEmptyMVar + reactorConfirmBarrier <- newBarrier + let + untilReactorStopSignal = untilMVar reactorStopSignal + confirmReactorShutdown reason = do + logWith recorder Debug $ LogReactorShutdownConfirmed reason + signalBarrier reactorConfirmBarrier () + requestReactorShutdown = do + k <- tryPutMVar reactorStopSignal () + logWith recorder Info $ LogReactorShutdownRequested k + let timeOutSeconds = 2 + timeout (timeOutSeconds * 1_000_000) (waitBarrier reactorConfirmBarrier) >>= \case + Just () -> pure () + -- If we don't get confirmation within 2 seconds, we log a warning and shutdown anyway. + Nothing -> logWith recorder Warning $ LogShutDownTimeout timeOutSeconds -- Forcefully exit let exit = void $ tryPutMVar clientMsgVar () @@ -156,7 +232,7 @@ -- We want to avoid that the list of cancelled requests -- keeps growing if we receive cancellations for requests -- that do not exist or have already been processed. - when (reqId `elem` queued) $ + when (reqId `Set.member` queued) $ modifyTVar cancelledRequests (Set.insert reqId) let clearReqId reqId = atomically $ do modifyTVar pendingRequests (Set.delete reqId) @@ -167,120 +243,156 @@ cancelled <- readTVar cancelledRequests unless (reqId `Set.member` cancelled) retry - let asyncHandlers = mconcat + let staticHandlers = mconcat [ userHandlers , cancelHandler cancelRequest - , exitHandler exit - , shutdownHandler stopReactorLoop + , shutdownHandler recorder requestReactorShutdown ] -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. - let doInitialize = handleInit recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan + let lifecycleCtx = ServerLifecycleContext + { ctxRecorder = recorder + , ctxDefaultRoot = defaultRoot + , ctxGetHieDbLoc = getHieDbLoc + , ctxGetIdeState = getIdeState + , ctxUntilReactorStopSignal = untilReactorStopSignal + , ctxConfirmReactorShutdown = confirmReactorShutdown + , ctxForceShutdown = exit + , ctxClearReqId = clearReqId + , ctxWaitForCancel = waitForCancel + , ctxClientMsgChan = clientMsgChan + } + let doInitialize = handleInit lifecycleCtx + let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO + let onExit = [void $ tryPutMVar reactorStopSignal ()] - pure (doInitialize, asyncHandlers, interpretHandler) + pure MkSetup {doInitialize, staticHandlers, interpretHandler, onExit} handleInit - :: Recorder (WithPriority Log) - -> (FilePath -> IO FilePath) - -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) - -> MVar () - -> IO () - -> (SomeLspId -> IO ()) - -> (SomeLspId -> IO ()) - -> Chan ReactorMessage - -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) -handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do + :: ServerLifecycleContext config + -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) +handleInit lifecycleCtx env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params - let root = LSP.resRootPath env - dir <- maybe getCurrentDirectory return root - dbLoc <- getHieDbLoc dir - - -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference - -- to 'getIdeState', so we use this dirty trick - dbMVar <- newEmptyMVar - ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar - - ide <- getIdeState env root withHieDb hieChan - + -- only shift if lsp root is different from the rootDir + -- see Note [Root Directory] + let + recorder = ctxRecorder lifecycleCtx + defaultRoot = ctxDefaultRoot lifecycleCtx + untilReactorStopSignal = ctxUntilReactorStopSignal lifecycleCtx + lifetimeConfirm = ctxConfirmReactorShutdown lifecycleCtx + root <- case LSP.resRootPath env of + Just lspRoot | lspRoot /= defaultRoot -> setCurrentDirectory lspRoot >> return lspRoot + _ -> pure defaultRoot + dbLoc <- ctxGetHieDbLoc lifecycleCtx root let initConfig = parseConfiguration params - - log Info $ LogRegisteringIdeConfig initConfig - registerIdeConfiguration (shakeExtras ide) initConfig + logWith recorder Info $ LogRegisteringIdeConfig initConfig + ideMVar <- newEmptyMVar - let handleServerException (Left e) = do - log Error $ LogReactorThreadException e - exitClientMsg - handleServerException (Right _) = pure () + let + loggedTeardown me = do + -- shutdown shake + case me of + Left e -> do + lifetimeConfirm "due to exception in reactor thread" + logWith recorder Error $ LogReactorThreadException e + ctxForceShutdown lifecycleCtx + _ -> do + lifetimeConfirm "due to shutdown message" + return () - exceptionInHandler e = do - log Error $ LogReactorMessageActionException e + exceptionInHandler e = do + logWith recorder Error $ LogReactorMessageActionException e - checkCancelled _id act k = - flip finally (clearReqId _id) $ - catch (do - -- We could optimize this by first checking if the id - -- is in the cancelled set. However, this is unlikely to be a - -- bottleneck and the additional check might hide - -- issues with async exceptions that need to be fixed. - cancelOrRes <- race (waitForCancel _id) act - case cancelOrRes of - Left () -> do - log Debug $ LogCancelledRequest _id - k $ ResponseError RequestCancelled "" Nothing - Right res -> pure res - ) $ \(e :: SomeException) -> do + checkCancelled :: forall m . LspId m -> IO () -> (TResponseError m -> IO ()) -> IO () + checkCancelled _id act k = + let sid = SomeLspId _id + in flip finally (ctxClearReqId lifecycleCtx sid) $ + catch + (do + -- We could optimize this by first checking if the id + -- is in the cancelled set. However, this is unlikely to be a + -- bottleneck and the additional check might hide + -- issues with async exceptions that need to be fixed. + cancelOrRes <- race (ctxWaitForCancel lifecycleCtx sid) act + case cancelOrRes of + Left () -> do + logWith recorder Debug $ LogCancelledRequest sid + k $ TResponseError (InL LSPErrorCodes_RequestCancelled) "" Nothing + Right res -> pure res + ) + $ \(e :: SomeException) -> do exceptionInHandler e - k $ ResponseError InternalError (T.pack $ show e) Nothing - _ <- flip forkFinally handleServerException $ do - untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb hieChan -> do - putMVar dbMVar (WithHieDbShield withHieDb,hieChan) - forever $ do - msg <- readChan clientMsgChan - -- We dispatch notifications synchronously and requests asynchronously - -- This is to ensure that all file edits and config changes are applied before a request is handled - case msg of - ReactorNotification act -> handle exceptionInHandler act - ReactorRequest _id act k -> void $ async $ checkCancelled _id act k - log Info LogReactorThreadStopped + k $ TResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing + _ <- flip forkFinally loggedTeardown $ do + -- Need to be careful about when the shutdown occurs, it needs to be shut + -- down after the session loader and restarting threads, and before the + -- hiedb connections are closed. + let shutdownSession = tryReadMVar ideMVar >>= traverse_ shutdown + runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc shutdownSession $ \withHieDb' threadQueue' -> do + ide <- ctxGetIdeState lifecycleCtx env root withHieDb' threadQueue' + putMVar ideMVar ide + -- Keep this after putMVar ideMVar ide; otherwise shutdown during + -- initialization could leave handleInit blocked indefinitely on readMVar. + untilReactorStopSignal $ forever $ do + msg <- readChan $ ctxClientMsgChan lifecycleCtx + -- We dispatch notifications synchronously and requests asynchronously + -- This is to ensure that all file edits and config changes are applied before a request is handled + case msg of + ReactorNotification act -> handle exceptionInHandler act + ReactorRequest _id act k -> void $ async $ checkCancelled _id act k + logWith recorder Info LogReactorThreadStopped + + ide <- readMVar ideMVar + registerIdeConfiguration (shakeExtras ide) initConfig pure $ Right (env,ide) - where - log :: Logger.Priority -> Log -> IO () - log = logWith recorder +-- | runWithWorkerThreads +-- create several threads to run the session, db and session loader +-- see Note [Serializing runs in separate thread] +runWithWorkerThreads :: Recorder (WithPriority Session.Log) -> FilePath -> IO () -> (WithHieDb -> ThreadQueue -> IO ()) -> IO () +runWithWorkerThreads recorder dbLoc shutdownSession f = evalContT $ do + (WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc + -- The shake session needs to be shut down prior to the hiedb connections + -- being cleaned up, otherwise shake could be referencing dead connections. + -- This is passed in via the callsites. + ContT $ \action -> action () `finally` shutdownSession + sessionRestartTQueue <- withWorkerQueueSimple (cmapWithPrio Session.LogSessionWorkerThread recorder) "RestartTQueue" + sessionLoaderTQueue <- withWorkerQueueSimple (cmapWithPrio Session.LogSessionWorkerThread recorder) "SessionLoaderTQueue" + liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue) -- | Runs the action until it ends or until the given MVar is put. +-- It is important, that the thread that puts the 'MVar' is not dropped before it puts the 'MVar' i.e. it should +-- occur as the final action in a 'finally' or 'bracket', because otherwise this thread will finish early (as soon +-- as the thread receives the BlockedIndefinitelyOnMVar exception) -- Rethrows any exceptions. -untilMVar :: MonadUnliftIO m => MVar () -> m () -> m () -untilMVar mvar io = void $ - waitAnyCancel =<< traverse async [ io , readMVar mvar ] +untilMVar :: MonadUnliftIO m => MVar () -> m a -> m () +untilMVar mvar io = race_ (readMVar mvar) io -cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) -cancelHandler cancelRequest = LSP.notificationHandler SCancelRequest $ \NotificationMessage{_params=CancelParams{_id}} -> - liftIO $ cancelRequest (SomeLspId _id) +untilMVar' :: MonadUnliftIO m => MVar a -> m b -> m (Either a b) +untilMVar' mvar io = race (readMVar mvar) io -shutdownHandler :: IO () -> LSP.Handlers (ServerM c) -shutdownHandler stopReactor = LSP.requestHandler SShutdown $ \_ resp -> do - (_, ide) <- ask - liftIO $ logDebug (ideLogger ide) "Received shutdown message" - -- stop the reactor to free up the hiedb connection - liftIO stopReactor - -- flush out the Shake session to record a Shake profile if applicable - liftIO $ shakeShut ide - resp $ Right Empty +cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) +cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \TNotificationMessage{_params=CancelParams{_id}} -> + liftIO $ cancelRequest (SomeLspId (toLspId _id)) + where toLspId :: (Int32 |? T.Text) -> LspId a + toLspId (InL x) = IdInt x + toLspId (InR y) = IdString y -exitHandler :: IO () -> LSP.Handlers (ServerM c) -exitHandler exit = LSP.notificationHandler SExit $ const $ liftIO exit +shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM c) +shutdownHandler _recorder requestReactorShutdown = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do + -- stop the reactor to free up the hiedb connection and shut down shake + liftIO requestReactorShutdown + resp $ Right Null modifyOptions :: LSP.Options -> LSP.Options -modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS +modifyOptions x = x{ LSP.optTextDocumentSync = Just $ tweakTDS origTDS } where - tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ InR $ SaveOptions Nothing} - origTDS = fromMaybe tdsDefault $ LSP.textDocumentSync x + tweakTDS tds = tds{_openClose=Just True, _change=Just TextDocumentSyncKind_Incremental, _save=Just $ InR $ SaveOptions Nothing} + origTDS = fromMaybe tdsDefault $ LSP.optTextDocumentSync x tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing - diff --git a/src/Development/IDE/LSP/Notifications.hs b/src/Development/IDE/LSP/Notifications.hs --- a/src/Development/IDE/LSP/Notifications.hs +++ b/src/Development/IDE/LSP/Notifications.hs @@ -3,8 +3,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} module Development.IDE.LSP.Notifications ( whenUriFile @@ -13,8 +11,9 @@ , ghcideNotificationsPluginPriority ) where -import Language.LSP.Types -import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types +import qualified Language.LSP.Protocol.Types as LSP import Control.Concurrent.STM.Stats (atomically) import Control.Monad.Extra @@ -31,67 +30,77 @@ import qualified Development.IDE.Core.FileStore as FileStore import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.OfInterest hiding (Log, LogShake) -import Development.IDE.Core.RuleTypes (GetClientSettings (..)) import Development.IDE.Core.Service hiding (Log, LogShake) -import Development.IDE.Core.Shake hiding (Log, Priority) +import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Location -import Development.IDE.Types.Logger -import Development.IDE.Types.Shake (toKey) +import Ide.Logger import Ide.Types import Numeric.Natural data Log = LogShake Shake.Log | LogFileStore FileStore.Log + | LogOpenedTextDocument !Uri + | LogModifiedTextDocument !Uri + | LogSavedTextDocument !Uri + | LogClosedTextDocument !Uri + | LogWatchedFileEvents !Text.Text + | LogWarnNoWatchedFilesSupport deriving Show instance Pretty Log where pretty = \case - LogShake log -> pretty log - LogFileStore log -> pretty log + LogShake msg -> pretty msg + LogFileStore msg -> pretty msg + LogOpenedTextDocument uri -> "Opened text document:" <+> pretty (getUri uri) + LogModifiedTextDocument uri -> "Modified text document:" <+> pretty (getUri uri) + LogSavedTextDocument uri -> "Saved text document:" <+> pretty (getUri uri) + LogClosedTextDocument uri -> "Closed text document:" <+> pretty (getUri uri) + LogWatchedFileEvents msg -> "Watched file events:" <+> pretty msg + LogWarnNoWatchedFilesSupport -> "Client does not support watched files. Falling back to OS polling" whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = mconcat - [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ +descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificationHandlers = mconcat + [ mkPluginNotificationHandler LSP.SMethod_TextDocumentDidOpen $ \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do - atomically $ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List []) + atomically $ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri _version) [] whenUriFile _uri $ \file -> do -- We don't know if the file actually exists, or if the contents match those on disk -- For example, vscode restores previously unsaved contents on open - addFileOfInterest ide file Modified{firstOpen=True} - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file - logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $ + addFileOfInterest ide file Modified{firstOpen=True} + logWith recorder Debug $ LogOpenedTextDocument _uri - , mkPluginNotificationHandler LSP.STextDocumentDidChange $ + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ \ide vfs _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do atomically $ updatePositionMapping ide identifier changes whenUriFile _uri $ \file -> do - addFileOfInterest ide file Modified{firstOpen=False} - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file - logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $ + addFileOfInterest ide file Modified{firstOpen=False} + logWith recorder Debug $ LogModifiedTextDocument _uri - , mkPluginNotificationHandler LSP.STextDocumentDidSave $ + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do - addFileOfInterest ide file OnDisk - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file - logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file $ + addFileOfInterest ide file OnDisk + logWith recorder Debug $ LogSavedTextDocument _uri - , mkPluginNotificationHandler LSP.STextDocumentDidClose $ + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do - deleteFileOfInterest ide file let msg = "Closed text document: " <> getUri _uri - scheduleGarbageCollection ide - setSomethingModified (VFSModified vfs) ide [] $ Text.unpack msg - logDebug (ideLogger ide) msg + setSomethingModified (VFSModified vfs) ide (Text.unpack msg) $ do + scheduleGarbageCollection ide + deleteFileOfInterest ide file + logWith recorder Debug $ LogClosedTextDocument _uri - , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWatchedFiles $ - \ide vfs _ (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do + , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWatchedFiles $ + \ide vfs _ (DidChangeWatchedFilesParams fileEvents) -> liftIO $ do -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and -- what we do with them -- filter out files of interest, since we already know all about those @@ -105,12 +114,13 @@ ] unless (null fileEvents') $ do let msg = show fileEvents' - logDebug (ideLogger ide) $ "Watched file events: " <> Text.pack msg - modifyFileExists ide fileEvents' - resetFileStore ide fileEvents' - setSomethingModified (VFSModified vfs) ide [] msg + logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg) + setSomethingModified (VFSModified vfs) ide msg $ do + ks1 <- resetFileStore ide fileEvents' + ks2 <- modifyFileExists ide fileEvents' + return (ks1 <> ks2) - , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $ + , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWorkspaceFolders $ \ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do let add = S.union substract = flip S.difference @@ -118,14 +128,11 @@ $ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events)) . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events)) - , mkPluginNotificationHandler LSP.SWorkspaceDidChangeConfiguration $ - \ide vfs _ (DidChangeConfigurationParams cfg) -> liftIO $ do - let msg = Text.pack $ show cfg - logDebug (ideLogger ide) $ "Configuration changed: " <> msg - modifyClientSettings ide (const $ Just cfg) - setSomethingModified (VFSModified vfs) ide [toKey GetClientSettings emptyFilePath] "config change" + -- Nothing additional to do here beyond what `lsp` does for us, but this prevents + -- complaints about there being no handler defined + , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration mempty - , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ _ -> do + , mkPluginNotificationHandler LSP.SMethod_Initialized $ \ide _ _ _ -> do --------- Initialize Shake session -------------------------------------------------------------------- liftIO $ shakeSessionInit (cmapWithPrio LogShake recorder) ide @@ -139,13 +146,15 @@ let globs = watchedGlobs opts success <- registerFileWatches globs unless success $ - liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling" + liftIO $ logWith recorder Warning LogWarnNoWatchedFilesSupport ], -- The ghcide descriptors should come last'ish so that the notification handlers -- (which restart the Shake build) run after everything else pluginPriority = ghcideNotificationsPluginPriority } + where + desc = "Handles basic notifications for ghcide" ghcideNotificationsPluginPriority :: Natural ghcideNotificationsPluginPriority = defaultPluginPriority - 900 diff --git a/src/Development/IDE/LSP/Outline.hs b/src/Development/IDE/LSP/Outline.hs --- a/src/Development/IDE/LSP/Outline.hs +++ b/src/Development/IDE/LSP/Outline.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} module Development.IDE.LSP.Outline ( moduleOutline @@ -10,37 +9,36 @@ where import Control.Monad.IO.Class +import Data.Foldable (toList) import Data.Functor import Data.Generics hiding (Prefix) +import Data.List.NonEmpty (nonEmpty) import Data.Maybe -import qualified Data.Text as T import Development.IDE.Core.Rules import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (rangeToRealSrcSpan, realSrcSpanToRange) -import Development.IDE.Types.Location import Development.IDE.GHC.Util (printOutputable) -import Language.LSP.Server (LspM) -import Language.LSP.Types (DocumentSymbol (..), +import Development.IDE.Types.Location +import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types (DocumentSymbol (..), DocumentSymbolParams (DocumentSymbolParams, _textDocument), - List (..), ResponseError, - SymbolInformation, - SymbolKind (SkConstructor, SkField, SkFile, SkFunction, SkInterface, SkMethod, SkModule, SkObject, SkStruct, SkTypeParameter, SkUnknown), + SymbolKind (..), TextDocumentIdentifier (TextDocumentIdentifier), - type (|?) (InL), uriToFilePath) -#if MIN_VERSION_ghc(9,2,0) -import Data.List.NonEmpty (nonEmpty, toList) -#endif + type (|?) (InL, InR), + uriToFilePath) + moduleOutline - :: IdeState -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation)) -moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } + :: PluginMethodHandler IdeState Method_TextDocumentDocumentSymbol +moduleOutline ideState _ DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } = liftIO $ case uriToFilePath uri of Just (toNormalizedFilePath' -> fp) -> do mb_decls <- fmap fst <$> runAction "Outline" ideState (useWithStale GetParsedModule fp) - pure $ Right $ case mb_decls of - Nothing -> InL (List []) + pure $ case mb_decls of + Nothing -> InL [] Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } } -> let declSymbols = mapMaybe documentSymbolForDecl hsmodDecls @@ -48,7 +46,7 @@ (L (locA -> (RealSrcSpan l _)) m) -> Just $ (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable m - , _kind = SkFile + , _kind = SymbolKind_File , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0 } _ -> Nothing @@ -58,14 +56,14 @@ allSymbols = case moduleSymbol of Nothing -> importSymbols <> declSymbols Just x -> - [ x { _children = Just (List (importSymbols <> declSymbols)) + [ x { _children = Just (importSymbols <> declSymbols) } ] in - InL (List allSymbols) + InR (InL allSymbols) - Nothing -> pure $ Right $ InL (List []) + Nothing -> pure $ InL [] documentSymbolForDecl :: LHsDecl GhcPs -> Maybe DocumentSymbol documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) @@ -76,7 +74,7 @@ t -> " " <> t ) , _detail = Just $ printOutputable fdInfo - , _kind = SkFunction + , _kind = SymbolKind_Function } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) = Just (defDocumentSymbol l :: DocumentSymbol) @@ -85,129 +83,83 @@ "" -> "" t -> " " <> t ) - , _kind = SkInterface + , _kind = SymbolKind_Interface , _detail = Just "class" , _children = - Just $ List - [ (defDocumentSymbol l :: DocumentSymbol) + Just $ + [ (defDocumentSymbol l' :: DocumentSymbol) { _name = printOutputable n - , _kind = SkMethod - , _selectionRange = realSrcSpanToRange l' + , _kind = SymbolKind_Method + , _selectionRange = realSrcSpanToRange l'' } - | L (locA -> (RealSrcSpan l _)) (ClassOpSig _ False names _) <- tcdSigs - , L (locA -> (RealSrcSpan l' _)) n <- names + | L (locA -> (RealSrcSpan l' _)) (ClassOpSig _ False names _) <- tcdSigs + , L (locA -> (RealSrcSpan l'' _)) n <- names ] } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable name - , _kind = SkStruct + , _kind = SymbolKind_Struct , _children = - Just $ List - [ (defDocumentSymbol l :: DocumentSymbol) + Just $ + [ (defDocumentSymbol l'' :: DocumentSymbol) { _name = printOutputable n - , _kind = SkConstructor + , _kind = SymbolKind_Constructor , _selectionRange = realSrcSpanToRange l' -#if MIN_VERSION_ghc(9,2,0) - , _children = List . toList <$> nonEmpty childs + , _children = toList <$> nonEmpty childs } - | con <- dd_cons + | con <- extract_cons dd_cons , let (cs, flds) = hsConDeclsBinders con , let childs = mapMaybe cvtFld flds , L (locA -> RealSrcSpan l' _) n <- cs - , let l = case con of - L (locA -> RealSrcSpan l _) _ -> l - _ -> l' + , let l'' = case con of + L (locA -> RealSrcSpan l''' _) _ -> l''' + _ -> l' ] } where cvtFld :: LFieldOcc GhcPs -> Maybe DocumentSymbol -#if MIN_VERSION_ghc(9,3,0) - cvtFld (L (locA -> RealSrcSpan l _) n) = Just $ (defDocumentSymbol l :: DocumentSymbol) -#else - cvtFld (L (RealSrcSpan l _) n) = Just $ (defDocumentSymbol l :: DocumentSymbol) -#endif -#if MIN_VERSION_ghc(9,3,0) + cvtFld (L (locA -> RealSrcSpan l' _) n) = Just $ (defDocumentSymbol l' :: DocumentSymbol) { _name = printOutputable (unLoc (foLabel n)) -#else - { _name = printOutputable (unLoc (rdrNameFieldOcc n)) -#endif - , _kind = SkField + , _kind = SymbolKind_Field } cvtFld _ = Nothing -#else - , _children = conArgRecordFields (con_args x) - } - | L (locA -> (RealSrcSpan l _ )) x <- dd_cons - , L (locA -> (RealSrcSpan l' _)) n <- getConNames' x - ] - } - where - -- | Extract the record fields of a constructor - conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List - [ (defDocumentSymbol l :: DocumentSymbol) - { _name = printOutputable n - , _kind = SkField - } - | L _ cdf <- lcdfs - , L (locA -> (RealSrcSpan l _)) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf - ] - conArgRecordFields _ = Nothing -#endif documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ SynDecl { tcdLName = L (locA -> (RealSrcSpan l' _)) n })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable n - , _kind = SkTypeParameter + , _kind = SymbolKind_TypeParameter , _selectionRange = realSrcSpanToRange l' } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable cid_poly_ty - , _kind = SkInterface + , _kind = SymbolKind_Interface } -#if MIN_VERSION_ghc(9,2,0) documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl FamEqn { feqn_tycon, feqn_pats } })) -#else -documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) -#endif = Just (defDocumentSymbol l :: DocumentSymbol) { _name = -#if MIN_VERSION_ghc(9,3,0) - printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats) -#else - printOutputable (unLoc feqn_tycon) <> " " <> T.unwords - (map printOutputable feqn_pats) -#endif - , _kind = SkInterface + printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix feqn_pats + , _kind = SymbolKind_Interface } -#if MIN_VERSION_ghc(9,2,0) documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl _ FamEqn { feqn_tycon, feqn_pats } })) -#else -documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) -#endif = Just (defDocumentSymbol l :: DocumentSymbol) { _name = -#if MIN_VERSION_ghc(9,3,0) - printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats) -#else - printOutputable (unLoc feqn_tycon) <> " " <> T.unwords - (map printOutputable feqn_pats) -#endif - , _kind = SkInterface + printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix feqn_pats + , _kind = SymbolKind_Interface } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (DerivD _ DerivDecl { deriv_type })) = gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) -> (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable @(HsType GhcPs) name - , _kind = SkInterface + , _kind = SymbolKind_Interface } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ FunBind{fun_id = L _ name})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable name - , _kind = SkFunction + , _kind = SymbolKind_Function } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ PatBind{pat_lhs})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable pat_lhs - , _kind = SkFunction + , _kind = SymbolKind_Function } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ForD _ x)) = Just @@ -215,12 +167,10 @@ { _name = case x of ForeignImport{} -> name ForeignExport{} -> name - XForeignDecl{} -> "?" - , _kind = SkObject + , _kind = SymbolKind_Object , _detail = case x of ForeignImport{} -> Just "import" ForeignExport{} -> Just "export" - XForeignDecl{} -> Nothing } where name = printOutputable $ unLoc $ fd_name x @@ -239,15 +189,15 @@ in Just (defDocumentSymbol (rangeToRealSrcSpan "" importRange)) { _name = "imports" - , _kind = SkModule - , _children = Just (List importSymbols) + , _kind = SymbolKind_Module + , _children = Just importSymbols } documentSymbolForImport :: LImportDecl GhcPs -> Maybe DocumentSymbol documentSymbolForImport (L (locA -> (RealSrcSpan l _)) ImportDecl { ideclName, ideclQualified }) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = "import " <> printOutputable ideclName - , _kind = SkModule + , _kind = SymbolKind_Module , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" } } documentSymbolForImport _ = Nothing @@ -257,23 +207,15 @@ _detail = Nothing _deprecated = Nothing _name = "" - _kind = SkUnknown 0 + -- This used to be SkUnknown 0, which is invalid, as SymbolKinds start at 1, + -- therefore, I am replacing it with SymbolKind_File, which is the type for 1 + _kind = SymbolKind_File _range = realSrcSpanToRange l _selectionRange = realSrcSpanToRange l _children = Nothing _tags = Nothing -- the version of getConNames for ghc9 is restricted to only the renaming phase -#if !MIN_VERSION_ghc(9,2,0) -getConNames' :: ConDecl GhcPs -> [Located (IdP GhcPs)] -getConNames' ConDeclH98 {con_name = name} = [name] -getConNames' ConDeclGADT {con_names = names} = names -#if !MIN_VERSION_ghc(8,10,0) -getConNames' (XConDecl NoExt) = [] -#elif !MIN_VERSION_ghc(9,0,0) -getConNames' (XConDecl x) = noExtCon x -#endif -#else hsConDeclsBinders :: LConDecl GhcPs -> ([LIdP GhcPs], [LFieldOcc GhcPs]) -- See hsLTyClDeclBinders for what this does @@ -291,7 +233,7 @@ -- remove only the first occurrence of any seen field in order to -- avoid circumventing detection of duplicate fields (#9156) ConDeclGADT { con_names = names, con_g_args = args } - -> (names, flds) + -> (toList names, flds) where flds = get_flds_gadt args @@ -303,18 +245,25 @@ get_flds_h98 :: HsConDeclH98Details GhcPs -> [LFieldOcc GhcPs] get_flds_h98 (RecCon flds) = get_flds (reLoc flds) - get_flds_h98 _ = [] + get_flds_h98 _ = [] get_flds_gadt :: HsConDeclGADTDetails GhcPs - -> ([LFieldOcc GhcPs]) -#if MIN_VERSION_ghc(9,3,0) - get_flds_gadt (RecConGADT flds _) = get_flds (reLoc flds) + -> [LFieldOcc GhcPs] +#if MIN_VERSION_ghc(9,9,0) + get_flds_gadt (RecConGADT _ flds) = get_flds (reLoc flds) #else - get_flds_gadt (RecConGADT flds) = get_flds (reLoc flds) + get_flds_gadt (RecConGADT flds _) = get_flds (reLoc flds) #endif - get_flds_gadt _ = [] + get_flds_gadt _ = [] +#if MIN_VERSION_ghc(9,13,0) + get_flds :: Located [LHsConDeclRecField GhcPs] + -> [LFieldOcc GhcPs] + get_flds flds = concatMap (cdrf_names . unLoc) (unLoc flds) +#else get_flds :: Located [LConDeclField GhcPs] - -> ([LFieldOcc GhcPs]) + -> [LFieldOcc GhcPs] get_flds flds = concatMap (cd_fld_names . unLoc) (unLoc flds) #endif + + diff --git a/src/Development/IDE/LSP/Server.hs b/src/Development/IDE/LSP/Server.hs --- a/src/Development/IDE/LSP/Server.hs +++ b/src/Development/IDE/LSP/Server.hs @@ -1,12 +1,7 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} module Development.IDE.LSP.Server ( ReactorMessage(..) , ReactorChan @@ -14,46 +9,46 @@ , requestHandler , notificationHandler ) where - -import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Reader import Development.IDE.Core.Shake import Development.IDE.Core.Tracing -import Ide.Types (HasTracing, traceWithSpan) -import Language.LSP.Server (Handlers, LspM) -import qualified Language.LSP.Server as LSP -import Language.LSP.Types +import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Server (Handlers, LspM) +import qualified Language.LSP.Server as LSP import Language.LSP.VFS import UnliftIO.Chan data ReactorMessage = ReactorNotification (IO ()) - | ReactorRequest SomeLspId (IO ()) (ResponseError -> IO ()) + | forall m . ReactorRequest (LspId m) (IO ()) (TResponseError m -> IO ()) type ReactorChan = Chan ReactorMessage newtype ServerM c a = ServerM { unServerM :: ReaderT (ReactorChan, IdeState) (LspM c) a } deriving (Functor, Applicative, Monad, MonadReader (ReactorChan, IdeState), MonadIO, MonadUnliftIO, LSP.MonadLsp c) requestHandler - :: forall (m :: Method FromClient Request) c. (HasTracing (MessageParams m)) => + :: forall m c. PluginMethod Request m => SMethod m - -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (ResponseResult m))) + -> (IdeState -> MessageParams m -> LspM c (Either (TResponseError m) (MessageResult m))) -> Handlers (ServerM c) -requestHandler m k = LSP.requestHandler m $ \RequestMessage{_method,_id,_params} resp -> do +requestHandler m k = LSP.requestHandler m $ \TRequestMessage{_method,_id,_params} resp -> do st@(chan,ide) <- ask env <- LSP.getLspEnv - let resp' = flip (runReaderT . unServerM) st . resp + let resp' :: Either (TResponseError m) (MessageResult m) -> LspM c () + resp' = flip (runReaderT . unServerM) st . resp trace x = otTracedHandler "Request" (show _method) $ \sp -> do traceWithSpan sp _params x - writeChan chan $ ReactorRequest (SomeLspId _id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left) + writeChan chan $ ReactorRequest _id (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left) notificationHandler - :: forall (m :: Method FromClient Notification) c. (HasTracing (MessageParams m)) => + :: forall m c. PluginMethod Notification m => SMethod m -> (IdeState -> VFS -> MessageParams m -> LspM c ()) -> Handlers (ServerM c) -notificationHandler m k = LSP.notificationHandler m $ \NotificationMessage{_params,_method}-> do +notificationHandler m k = LSP.notificationHandler m $ \TNotificationMessage{_params,_method}-> do (chan,ide) <- ask env <- LSP.getLspEnv -- Take a snapshot of the VFS state on every notification diff --git a/src/Development/IDE/Main.hs b/src/Development/IDE/Main.hs --- a/src/Development/IDE/Main.hs +++ b/src/Development/IDE/Main.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -Wno-orphans #-} -{-# LANGUAGE RankNTypes #-} module Development.IDE.Main (Arguments(..) ,defaultArguments @@ -12,16 +10,18 @@ ,testing ,Log(..) ) where + import Control.Concurrent.Extra (withNumCapabilities) +import Control.Concurrent.MVar (MVar, newEmptyMVar, + putMVar, tryReadMVar) import Control.Concurrent.STM.Stats (dumpSTMStats) -import Control.Exception.Safe (SomeException, - catchAny, - displayException) +import Control.Exception.Safe as Safe import Control.Monad.Extra (concatMapM, unless, when) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as J import Data.Coerce (coerce) import Data.Default (Default (def)) -import Data.Foldable (traverse_) import Data.Hashable (hashed) import qualified Data.HashMap.Strict as HashMap import Data.List.Extra (intercalate, @@ -30,14 +30,14 @@ import Data.Maybe (catMaybes, isJust) import qualified Data.Text as T import Development.IDE (Action, - GhcVersion (..), - Priority (Debug, Error), - Rules, ghcVersion, - hDuplicateTo') + Priority (Debug), + Rules, hDuplicateTo') import Development.IDE.Core.Debouncer (Debouncer, newAsyncDebouncer) -import Development.IDE.Core.FileStore (isWatchSupported) +import Development.IDE.Core.FileStore (isWatchSupported, + setSomethingModified) import Development.IDE.Core.IdeConfiguration (IdeConfiguration (..), + modifyClientSettings, registerIdeConfiguration) import Development.IDE.Core.OfInterest (FileOfInterestStatus (OnDisk), kick, @@ -51,17 +51,17 @@ runAction) import qualified Development.IDE.Core.Service as Service import Development.IDE.Core.Shake (IdeState (shakeExtras), - IndexQueue, + ThreadQueue (tLoaderQueue), shakeSessionInit, uses) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph (action) import Development.IDE.LSP.LanguageServer (runLanguageServer, + runWithWorkerThreads, setupLSP) import qualified Development.IDE.LSP.LanguageServer as LanguageServer import Development.IDE.Main.HeapStats (withHeapStats) import qualified Development.IDE.Main.HeapStats as HeapStats -import qualified Development.IDE.Monitoring.EKG as EKG import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules)) import Development.IDE.Plugin.HLS (asGhcIdePlugin) @@ -70,21 +70,12 @@ import qualified Development.IDE.Plugin.Test as Test import Development.IDE.Session (SessionLoadingOptions, getHieDbLoc, + getInitialGhcLibDirDefault, loadSessionWithOptions, - retryOnSqliteBusy, - runWithDb, - setInitialDynFlags) + retryOnSqliteBusy) import qualified Development.IDE.Session as Session import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath') -import Development.IDE.Types.Logger (Logger, - Pretty (pretty), - Priority (Info, Warning), - Recorder, - WithPriority, - cmapWithPrio, - logWith, nest, vsep, - (<+>)) import Development.IDE.Types.Monitoring (Monitoring) import Development.IDE.Types.Options (IdeGhcSession, IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset), @@ -93,12 +84,20 @@ defaultIdeOptions, optModifyDynFlags, optTesting) -import Development.IDE.Types.Shake (WithHieDb) +import Development.IDE.Types.Shake (WithHieDb, + toNoFileKey) import GHC.Conc (getNumProcessors) import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Handle (hDuplicate) import HIE.Bios.Cradle (findCradle) import qualified HieDb.Run as HieDb +import Ide.Logger (Pretty (pretty), + Priority (Info), + Recorder, + WithPriority, + cmapWithPrio, + logWith, nest, vsep, + (<+>)) import Ide.Plugin.Config (CheckParents (NeverCheck), Config, checkParents, checkProject, @@ -116,16 +115,17 @@ import Numeric.Natural (Natural) import Options.Applicative hiding (action) import qualified System.Directory.Extra as IO -import System.Exit (ExitCode (ExitFailure), +import System.Exit (ExitCode (ExitFailure, ExitSuccess), exitWith) import System.FilePath (takeExtension, - takeFileName) + takeFileName, ()) import System.IO (BufferMode (LineBuffering, NoBuffering), Handle, hFlush, hPutStrLn, hSetBuffering, hSetEncoding, stderr, stdin, stdout, utf8) +import System.Process (readProcessWithExitCode) import System.Random (newStdGen) import System.Time.Extra (Seconds, offsetTime, showDuration) @@ -135,8 +135,7 @@ | LogLspStart [PluginId] | LogLspStartDuration !Seconds | LogShouldRunSubset !Bool - | LogOnlyPartialGhc94Support - | LogSetInitialDynFlagsException !SomeException + | LogConfigurationChange T.Text | LogService Service.Log | LogShake Shake.Log | LogGhcIde GhcIde.Log @@ -144,11 +143,12 @@ | LogSession Session.Log | LogPluginHLS PluginHLS.Log | LogRules Rules.Log + | LogUsingGit deriving Show instance Pretty Log where pretty = \case - LogHeapStats log -> pretty log + LogHeapStats msg -> pretty msg LogLspStart pluginIds -> nest 2 $ vsep [ "Starting LSP server..." @@ -159,17 +159,15 @@ "Started LSP server in" <+> pretty (showDuration duration) LogShouldRunSubset shouldRunSubset -> "shouldRunSubset:" <+> pretty shouldRunSubset - LogOnlyPartialGhc94Support -> - "Currently, HLS supports GHC 9.4 only partially. See [issue #3190](https://github.com/haskell/haskell-language-server/issues/3190) for more detail." - LogSetInitialDynFlagsException e -> - "setInitialDynFlags:" <+> pretty (displayException e) - LogService log -> pretty log - LogShake log -> pretty log - LogGhcIde log -> pretty log - LogLanguageServer log -> pretty log - LogSession log -> pretty log - LogPluginHLS log -> pretty log - LogRules log -> pretty log + LogConfigurationChange msg -> "Configuration changed:" <+> pretty msg + LogService msg -> pretty msg + LogShake msg -> pretty msg + LogGhcIde msg -> pretty msg + LogLanguageServer msg -> pretty msg + LogSession msg -> pretty msg + LogPluginHLS msg -> pretty msg + LogRules msg -> pretty msg + LogUsingGit -> "Using git to list file, relying on .gitignore" data Command = Check [FilePath] -- ^ Typecheck some paths and print diagnostics. Exit code is the number of failures @@ -207,9 +205,8 @@ data Arguments = Arguments - { argsProjectRoot :: Maybe FilePath + { argsProjectRoot :: FilePath , argCommand :: Command - , argsLogger :: IO Logger , argsRules :: Rules () , argsHlsPlugins :: IdePlugins IdeState , argsGhcidePlugin :: Plugin Config -- ^ Deprecated @@ -223,14 +220,14 @@ , argsHandleOut :: IO Handle , argsThreads :: Maybe Natural , argsMonitoring :: IO Monitoring + , argsDisableKick :: Bool -- ^ flag to disable kick used for testing } -defaultArguments :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> Arguments -defaultArguments recorder logger plugins = Arguments - { argsProjectRoot = Nothing +defaultArguments :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments +defaultArguments recorder projectRoot plugins = Arguments + { argsProjectRoot = projectRoot -- ^ see Note [Root Directory] , argCommand = LSP - , argsLogger = pure logger - , argsRules = mainRule (cmapWithPrio LogRules recorder) def >> action kick + , argsRules = mainRule (cmapWithPrio LogRules recorder) def , argsGhcidePlugin = mempty , argsHlsPlugins = pluginDescToIdePlugins (GhcIde.descriptors (cmapWithPrio LogGhcIde recorder)) <> plugins , argsSessionLoadingOptions = def @@ -238,7 +235,15 @@ { optCheckProject = pure $ checkProject config , optCheckParents = pure $ checkParents config } - , argsLspOptions = def {LSP.completionTriggerCharacters = Just "."} + , argsLspOptions = def + { LSP.optCompletionTriggerCharacters = Just "." + -- Generally people start to notice that something is taking a while at about 1s, so + -- that's when we start reporting progress + , LSP.optProgressStartDelay = 1_000_000 + -- Once progress is being reported, it's nice to see that it's moving reasonably quickly, + -- but not so fast that it's ugly. This number is a bit made up + , LSP.optProgressUpdateDelay = 1_00_000 + } , argsDefaultHlsConfig = def , argsGetHieDbLoc = getHieDbLoc , argsDebouncer = newAsyncDebouncer @@ -258,15 +263,16 @@ -- the language server tests without the redirection. putStr " " >> hFlush stdout return newStdout - , argsMonitoring = OpenTelemetry.monitoring <> EKG.monitoring logger 8999 + , argsMonitoring = OpenTelemetry.monitoring + , argsDisableKick = False } -testing :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> Arguments -testing recorder logger plugins = +testing :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments +testing recorder projectRoot plugins = let - arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = - defaultArguments recorder logger plugins + arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } = + defaultArguments recorder projectRoot plugins hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc argsHlsPlugins ++ [Test.blockCommandDescriptor "block-command", Test.plugin] @@ -275,30 +281,34 @@ defOptions = argsIdeOptions config sessionLoader in defOptions{ optTesting = IdeTesting True } + lspOptions = argsLspOptions { LSP.optProgressStartDelay = 0, LSP.optProgressUpdateDelay = 0 } in arguments { argsHlsPlugins = hlsPlugins , argsIdeOptions = ideOptions + , argsLspOptions = lspOptions } defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO () defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats recorder) fun where - log :: Priority -> Log -> IO () - log = logWith recorder - fun = do setLocaleEncoding utf8 pid <- T.pack . show <$> getProcessID - logger <- argsLogger hSetBuffering stderr LineBuffering let hlsPlugin = asGhcIdePlugin (cmapWithPrio LogPluginHLS recorder) argsHlsPlugins hlsCommands = allLspCmdIds' pid argsHlsPlugins plugins = hlsPlugin <> argsGhcidePlugin - options = argsLspOptions { LSP.executeCommandCommands = LSP.executeCommandCommands argsLspOptions <> Just hlsCommands } - argsOnConfigChange = getConfigFromNotification argsHlsPlugins - rules = argsRules >> pluginRules plugins + options = argsLspOptions { LSP.optExecuteCommandCommands = LSP.optExecuteCommandCommands argsLspOptions <> Just hlsCommands } + argsParseConfig = getConfigFromNotification argsHlsPlugins + rules = do + argsRules + unless argsDisableKick $ action kick + pluginRules plugins + -- install the main and ghcide-plugin rules + -- install the kick action, which triggers a typecheck on every + -- Shake database restart, i.e. on every user edit. debouncer <- argsDebouncer inH <- argsHandleIn @@ -309,63 +319,66 @@ case argCommand of LSP -> withNumCapabilities numCapabilities $ do - t <- offsetTime - log Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) - - let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState - getIdeState env rootPath withHieDb hieChan = do - traverse_ IO.setCurrentDirectory rootPath - t <- t - log Info $ LogLspStartDuration t - - dir <- maybe IO.getCurrentDirectory return rootPath - - -- We want to set the global DynFlags right now, so that we can use - -- `unsafeGlobalDynFlags` even before the project is configured - _mlibdir <- - setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions - -- TODO: should probably catch/log/rethrow at top level instead - `catchAny` (\e -> log Error (LogSetInitialDynFlagsException e) >> pure Nothing) + ioT <- offsetTime + logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) - sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir + let getIdeState :: MVar IdeState -> LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> Shake.ThreadQueue -> IO IdeState + getIdeState ideStateVar env rootPath withHieDb threadQueue = do + t <- ioT + logWith recorder Info $ LogLspStartDuration t + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath (tLoaderQueue threadQueue) config <- LSP.runLspT env LSP.getConfig let def_options = argsIdeOptions config sessionLoader -- disable runSubset if the client doesn't support watched files runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported - log Debug $ LogShouldRunSubset runSubset + logWith recorder Debug $ LogShouldRunSubset runSubset - let options = def_options + let ideOptions = def_options { optReportProgress = clientSupportsProgress caps , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins , optRunSubset = runSubset } caps = LSP.resClientCapabilities env - -- FIXME: Remove this after GHC 9.4 gets fully supported - when (ghcVersion == GHC94) $ - log Warning LogOnlyPartialGhc94Support monitoring <- argsMonitoring - initialise + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules (Just env) - logger debouncer - options + ideOptions withHieDb - hieChan + threadQueue monitoring + rootPath + putMVar ideStateVar ide + pure ide - let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState + let setup ideStateVar = setupLSP (cmapWithPrio LogLanguageServer recorder) argsProjectRoot argsGetHieDbLoc (pluginHandlers plugins) (getIdeState ideStateVar) + -- See Note [Client configuration in Rules] + onConfigChange ideStateVar cfg = do + -- TODO: this is nuts, we're converting back to JSON just to get a fingerprint + let cfgObj = J.toJSON cfg + mide <- liftIO $ tryReadMVar ideStateVar + case mide of + Nothing -> pure () + Just ide -> liftIO $ do + let msg = T.pack $ show cfg + setSomethingModified Shake.VFSUnmodified ide "config change" $ do + logWith recorder Debug $ LogConfigurationChange msg + modifyClientSettings ide (const $ Just cfgObj) + return [toNoFileKey Rules.GetClientSettings] - runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsOnConfigChange setup + do + ideStateVar <- newEmptyMVar + runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig (onConfigChange ideStateVar) (setup ideStateVar) dumpSTMStats Check argFiles -> do - dir <- maybe IO.getCurrentDirectory return argsProjectRoot + let dir = argsProjectRoot dbLoc <- getHieDbLoc dir - runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do + runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc mempty $ \hiedb threadQueue -> do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error hSetEncoding stdout utf8 hSetEncoding stderr utf8 @@ -374,78 +387,107 @@ putStrLn "Report bugs at https://github.com/haskell/haskell-language-server/issues" putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir - files <- expandFiles (argFiles ++ ["." | null argFiles]) + files <- expandFiles recorder (argFiles ++ ["." | null argFiles]) -- LSP works with absolute file paths, so try and behave similarly - files <- nubOrd <$> mapM IO.canonicalizePath files - putStrLn $ "Found " ++ show (length files) ++ " files" + absoluteFiles <- nubOrd <$> mapM IO.canonicalizePath files + putStrLn $ "Found " ++ show (length absoluteFiles) ++ " files" putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup" - cradles <- mapM findCradle files + cradles <- mapM findCradle absoluteFiles let ucradles = nubOrd cradles let n = length ucradles putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1] when (n > 0) $ putStrLn $ " (" ++ intercalate ", " (catMaybes ucradles) ++ ")" putStrLn "\nStep 3/4: Initializing the IDE" - sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir (tLoaderQueue threadQueue) let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader - options = def_options + ideOptions = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer options hiedb hieChan mempty + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty dir shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) putStrLn "\nStep 4/4: Type checking the files" - setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') files - results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files) - _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' files) - _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' files) - let (worked, failed) = partition fst $ zip (map isJust results) files + setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') absoluteFiles + results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' absoluteFiles) + _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' absoluteFiles) + _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' absoluteFiles) + let (worked, failed) = partition fst $ zip (map isJust results) absoluteFiles when (failed /= []) $ putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed - let nfiles xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files" + let nfiles xs = let n' = length xs in if n' == 1 then "1 file" else show n' ++ " files" putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)" unless (null failed) (exitWith $ ExitFailure (length failed)) Db opts cmd -> do - root <- maybe IO.getCurrentDirectory return argsProjectRoot + let root = argsProjectRoot dbLoc <- getHieDbLoc root hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc - mlibdir <- setInitialDynFlags (cmapWithPrio LogSession recorder) root def + mlibdir <- getInitialGhcLibDirDefault (cmapWithPrio LogSession recorder) root rng <- newStdGen case mlibdir of Nothing -> exitWith $ ExitFailure 1 Just libdir -> retryOnSqliteBusy (cmapWithPrio LogSession recorder) rng (HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd) Custom (IdeCommand c) -> do - root <- maybe IO.getCurrentDirectory return argsProjectRoot + let root = argsProjectRoot dbLoc <- getHieDbLoc root - runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do - sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." + runWithWorkerThreads (cmapWithPrio LogSession recorder) dbLoc mempty $ \hiedb threadQueue -> do + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." (tLoaderQueue threadQueue) let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader - options = def_options + ideOptions = def_options { optCheckParents = pure NeverCheck , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing logger debouncer options hiedb hieChan mempty + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb threadQueue mempty root shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide -expandFiles :: [FilePath] -> IO [FilePath] -expandFiles = concatMapM $ \x -> do +-- | List the haskell files given some paths +-- +-- It will rely on git if possible to filter-out ignored files. +expandFiles :: Recorder (WithPriority Log) -> [FilePath] -> IO [FilePath] +expandFiles recorder paths = do + let haskellFind x = + let recurse "." = True + recurse y | "." `isPrefixOf` takeFileName y = False -- skip .git etc + recurse y = takeFileName y `notElem` ["dist", "dist-newstyle"] -- cabal directories + in filter (\y -> takeExtension y `elem` [".hs", ".lhs"]) <$> IO.listFilesInside (return . recurse) x + git args = do + mResult <- (Just <$> readProcessWithExitCode "git" args "") `Safe.catchAny`const (pure Nothing) + pure $ + case mResult of + Just (ExitSuccess, gitStdout, _) -> Just gitStdout + _ -> Nothing + mHasGit <- git ["status"] + when (isJust mHasGit) $ logWith recorder Info LogUsingGit + let findFiles = + case mHasGit of + Just _ -> \path -> do + let lookups = + if takeExtension path `elem` [".hs", ".lhs"] + then [path] + else [path "*.hs", path "*.lhs"] + gitLines args = fmap lines <$> git args + mTracked <- gitLines ("ls-files":lookups) + mUntracked <- gitLines ("ls-files":"-o":lookups) + case mTracked <> mUntracked of + Nothing -> haskellFind path + Just files -> pure files + _ -> haskellFind + + flip concatMapM paths $ \x -> do b <- IO.doesFileExist x if b then return [x] else do - let recurse "." = True - recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc - recurse x = takeFileName x `notElem` ["dist", "dist-newstyle"] -- cabal directories - files <- filter (\x -> takeExtension x `elem` [".hs", ".lhs"]) <$> IO.listFilesInside (return . recurse) x + files <- findFiles x when (null files) $ fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x return files diff --git a/src/Development/IDE/Main/HeapStats.hs b/src/Development/IDE/Main/HeapStats.hs --- a/src/Development/IDE/Main/HeapStats.hs +++ b/src/Development/IDE/Main/HeapStats.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE NumericUnderscores #-} -- | Logging utilities for reporting heap statistics module Development.IDE.Main.HeapStats ( withHeapStats, Log(..)) where @@ -6,11 +5,11 @@ import Control.Concurrent.Async import Control.Monad import Data.Word -import Development.IDE.Types.Logger (Pretty (pretty), Priority (Info), - Recorder, WithPriority, hsep, - logWith, (<+>)) import GHC.Stats -import Text.Printf (printf) +import Ide.Logger (Pretty (pretty), Priority (Info), + Recorder, WithPriority, hsep, + logWith, (<+>)) +import Text.Printf (printf) data Log = LogHeapStatsPeriod !Int @@ -19,7 +18,7 @@ deriving Show instance Pretty Log where - pretty log = case log of + pretty = \case LogHeapStatsPeriod period -> "Logging heap statistics every" <+> pretty (toFormattedSeconds period) LogHeapStatsDisabled -> diff --git a/src/Development/IDE/Monitoring/EKG.hs b/src/Development/IDE/Monitoring/EKG.hs deleted file mode 100644 --- a/src/Development/IDE/Monitoring/EKG.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE CPP #-} -module Development.IDE.Monitoring.EKG(monitoring) where - -import Development.IDE.Types.Logger (Logger) -import Development.IDE.Types.Monitoring (Monitoring (..)) -#ifdef MONITORING_EKG -import Control.Concurrent (killThread) -import Control.Concurrent.Async (async, waitCatch) -import Control.Monad (forM_) -import Data.Text (pack) -import Development.IDE.Types.Logger (logInfo) -import qualified System.Metrics as Monitoring -import qualified System.Remote.Monitoring.Wai as Monitoring - --- | Monitoring using EKG -monitoring :: Logger -> Int -> IO Monitoring -monitoring logger port = do - store <- Monitoring.newStore - Monitoring.registerGcMetrics store - let registerCounter name read = Monitoring.registerCounter name read store - registerGauge name read = Monitoring.registerGauge name read store - start = do - server <- do - let startServer = Monitoring.forkServerWith store "localhost" port - -- this can fail if the port is busy, throwing an async exception back to us - -- to handle that, wrap the server thread in an async - mb_server <- async startServer >>= waitCatch - case mb_server of - Right s -> do - logInfo logger $ pack $ - "Started monitoring server on port " <> show port - return $ Just s - Left e -> do - logInfo logger $ pack $ - "Unable to bind monitoring server on port " - <> show port <> ":" <> show e - return Nothing - return $ forM_ server $ \s -> do - logInfo logger "Stopping monitoring server" - killThread $ Monitoring.serverThreadId s - return $ Monitoring {..} - -#else - -monitoring :: Logger -> Int -> IO Monitoring -monitoring _ _ = mempty - -#endif diff --git a/src/Development/IDE/Monitoring/OpenTelemetry.hs b/src/Development/IDE/Monitoring/OpenTelemetry.hs --- a/src/Development/IDE/Monitoring/OpenTelemetry.hs +++ b/src/Development/IDE/Monitoring/OpenTelemetry.hs @@ -15,9 +15,9 @@ monitoring | userTracingEnabled = do actions <- newIORef [] - let registerCounter name read = do + let registerCounter name readA = do observer <- mkValueObserver (encodeUtf8 name) - let update = observe observer . fromIntegral =<< read + let update = observe observer . fromIntegral =<< readA atomicModifyIORef'_ actions (update :) registerGauge = registerCounter let start = do diff --git a/src/Development/IDE/Plugin/Completions.hs b/src/Development/IDE/Plugin/Completions.hs --- a/src/Development/IDE/Plugin/Completions.hs +++ b/src/Development/IDE/Plugin/Completions.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} module Development.IDE.Plugin.Completions @@ -11,72 +10,81 @@ import Control.Concurrent.Async (concurrently) import Control.Concurrent.STM.Stats (readTVarIO) +import Control.Lens ((&), (.~), (?~)) import Control.Monad.IO.Class -import Control.Lens ((&), (.~)) +import Control.Monad.Trans.Except (ExceptT (ExceptT), + withExceptT) import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as Set -import Data.Aeson import Data.Maybe import qualified Data.Text as T -import Development.IDE.Core.PositionMapping import Development.IDE.Core.Compile +import Development.IDE.Core.FileStore (getUriContents) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service hiding (Log, LogShake) -import Development.IDE.Core.Shake hiding (Log) +import Development.IDE.Core.Shake hiding (Log, + knownTargets) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Util import Development.IDE.Graph -import Development.IDE.Spans.Common -import Development.IDE.Spans.Documentation import Development.IDE.Plugin.Completions.Logic import Development.IDE.Plugin.Completions.Types +import Development.IDE.Spans.Common +import Development.IDE.Spans.Documentation import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq (HscEnvEq (envPackageExports, envVisibleModuleNames), hscEnv) import qualified Development.IDE.Types.KnownTargets as KT import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) +import Ide.Plugin.Error import Ide.Types -import qualified Language.LSP.Server as LSP -import Language.LSP.Types -import qualified Language.LSP.Types.Lens as J -import qualified Language.LSP.VFS as VFS +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import Numeric.Natural +import Prelude hiding (mod) import Text.Fuzzy.Parallel (Scored (..)) import Development.IDE.Core.Rules (usePropertyAction) -import qualified GHC.LanguageExtensions as LangExt + import qualified Ide.Plugin.Config as Config +import qualified GHC.LanguageExtensions as LangExt + data Log = LogShake Shake.Log deriving Show instance Pretty Log where pretty = \case - LogShake log -> pretty log + LogShake msg -> pretty msg ghcideCompletionsPluginPriority :: Natural ghcideCompletionsPluginPriority = defaultPluginPriority descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = (defaultPluginDescriptor plId) +descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginRules = produceCompletions recorder - , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP - <> mkPluginHandler SCompletionItemResolve resolveCompletion + , pluginHandlers = mkPluginHandler SMethod_TextDocumentCompletion getCompletionsLSP + <> mkResolveHandler SMethod_CompletionItemResolve resolveCompletion , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} , pluginPriority = ghcideCompletionsPluginPriority } + where + desc = "Provides Haskell completions" produceCompletions :: Recorder (WithPriority Log) -> Rules () produceCompletions recorder = do define (cmapWithPrio LogShake recorder) $ \LocalCompletions file -> do let uri = fromNormalizedUri $ normalizedFilePathToUri file - pm <- useWithStale GetParsedModule file - case pm of + mbPm <- useWithStale GetParsedModule file + case mbPm of Just (pm, _) -> do let cdata = localCompletionsForParsedModule uri pm return ([], Just cdata) @@ -86,9 +94,9 @@ -- synthesizing a fake module with an empty body from the buffer -- in the ModSummary, which preserves all the imports ms <- fmap fst <$> useWithStale GetModSummaryWithoutTimestamps file - sess <- fmap fst <$> useWithStale GhcSessionDeps file + mbSess <- fmap fst <$> useWithStale GhcSessionDeps file - case (ms, sess) of + case (ms, mbSess) of (Just ModSummaryResult{..}, Just sess) -> do let env = hscEnv sess -- We do this to be able to provide completions of items that are not restricted to the explicit list @@ -106,68 +114,56 @@ -- Drop any explicit imports in ImportDecl if not hidden dropListFromImportDecl :: LImportDecl GhcPs -> LImportDecl GhcPs dropListFromImportDecl iDecl = let - f d@ImportDecl {ideclHiding} = case ideclHiding of - Just (False, _) -> d {ideclHiding=Nothing} + f d@ImportDecl {ideclImportList} = case ideclImportList of + Just (Exactly, _) -> d {ideclImportList=Nothing} -- if hiding or Nothing just return d - _ -> d + _ -> d f x = x in f <$> iDecl -resolveCompletion :: IdeState -> PluginId -> CompletionItem -> LSP.LspM Config (Either ResponseError CompletionItem) -resolveCompletion ide _ comp@CompletionItem{_detail,_documentation,_xdata} - | Just resolveData <- _xdata - , Success (CompletionResolveData uri needType (NameDetails mod occ)) <- fromJSON resolveData - , Just file <- uriToNormalizedFilePath $ toNormalizedUri uri - = liftIO $ runIdeAction "Completion resolve" (shakeExtras ide) $ do - msess <- useWithStaleFast GhcSessionDeps file - case msess of - Nothing -> pure (Right comp) -- File doesn't compile, return original completion item - Just (sess,_) -> do - let nc = ideNc $ shakeExtras ide -#if MIN_VERSION_ghc(9,3,0) - name <- liftIO $ lookupNameCache nc mod occ -#else - name <- liftIO $ upNameCache nc (lookupNameCache mod occ) -#endif - mdkm <- useWithStaleFast GetDocMap file - let (dm,km) = case mdkm of - Just (DKMap dm km, _) -> (dm,km) - Nothing -> (mempty, mempty) - doc <- case lookupNameEnv dm name of - Just doc -> pure $ spanDocToMarkdown doc - Nothing -> liftIO $ spanDocToMarkdown <$> getDocumentationTryGhc (hscEnv sess) name - typ <- case lookupNameEnv km name of - _ | not needType -> pure Nothing - Just ty -> pure (safeTyThingType ty) - Nothing -> do - (safeTyThingType =<<) <$> liftIO (lookupName (hscEnv sess) name) - let det1 = case typ of - Just ty -> Just (":: " <> printOutputable (stripForall ty) <> "\n") - Nothing -> Nothing - doc1 = case _documentation of - Just (CompletionDocMarkup (MarkupContent MkMarkdown old)) -> - CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator (old:doc) - _ -> CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator doc - pure (Right $ comp & J.detail .~ (det1 <> _detail) - & J.documentation .~ Just doc1 - ) +resolveCompletion :: ResolveFunction IdeState CompletionResolveData Method_CompletionItemResolve +resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} uri (CompletionResolveData _ needType (NameDetails mod occ)) = + do + file <- getNormalizedFilePathE uri + (sess,_) <- withExceptT (const PluginStaleResolve) + $ runIdeActionE "CompletionResolve.GhcSessionDeps" (shakeExtras ide) + $ useWithStaleFastE GhcSessionDeps file + let nc = ideNc $ shakeExtras ide + name <- liftIO $ lookupNameCache nc mod occ + mdkm <- liftIO $ runIdeAction "CompletionResolve.GetDocMap" (shakeExtras ide) $ useWithStaleFast GetDocMap file + let (dm,km) = case mdkm of + Just (DKMap docMap tyThingMap _argDocMap, _) -> (docMap,tyThingMap) + Nothing -> (mempty, mempty) + doc <- case lookupNameEnv dm name of + Just doc -> pure $ spanDocToMarkdown doc + Nothing -> liftIO $ spanDocToMarkdown . fst <$> getDocumentationTryGhc (hscEnv sess) name + typ <- case lookupNameEnv km name of + _ | not needType -> pure Nothing + Just ty -> pure (safeTyThingType True ty) + Nothing -> do + (safeTyThingType True =<<) <$> liftIO (lookupName (hscEnv sess) name) + let det1 = case typ of + Just ty -> Just (":: " <> printOutputable (stripForall ty) <> "\n") + Nothing -> Nothing + doc1 = case _documentation of + Just (InR (MarkupContent MarkupKind_Markdown old)) -> + InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator (old:doc) + _ -> InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator doc + pure (comp & L.detail .~ (det1 <> _detail) + & L.documentation ?~ doc1) where stripForall ty = case splitForAllTyCoVars ty of (_,res) -> res -resolveCompletion _ _ comp = pure (Right comp) -- | Generate code actions. -getCompletionsLSP - :: IdeState - -> PluginId - -> CompletionParams - -> LSP.LspM Config (Either ResponseError (ResponseResult TextDocumentCompletion)) +getCompletionsLSP :: PluginMethodHandler IdeState Method_TextDocumentCompletion getCompletionsLSP ide plId CompletionParams{_textDocument=TextDocumentIdentifier uri ,_position=position - ,_context=completionContext} = do - contents <- LSP.getVirtualFile $ toNormalizedUri uri - fmap Right $ case (contents, uriToFilePath' uri) of + ,_context=completionContext} = ExceptT $ do + contentsMaybe <- + liftIO $ runAction "Completion" ide $ getUriContents $ toNormalizedUri uri + fmap Right $ case (contentsMaybe, uriToFilePath' uri) of (Just cnts, Just path) -> do let npath = toNormalizedFilePath' path (ideOpts, compls, moduleExports, astres) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do @@ -177,7 +173,7 @@ pm <- useWithStaleFast GetParsedModule npath binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath knownTargets <- liftIO $ runAction "Completion" ide $ useNoFile GetKnownTargets - let localModules = maybe [] Map.keys knownTargets + let localModules = maybe [] (Map.keys . targetMap) knownTargets let lModules = mempty{importableModules = map toModueNameText localModules} -- set up the exports map including both package and project-level identifiers packageExportsMapIO <- fmap(envPackageExports . fst) <$> useWithStaleFast GhcSession npath @@ -191,11 +187,7 @@ let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls <> Just lModules -- get HieAst if OverloadedRecordDot is enabled -#if MIN_VERSION_ghc(9,2,0) let uses_overloaded_record_dot (ms_hspp_opts . msrModSummary -> dflags) = xopt LangExt.OverloadedRecordDot dflags -#else - let uses_overloaded_record_dot _ = False -#endif ms <- fmap fst <$> useWithStaleFast GetModSummaryWithoutTimestamps npath astres <- case ms of Just ms' | uses_overloaded_record_dot ms' @@ -205,20 +197,19 @@ pure (opts, fmap (,pm,binds) compls, moduleExports, astres) case compls of Just (cci', parsedMod, bindMap) -> do - let pfix = getCompletionPrefix position cnts + let pfix = getCompletionPrefixFromRope position cnts case (pfix, completionContext) of - ((PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) - -> return (InL $ List []) + (PosPrefixInfo _ "" _ _, Just CompletionContext { _triggerCharacter = Just "."}) + -> return (InL []) (_, _) -> do let clientCaps = clientCapabilities $ shakeExtras ide plugins = idePlugins $ shakeExtras ide config <- liftIO $ runAction "" ide $ getCompletionsConfig plId - allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports uri - pure $ InL (List $ orderedCompletions allCompletions) - _ -> return (InL $ List []) - _ -> return (InL $ List []) - _ -> return (InL $ List []) + let allCompletions = getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports uri + pure $ InL (orderedCompletions allCompletions) + _ -> return (InL []) + _ -> return (InL []) getCompletionsConfig :: PluginId -> Action CompletionsConfig getCompletionsConfig pId = diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/src/Development/IDE/Plugin/Completions/Logic.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} - +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} -- Mostly taken from "haskell-ide-engine" module Development.IDE.Plugin.Completions.Logic ( @@ -11,69 +11,73 @@ , getCompletions , fromIdentInfo , getCompletionPrefix +, getCompletionPrefixFromRope ) where import Control.Applicative +import Control.Lens hiding (Context, + parts) import Data.Char (isAlphaNum, isUpper) +import Data.Default (def) import Data.Generics import Data.List.Extra as List hiding (stripPrefix) import qualified Data.Map as Map +import Prelude hiding (mod) -import Data.Maybe (catMaybes, fromMaybe, - isJust, listToMaybe, - mapMaybe, isNothing) +import Data.Maybe (fromMaybe, isJust, + isNothing, + listToMaybe, + mapMaybe) import qualified Data.Text as T import qualified Text.Fuzzy.Parallel as Fuzzy import Control.Monad import Data.Aeson (ToJSON (toJSON)) import Data.Function (on) -import Data.Functor -import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HashSet -import Data.Monoid (First (..)) import Data.Ord (Down (Down)) import qualified Data.Set as Set -import Development.IDE.Core.Compile import Development.IDE.Core.PositionMapping -import Development.IDE.GHC.Compat hiding (ppr) +import Development.IDE.GHC.Compat hiding (isQual, ppr) import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types -import Development.IDE.Spans.Common -import Development.IDE.Spans.Documentation import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Exports -import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Options - -#if MIN_VERSION_ghc(9,2,0) -import GHC.Plugins (Depth (AllTheWay), - defaultSDocContext, - mkUserStyle, - neverQualify, - renderWithContext, - sdocStyle) -#endif +import GHC.Iface.Ext.Types (HieAST, + NodeInfo (..)) +import GHC.Iface.Ext.Utils (nodeInfo) import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), IdePlugins (..), PluginId) -import Language.LSP.Types -import Language.LSP.Types.Capabilities +import Language.Haskell.Syntax.Basic +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types import qualified Language.LSP.VFS as VFS import Text.Fuzzy.Parallel (Scored (score), original) -import qualified Data.Text.Utf16.Rope as Rope -import Development.IDE +import qualified Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE hiding (line) import Development.IDE.Spans.AtPoint (pointCommand) + +import qualified Development.IDE.Plugin.Completions.Types as C +import GHC.Plugins (Depth (AllTheWay), + mkUserStyle, + neverQualify, + sdocStyle) + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + + -- Chunk size used for parallelizing fuzzy matching chunkSize :: Int chunkSize = 1000 @@ -137,29 +141,31 @@ importGo :: GHC.LImportDecl GhcPs -> Maybe Context importGo (L (locA -> r) impDecl) | pos `isInsideSrcSpan` r - = importInline importModuleName (fmap (fmap reLoc) $ ideclHiding impDecl) + = importInline importModuleName (fmap (fmap reLoc) $ ideclImportList impDecl) <|> Just (ImportContext importModuleName) | otherwise = Nothing where importModuleName = moduleNameString $ unLoc $ ideclName impDecl - importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context - importInline modName (Just (True, L r _)) + -- importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context + importInline modName (Just (EverythingBut, L r _)) | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName | otherwise = Nothing - importInline modName (Just (False, L r _)) + + importInline modName (Just (Exactly, L r _)) | pos `isInsideSrcSpan` r = Just $ ImportListContext modName | otherwise = Nothing + importInline _ _ = Nothing occNameToComKind :: OccName -> CompletionItemKind occNameToComKind oc | isVarOcc oc = case occNameString oc of - i:_ | isUpper i -> CiConstructor - _ -> CiFunction - | isTcOcc oc = CiStruct - | isDataOcc oc = CiConstructor - | otherwise = CiVariable + i:_ | isUpper i -> CompletionItemKind_Constructor + _ -> CompletionItemKind_Function + | isTcOcc oc = CompletionItemKind_Struct + | isDataOcc oc = CompletionItemKind_Constructor + | otherwise = CompletionItemKind_Variable showModName :: ModuleName -> T.Text @@ -169,7 +175,7 @@ -> IdeOptions -> Uri -> CompItem -> CompletionItem mkCompl pId - IdeOptions {..} + _ideOptions uri CI { compKind, @@ -197,14 +203,16 @@ _preselect = Nothing, _sortText = Nothing, _filterText = Nothing, - _insertText = Just insertText, - _insertTextFormat = Just Snippet, + _insertText = Just $ snippetToText insertText, + _insertTextFormat = Just InsertTextFormat_Snippet, _insertTextMode = Nothing, _textEdit = Nothing, _additionalTextEdits = Nothing, _commitCharacters = Nothing, _command = mbCommand, - _xdata = toJSON <$> fmap (CompletionResolveData uri (isNothing typeText)) nameDetails} + _data_ = toJSON <$> fmap (CompletionResolveData uri (isNothing typeText)) nameDetails, + _labelDetails = Nothing, + _textEditText = Nothing} removeSnippetsWhen (isJust isInfix) ci where kind = Just compKind @@ -213,8 +221,8 @@ Local pos -> "*Defined at " <> pprLineCol (srcSpanStart pos) <> " in this module*\n" ImportedFrom mod -> "*Imported from '" <> mod <> "'*\n" DefinedIn mod -> "*Defined in '" <> mod <> "'*\n" - documentation = Just $ CompletionDocMarkup $ - MarkupContent MkMarkdown $ + documentation = Just $ InR $ + MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator docs' pprLineCol :: SrcLoc -> T.Text pprLineCol (UnhelpfulLoc fs) = T.pack $ unpackFS fs @@ -234,11 +242,10 @@ compKind = occNameToComKind origName isTypeCompl = isTcOcc origName typeText = Nothing - label = stripPrefix $ printOutputable origName - insertText = case isInfix of - Nothing -> label - Just LeftSide -> label <> "`" - + label = stripOccNamePrefix $ printOutputable origName + insertText = snippetText $ case isInfix of + Nothing -> label + Just LeftSide -> label <> "`" Just Surrounded -> label additionalTextEdits = imp <&> \x -> @@ -251,50 +258,48 @@ } showForSnippet :: Outputable a => a -> T.Text -#if MIN_VERSION_ghc(9,2,0) showForSnippet x = T.pack $ renderWithContext ctxt $ GHC.ppr x -- FIXme where ctxt = defaultSDocContext{sdocStyle = mkUserStyle neverQualify AllTheWay} -#else -showForSnippet x = printOutputable x -#endif mkModCompl :: T.Text -> CompletionItem mkModCompl label = - CompletionItem label (Just CiModule) Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing + defaultCompletionItemWithLabel label + & L.kind ?~ CompletionItemKind_Module mkModuleFunctionImport :: T.Text -> T.Text -> CompletionItem mkModuleFunctionImport moduleName label = - CompletionItem label (Just CiFunction) Nothing (Just moduleName) - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing + defaultCompletionItemWithLabel label + & L.kind ?~ CompletionItemKind_Function + & L.detail ?~ moduleName mkImportCompl :: T.Text -> T.Text -> CompletionItem mkImportCompl enteredQual label = - CompletionItem m (Just CiModule) Nothing (Just label) - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing + defaultCompletionItemWithLabel m + & L.kind ?~ CompletionItemKind_Module + & L.detail ?~ label where m = fromMaybe "" (T.stripPrefix enteredQual label) mkExtCompl :: T.Text -> CompletionItem mkExtCompl label = - CompletionItem label (Just CiKeyword) Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing + defaultCompletionItemWithLabel label + & L.kind ?~ CompletionItemKind_Keyword +defaultCompletionItemWithLabel :: T.Text -> CompletionItem +defaultCompletionItemWithLabel label = + CompletionItem label def def def def def def def def def + def def def def def def def def def fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem -fromIdentInfo doc id@IdentInfo{..} q = CI +fromIdentInfo doc identInfo@IdentInfo{..} q = CI { compKind= occNameToComKind name - , insertText=rend + , insertText= snippetText rend , provenance = DefinedIn mod , label=rend , typeText = Nothing , isInfix=Nothing - , isTypeCompl= not (isDatacon id) && isUpper (T.head rend) + , isTypeCompl= not (isDatacon identInfo) && isUpper (T.head rend) , additionalTextEdits= Just $ ExtendImport { doc, @@ -306,8 +311,8 @@ , nameDetails = Nothing , isLocalCompletion = False } - where rend = rendered id - mod = moduleNameText id + where rend = rendered identInfo + mod = moduleNameText identInfo cacheDataProducer :: Uri -> [ModuleName] -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> CachedCompletions cacheDataProducer uri visibleMods curMod globalEnv inScopeEnv limports = @@ -332,17 +337,13 @@ -- construct a map from Parents(type) to their fields fieldMap = Map.fromListWith (++) $ flip mapMaybe rdrElts $ \elt -> do -#if MIN_VERSION_ghc(9,2,0) par <- greParent_maybe elt - flbl <- greFieldLabel elt - Just (par,[flLabel flbl]) +#if MIN_VERSION_ghc(9,7,0) + flbl <- greFieldLabel_maybe elt #else - case gre_par elt of - FldParent n ml -> do - l <- ml - Just (n, [l]) - _ -> Nothing + flbl <- greFieldLabel elt #endif + Just (par,[flLabel flbl]) getCompls :: [GlobalRdrElt] -> ([CompItem],QualCompls) getCompls = foldMap getComplsForOne @@ -366,24 +367,25 @@ | is_qual spec = Map.singleton asMod compItem | otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)] asMod = showModName (is_as spec) +#if MIN_VERSION_ghc(9,8,0) + origMod = showModName (moduleName $ is_mod spec) +#else origMod = showModName (is_mod spec) +#endif in (unqual,QualCompls qual) toCompItem :: Parent -> Module -> T.Text -> Name -> Maybe (LImportDecl GhcPs) -> [CompItem] - toCompItem par m mn n imp' = + toCompItem par _ mn n imp' = -- docs <- getDocumentationTryGhc packageState curMod n let (mbParent, originName) = case par of NoParent -> (Nothing, nameOccName n) ParentIs n' -> (Just . T.pack $ printName n', nameOccName n) -#if !MIN_VERSION_ghc(9,2,0) - FldParent n' lbl -> (Just . T.pack $ printName n', maybe (nameOccName n) mkVarOccFS lbl) -#endif recordCompls = case par of ParentIs parent | isDataConName n , Just flds <- Map.lookup parent fieldMap , not (null flds) -> - [mkRecordSnippetCompItem uri mbParent (printOutputable originName) (map (T.pack . unpackFS) flds) (ImportedFrom mn) imp'] + [mkRecordSnippetCompItem uri mbParent (printOutputable originName) (map (T.pack . unpackFS . field_label) flds) (ImportedFrom mn) imp'] _ -> [] in mkNameCompItem uri mbParent originName (ImportedFrom mn) Nothing imp' (nameModule_maybe n) @@ -413,60 +415,61 @@ } where typeSigIds = Set.fromList - [ id + [ identifier | L _ (SigD _ (TypeSig _ ids _)) <- hsmodDecls - , L _ id <- ids + , L _ identifier <- ids ] hasTypeSig = (`Set.member` typeSigIds) . unLoc compls = concat [ case decl of SigD _ (TypeSig _ ids typ) -> - [mkComp id CiFunction (Just $ showForSnippet typ) | id <- ids] + [mkComp identifier CompletionItemKind_Function (Just $ showForSnippet typ) | identifier <- ids] ValD _ FunBind{fun_id} -> - [ mkComp fun_id CiFunction Nothing + [ mkComp fun_id CompletionItemKind_Function Nothing | not (hasTypeSig fun_id) ] ValD _ PatBind{pat_lhs} -> - [mkComp id CiVariable Nothing - | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] + [mkComp identifier CompletionItemKind_Variable Nothing + | VarPat _ identifier <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] TyClD _ ClassDecl{tcdLName, tcdSigs, tcdATs} -> - mkComp tcdLName CiInterface (Just $ showForSnippet tcdLName) : - [ mkComp id CiFunction (Just $ showForSnippet typ) + mkComp tcdLName CompletionItemKind_Interface (Just $ showForSnippet tcdLName) : + [ mkComp identifier CompletionItemKind_Function (Just $ showForSnippet typ) | L _ (ClassOpSig _ _ ids typ) <- tcdSigs - , id <- ids] ++ - [ mkComp fdLName CiStruct (Just $ showForSnippet fdLName) + , identifier <- ids] ++ + [ mkComp fdLName CompletionItemKind_Struct (Just $ showForSnippet fdLName) | L _ (FamilyDecl{fdLName}) <- tcdATs] TyClD _ x -> - let generalCompls = [mkComp id cl (Just $ showForSnippet $ tyClDeclLName x) - | id <- listify (\(_ :: LIdP GhcPs) -> True) x - , let cl = occNameToComKind (rdrNameOcc $ unLoc id)] + let generalCompls = [mkComp identifier cl (Just $ showForSnippet $ tyClDeclLName x) + | identifier <- listify (\(_ :: LIdP GhcPs) -> True) x + , let cl = occNameToComKind (rdrNameOcc $ unLoc identifier)] -- here we only have to look at the outermost type recordCompls = findRecordCompl uri (Local pos) x in -- the constructors and snippets will be duplicated here giving the user 2 choices. generalCompls ++ recordCompls ForD _ ForeignImport{fd_name,fd_sig_ty} -> - [mkComp fd_name CiVariable (Just $ showForSnippet fd_sig_ty)] + [mkComp fd_name CompletionItemKind_Variable (Just $ showForSnippet fd_sig_ty)] ForD _ ForeignExport{fd_name,fd_sig_ty} -> - [mkComp fd_name CiVariable (Just $ showForSnippet fd_sig_ty)] + [mkComp fd_name CompletionItemKind_Variable (Just $ showForSnippet fd_sig_ty)] _ -> [] | L (locA -> pos) decl <- hsmodDecls, let mkComp = mkLocalComp pos ] mkLocalComp pos n ctyp ty = - CI ctyp pn (Local pos) pn ty Nothing (ctyp `elem` [CiStruct, CiInterface]) Nothing (Just $ NameDetails (ms_mod $ pm_mod_summary pm) occ) True + CI ctyp sn (Local pos) pn ty Nothing (ctyp `elem` [CompletionItemKind_Struct, CompletionItemKind_Interface]) Nothing (Just $ NameDetails (ms_mod $ pm_mod_summary pm) occ) True where occ = rdrNameOcc $ unLoc n pn = showForSnippet n + sn = snippetText pn findRecordCompl :: Uri -> Provenance -> TyClDecl GhcPs -> [CompItem] findRecordCompl uri mn DataDecl {tcdLName, tcdDataDefn} = result where result = [mkRecordSnippetCompItem uri (Just $ printOutputable $ unLoc tcdLName) (printOutputable . unLoc $ con_name) field_labels mn Nothing - | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn + | ConDeclH98{..} <- unLoc <$> (extract_cons $ dd_cons tcdDataDefn) , Just con_details <- [getFlds con_args] , let field_names = concatMap extract con_details , let field_labels = printOutputable <$> field_names @@ -487,15 +490,17 @@ -- -- is encoded as @[[arg1, arg2], [arg3], [arg4]]@ -- Hence, we must concat nested arguments into one to get all the fields. -#if MIN_VERSION_ghc(9,3,0) - extract ConDeclField{..} - = map (foLabel . unLoc) cd_fld_names +#if MIN_VERSION_ghc(9,13,0) + extract HsConDeclRecField{..} + = map (foLabel . unLoc) cdrf_names + -- XConDeclRecField + extract _ = [] #else extract ConDeclField{..} - = map (rdrNameFieldOcc . unLoc) cd_fld_names -#endif + = map (foLabel . unLoc) cd_fld_names -- XConDeclField extract _ = [] +#endif findRecordCompl _ _ _ = [] toggleSnippets :: ClientCapabilities -> CompletionsConfig -> CompletionItem -> CompletionItem @@ -503,7 +508,7 @@ removeSnippetsWhen (not $ enableSnippets && supported) where supported = - Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport) + Just True == (_textDocument >>= _completion >>= view L.completionItem >>= view L.snippetSupport) toggleAutoExtend :: CompletionsConfig -> CompItem -> CompItem toggleAutoExtend CompletionsConfig{enableAutoExtend=False} x = x {additionalTextEdits = Nothing} @@ -514,7 +519,7 @@ if condition then x - { _insertTextFormat = Just PlainText, + { _insertTextFormat = Just InsertTextFormat_PlainText, _insertText = Nothing } else x @@ -532,10 +537,54 @@ -> CompletionsConfig -> ModuleNameEnv (HashSet.HashSet IdentInfo) -> Uri - -> IO [Scored CompletionItem] -getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules} - maybe_parsed maybe_ast_res (localBindings, bmapping) prefixInfo caps config moduleExportsMap uri = do - let PosPrefixInfo { fullLine, prefixScope, prefixText } = prefixInfo + -> [Scored CompletionItem] +getCompletions + plugins + ideOpts + CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules} + maybe_parsed + maybe_ast_res + (localBindings, bmapping) + prefixInfo@(PosPrefixInfo { fullLine, prefixScope, prefixText }) + caps + config + moduleExportsMap + uri + -- ------------------------------------------------------------------------ + -- IMPORT MODULENAME (NAM|) + | Just (ImportListContext moduleName) <- maybeContext + = moduleImportListCompletions moduleName + + | Just (ImportHidingContext moduleName) <- maybeContext + = moduleImportListCompletions moduleName + + -- ------------------------------------------------------------------------ + -- IMPORT MODULENAM| + | Just (ImportContext _moduleName) <- maybeContext + = filtImportCompls + + -- ------------------------------------------------------------------------ + -- {-# LA| #-} + -- we leave this condition here to avoid duplications and return empty list + -- since HLS implements these completions (#haskell-language-server/pull/662) + | "{-# " `T.isPrefixOf` fullLine + = [] + + -- ------------------------------------------------------------------------ + | otherwise = + -- assumes that nubOrdBy is stable + let uniqueFiltCompls = nubOrdBy (uniqueCompl `on` snd . Fuzzy.original) filtCompls + compls = (fmap.fmap.fmap) (mkCompl pId ideOpts uri) uniqueFiltCompls + pId = lookupCommandProvider plugins (CommandId extendImportCommandId) + in + (fmap.fmap) snd $ + sortBy (compare `on` lexicographicOrdering) $ + mergeListsBy (flip compare `on` score) + [ (fmap.fmap) (notQual,) filtModNameCompls + , (fmap.fmap) (notQual,) filtKeywordCompls + , (fmap.fmap.fmap) (toggleSnippets caps config) compls + ] + where enteredQual = if T.null prefixScope then "" else prefixScope <> "." fullPrefix = enteredQual <> prefixText @@ -558,11 +607,9 @@ $ Fuzzy.simpleFilter chunkSize maxC fullPrefix $ (if T.null enteredQual then id else mapMaybe (T.stripPrefix enteredQual)) allModNamesAsNS - - filtCompls = Fuzzy.filter chunkSize maxC prefixText ctxCompls (label . snd) - where - - mcc = case maybe_parsed of + -- If we have a parsed module, use it to determine which completion to show. + maybeContext :: Maybe Context + maybeContext = case maybe_parsed of Nothing -> Nothing Just (pm, pmapping) -> let PositionMapping pDelta = pmapping @@ -571,7 +618,9 @@ hpos = upperRange position' in getCContext lpos pm <|> getCContext hpos pm - + filtCompls :: [Scored (Bool, CompItem)] + filtCompls = Fuzzy.filter chunkSize maxC prefixText ctxCompls (label . snd) + where -- We need the hieast to be "fresh". We can't get types from "stale" hie files, so hasfield won't work, -- since it gets the record fields from the types. -- Perhaps this could be fixed with a refactor to GHC's IfaceTyCon, to have it also contain record fields. @@ -596,8 +645,8 @@ -- to get the record's module, which isn't included in the type information used to get the fields. dotFieldSelectorToCompl :: T.Text -> T.Text -> (Bool, CompItem) dotFieldSelectorToCompl recname label = (True, CI - { compKind = CiField - , insertText = label + { compKind = CompletionItemKind_Field + , insertText = snippetText label , provenance = DefinedIn recname , label = label , typeText = Nothing @@ -609,7 +658,7 @@ }) -- completions specific to the current context - ctxCompls' = case mcc of + ctxCompls' = case maybeContext of Nothing -> compls Just TypeContext -> filter ( isTypeCompl . snd) compls Just ValueContext -> filter (not . isTypeCompl . snd) compls @@ -626,14 +675,14 @@ endLoc = upperRange oldPos localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc localBindsToCompItem :: Name -> Maybe Type -> CompItem - localBindsToCompItem name typ = CI ctyp pn thisModName pn ty Nothing (not $ isValOcc occ) Nothing dets True + localBindsToCompItem name typ = CI ctyp (snippetText pn) thisModName pn ty Nothing (not $ isValOcc occ) Nothing dets True where occ = nameOccName name ctyp = occNameToComKind occ pn = showForSnippet name ty = showForSnippet <$> typ thisModName = Local $ nameSrcSpan name - dets = NameDetails <$> (nameModule_maybe name) <*> pure (nameOccName name) + dets = NameDetails <$> nameModule_maybe name <*> pure (nameOccName name) -- When record-dot-syntax completions are available, we return them exclusively. -- They are only available when we write i.e. `myrecord.` with OverloadedRecordDot enabled. @@ -644,60 +693,42 @@ | otherwise = ((qual,) <$> Map.findWithDefault [] prefixScope (getQualCompls qualCompls)) ++ map (\compl -> (notQual, compl (Just prefixScope))) anyQualCompls - filtListWith f list = + filtListWith f xs = [ fmap f label - | label <- Fuzzy.simpleFilter chunkSize maxC fullPrefix list + | label <- Fuzzy.simpleFilter chunkSize maxC fullPrefix xs , enteredQual `T.isPrefixOf` original label ] + moduleImportListCompletions :: String -> [Scored CompletionItem] + moduleImportListCompletions moduleNameS = + let moduleName = T.pack moduleNameS + funcs = lookupWithDefaultUFM moduleExportsMap HashSet.empty $ mkModuleName moduleNameS + funs = map (show . name) $ HashSet.toList funcs + in filterModuleExports moduleName $ map T.pack funs + + filtImportCompls :: [Scored CompletionItem] filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules + + filterModuleExports :: T.Text -> [T.Text] -> [Scored CompletionItem] filterModuleExports moduleName = filtListWith $ mkModuleFunctionImport moduleName + + filtKeywordCompls :: [Scored CompletionItem] filtKeywordCompls | T.null prefixScope = filtListWith mkExtCompl (optKeywords ideOpts) | otherwise = [] - if - -- TODO: handle multiline imports - | "import " `T.isPrefixOf` fullLine - && (List.length (words (T.unpack fullLine)) >= 2) - && "(" `isInfixOf` T.unpack fullLine - -> do - let moduleName = words (T.unpack fullLine) !! 1 - funcs = lookupWithDefaultUFM moduleExportsMap HashSet.empty $ mkModuleName moduleName - funs = map (renderOcc . name) $ HashSet.toList funcs - return $ filterModuleExports (T.pack moduleName) funs - | "import " `T.isPrefixOf` fullLine - -> return filtImportCompls - -- we leave this condition here to avoid duplications and return empty list - -- since HLS implements these completions (#haskell-language-server/pull/662) - | "{-# " `T.isPrefixOf` fullLine - -> return [] - | otherwise -> do - -- assumes that nubOrdBy is stable - let uniqueFiltCompls = nubOrdBy (uniqueCompl `on` snd . Fuzzy.original) filtCompls - let compls = (fmap.fmap.fmap) (mkCompl pId ideOpts uri) uniqueFiltCompls - pId = lookupCommandProvider plugins (CommandId extendImportCommandId) - return $ - (fmap.fmap) snd $ - sortBy (compare `on` lexicographicOrdering) $ - mergeListsBy (flip compare `on` score) - [ (fmap.fmap) (notQual,) filtModNameCompls - , (fmap.fmap) (notQual,) filtKeywordCompls - , (fmap.fmap.fmap) (toggleSnippets caps config) compls - ] - where - -- We use this ordering to alphabetically sort suggestions while respecting - -- all the previously applied ordering sources. These are: - -- 1. Qualified suggestions go first - -- 2. Fuzzy score ranks next - -- 3. In-scope completions rank next - -- 4. label alphabetical ordering next - -- 4. detail alphabetical ordering (proxy for module) - lexicographicOrdering Fuzzy.Scored{score, original} = - case original of - (isQual, CompletionItem{_label,_detail}) -> do - let isLocal = maybe False (":" `T.isPrefixOf`) _detail - (Down isQual, Down score, Down isLocal, _label, _detail) + -- We use this ordering to alphabetically sort suggestions while respecting + -- all the previously applied ordering sources. These are: + -- 1. Qualified suggestions go first + -- 2. Fuzzy score ranks next + -- 3. In-scope completions rank next + -- 4. label alphabetical ordering next + -- 4. detail alphabetical ordering (proxy for module) + lexicographicOrdering Fuzzy.Scored{score, original} = + case original of + (isQual, CompletionItem{_label,_detail}) -> do + let isLocal = maybe False (":" `T.isPrefixOf`) _detail + (Down isQual, Down score, Down isLocal, _label, _detail) @@ -709,11 +740,12 @@ EQ -> -- preserve completions for duplicate record fields where the only difference is in the type -- remove redundant completions with less type info than the previous - if (isLocalCompletion unique) + if isLocalCompletion unique -- filter global completions when we already have a local one || not(isLocalCompletion candidate) && isLocalCompletion unique then EQ - else compare (importedFrom candidate, insertText candidate) (importedFrom unique, insertText unique) + else compare (importedFrom candidate) (importedFrom unique) <> + snippetLexOrd (insertText candidate) (insertText unique) other -> other where importedFrom :: CompItem -> T.Text @@ -758,65 +790,11 @@ -- --------------------------------------------------------------------- --- | Under certain circumstance GHC generates some extra stuff that we --- don't want in the autocompleted symbols - {- When e.g. DuplicateRecordFields is enabled, compiler generates - names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors - https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation - -} --- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace. -stripPrefix :: T.Text -> T.Text -stripPrefix name = T.takeWhile (/=':') $ fromMaybe name $ - getFirst $ foldMap (First . (`T.stripPrefix` name)) prefixes - --- | Prefixes that can occur in a GHC OccName -prefixes :: [T.Text] -prefixes = - [ - -- long ones - "$con2tag_" - , "$tag2con_" - , "$maxtag_" - - -- four chars - , "$sel:" - , "$tc'" - - -- three chars - , "$dm" - , "$co" - , "$tc" - , "$cp" - , "$fx" - - -- two chars - , "$W" - , "$w" - , "$m" - , "$b" - , "$c" - , "$d" - , "$i" - , "$s" - , "$f" - , "$r" - , "C:" - , "N:" - , "D:" - , "$p" - , "$L" - , "$f" - , "$t" - , "$c" - , "$m" - ] - - mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> Provenance -> Maybe (LImportDecl GhcPs) -> CompItem mkRecordSnippetCompItem uri parent ctxStr compl importedFrom imp = r where r = CI { - compKind = CiSnippet + compKind = CompletionItemKind_Snippet , insertText = buildSnippet , provenance = importedFrom , typeText = Nothing @@ -836,9 +814,10 @@ } placeholder_pairs = zip compl ([1..]::[Int]) - snippet_parts = map (\(x, i) -> x <> "=${" <> T.pack (show i) <> ":_" <> x <> "}") placeholder_pairs - snippet = T.intercalate (T.pack ", ") snippet_parts - buildSnippet = ctxStr <> " {" <> snippet <> "}" + snippet_parts = placeholder_pairs <&> \(x, i) -> + snippetText x <> "=" <> snippetVariableDefault (T.pack $ show i) (C.SText $ "_" <> x) + snippet = mconcat $ intersperse ", " snippet_parts + buildSnippet = snippetText ctxStr <> " {" <> snippet <> "}" getImportQual :: LImportDecl GhcPs -> Maybe T.Text getImportQual (L _ imp) @@ -888,13 +867,16 @@ -- |From the given cursor position, gets the prefix module or record for autocompletion getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo -getCompletionPrefix pos@(Position l c) (VFS.VirtualFile _ _ ropetext) = +getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext _) = getCompletionPrefixFromRope pos ropetext + +getCompletionPrefixFromRope :: Position -> Rope.Rope -> PosPrefixInfo +getCompletionPrefixFromRope pos@(Position l c) ropetext = fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad let headMaybe = listToMaybe lastMaybe = headMaybe . reverse -- grab the entire line the cursor is at - curLine <- headMaybe $ T.lines $ Rope.toText + curLine <- headMaybe $ Rope.lines $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext let beforePos = T.take (fromIntegral c) curLine -- the word getting typed, after previous space and before cursor @@ -909,7 +891,9 @@ [] -> Nothing (x:xs) -> do let modParts = reverse $ filter (not .T.null) xs - modName = T.intercalate "." modParts + -- Must check the prefix is a valid module name, else record dot accesses treat + -- the record name as a qualName for search and generated imports + modName = if all (isUpper . T.head) modParts then T.intercalate "." modParts else "" return $ PosPrefixInfo { fullLine = curLine, prefixScope = modName, prefixText = x, cursorPos = pos } completionPrefixPos :: PosPrefixInfo -> Position diff --git a/src/Development/IDE/Plugin/Completions/Types.hs b/src/Development/IDE/Plugin/Completions/Types.hs --- a/src/Development/IDE/Plugin/Completions/Types.hs +++ b/src/Development/IDE/Plugin/Completions/Types.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} module Development.IDE.Plugin.Completions.Types ( module Development.IDE.Plugin.Completions.Types ) where @@ -14,33 +14,32 @@ import Data.Aeson import Data.Aeson.Types +import Data.Function (on) import Data.Hashable (Hashable) +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty (..)) +import Data.String (IsString (..)) import Data.Text (Text) -import Data.Typeable (Typeable) import Development.IDE.GHC.Compat import Development.IDE.Graph (RuleResult) -import Development.IDE.Spans.Common +import Development.IDE.Spans.Common () import GHC.Generics (Generic) +import qualified GHC.Types.Name.Occurrence as Occ import Ide.Plugin.Properties -import Language.LSP.Types (CompletionItemKind (..), Uri) -import qualified Language.LSP.Types as J -#if MIN_VERSION_ghc(9,0,0) -import qualified GHC.Types.Name.Occurrence as Occ -#else -import qualified OccName as Occ -#endif +import Language.LSP.Protocol.Types (CompletionItemKind (..), Uri) +import qualified Language.LSP.Protocol.Types as J -- | Produce completions info for a file type instance RuleResult LocalCompletions = CachedCompletions type instance RuleResult NonLocalCompletions = CachedCompletions data LocalCompletions = LocalCompletions - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable LocalCompletions instance NFData LocalCompletions data NonLocalCompletions = NonLocalCompletions - deriving (Eq, Show, Typeable, Generic) + deriving (Eq, Show, Generic) instance Hashable NonLocalCompletions instance NFData NonLocalCompletions @@ -53,8 +52,8 @@ extendImportCommandId = "extendImport" properties :: Properties - '[ 'PropertyKey "autoExtendOn" 'TBoolean, - 'PropertyKey "snippetsOn" 'TBoolean] + '[ 'PropertyKey "autoExtendOn" TBoolean, + 'PropertyKey "snippetsOn" TBoolean] properties = emptyProperties & defineBooleanProperty #snippetsOn "Inserts snippets when using code completions" @@ -86,9 +85,60 @@ | Local SrcSpan deriving (Eq, Ord, Show) +newtype Snippet = Snippet [SnippetAny] + deriving (Eq, Show) + deriving newtype (Semigroup, Monoid) + +instance IsString Snippet where + fromString = snippetText . T.pack + +-- | @SnippetAny@ can be used to construct sanitized snippets. See the LSP +-- spec for more details. +data SnippetAny + = SText Text + -- ^ Literal text + | STabStop Int (Maybe SnippetAny) + -- ^ Creates a tab stop, i.e. parts of the snippet that are meant to be + -- filled in by the user and that can be jumped between using the tab key. + -- The optional field can be used to provide a placeholder value. + | SChoice Int (NonEmpty Text) + -- ^ Presents a choice between the provided values to the user + | SVariable Text (Maybe SnippetAny) + -- ^ Snippet variable. See the spec for possible values. The optional field + -- can be used to provide a default value for when the variable is not set. + deriving (Eq, Show) + +snippetText :: Text -> Snippet +snippetText = Snippet . L.singleton . SText + +snippetVariable :: Text -> Snippet +snippetVariable n = Snippet . L.singleton $ SVariable n Nothing + +snippetVariableDefault :: Text -> SnippetAny -> Snippet +snippetVariableDefault n d = Snippet . L.singleton . SVariable n $ Just d + +snippetToText :: Snippet -> Text +snippetToText (Snippet l) = foldMap (snippetAnyToText False) l + where + snippetAnyToText isNested = \case + SText t -> sanitizeText isNested t + STabStop i ph -> "${" <> T.pack (show i) <> foldMap (\p -> ":" <> snippetAnyToText True p) ph <> "}" + SChoice i (c :| cs) -> "${" <> T.pack (show i) <> "|" <> c <> foldMap ("," <>) cs <> "}" + SVariable n md -> "${" <> n <> foldMap (\x -> ":" <> snippetAnyToText True x) md <> "}" + sanitizeText isNested = T.foldl' (sanitizeChar isNested) mempty + sanitizeChar isNested t = (t <>) . \case + '$' -> "\\$" + '\\' -> "\\\\" + ',' | isNested -> "\\," + '|' | isNested -> "\\|" + c -> T.singleton c + +snippetLexOrd :: Snippet -> Snippet -> Ordering +snippetLexOrd = compare `on` snippetToText + data CompItem = CI { compKind :: CompletionItemKind - , insertText :: T.Text -- ^ Snippet for the completion + , insertText :: Snippet -- ^ Snippet for the completion , provenance :: Provenance -- ^ From where this item is imported from. , label :: T.Text -- ^ Label to display to the user. , typeText :: Maybe T.Text @@ -178,7 +228,7 @@ parseNs (String "c") = pure dataName parseNs (String "t") = pure tcClsName parseNs (String "z") = pure tvName -parseNs _ = mempty +parseNs _ = mempty instance FromJSON NameDetails where parseJSON v@(Array _) @@ -200,13 +250,13 @@ instance Show NameDetails where show = show . toJSON --- | The data that is acutally sent for resolve support +-- | The data that is actually sent for resolve support -- We need the URI to be able to reconstruct the GHC environment -- in the file the completion was triggered in. data CompletionResolveData = CompletionResolveData - { itemFile :: Uri + { itemFile :: Uri , itemNeedsType :: Bool -- ^ Do we need to lookup a type for this item? - , itemName :: NameDetails + , itemName :: NameDetails } deriving stock Generic deriving anyclass (FromJSON, ToJSON) diff --git a/src/Development/IDE/Plugin/HLS.hs b/src/Development/IDE/Plugin/HLS.hs --- a/src/Development/IDE/Plugin/HLS.hs +++ b/src/Development/IDE/Plugin/HLS.hs @@ -1,79 +1,103 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} module Development.IDE.Plugin.HLS ( asGhcIdePlugin + , toResponseError , Log(..) ) where -import Control.Exception (SomeException) -import Control.Lens ((^.)) +import Control.Exception (SomeException) +import Control.Lens ((^.)) import Control.Monad -import qualified Data.Aeson as J -import Data.Bifunctor (first) -import Data.Dependent.Map (DMap) -import qualified Data.Dependent.Map as DMap +import qualified Control.Monad.Extra as Extra +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Except (runExceptT) +import qualified Data.Aeson as A +import Data.Bifunctor (first) +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum import Data.Either -import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as Map +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import Data.Maybe (isNothing, mapMaybe) import Data.Some import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import Development.IDE.Core.Shake hiding (Log) +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE.Core.PluginUtils (injectServerDiagnostics) +import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing -import Development.IDE.Graph (Rules) +import Development.IDE.Graph (Rules) import Development.IDE.LSP.Server import Development.IDE.Plugin -import qualified Development.IDE.Plugin as P -import Development.IDE.Types.Logger +import qualified Development.IDE.Plugin as P +import Ide.Logger import Ide.Plugin.Config -import Ide.PluginUtils (getClientConfig) -import Ide.Types as HLS -import qualified Language.LSP.Server as LSP -import Language.LSP.Types -import qualified Language.LSP.Types as J -import qualified Language.LSP.Types.Lens as LSP +import Ide.Plugin.Error +import Ide.Plugin.HandleRequestTypes +import Ide.PluginUtils (getClientConfig) +import Ide.Types as HLS +import qualified Language.LSP.Protocol.Lens as JL +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import qualified Language.LSP.Server as LSP import Language.LSP.VFS -import Prettyprinter.Render.String (renderString) -import Text.Regex.TDFA.Text () -import UnliftIO (MonadUnliftIO) -import UnliftIO.Async (forConcurrently) -import UnliftIO.Exception (catchAny) +import Prettyprinter.Render.String (renderString) +import Text.Regex.TDFA.Text () +import UnliftIO (MonadUnliftIO, liftIO, + readTVarIO) +import UnliftIO.Async (forConcurrently) +import UnliftIO.Exception (catchAny) -- --------------------------------------------------------------------- -- data Log - = LogPluginError PluginId ResponseError + = LogPluginError PluginId PluginError + | forall m . A.ToJSON (ErrorData m) => LogResponseError PluginId (TResponseError m) | LogNoPluginForMethod (Some SMethod) | LogInvalidCommandIdentifier + | ExceptionInPlugin PluginId (Some SMethod) SomeException + | LogResolveDefaultHandler (Some SMethod) + instance Pretty Log where pretty = \case - LogPluginError (PluginId pId) err -> pretty pId <> ":" <+> prettyResponseError err + LogPluginError (PluginId pId) err -> + pretty pId <> ":" <+> pretty err + LogResponseError (PluginId pId) err -> + pretty pId <> ":" <+> pretty err LogNoPluginForMethod (Some method) -> - "No plugin enabled for " <> pretty (show method) + "No plugin handles this " <> pretty method <> " request." LogInvalidCommandIdentifier-> "Invalid command identifier" - + ExceptionInPlugin plId (Some method) exception -> + "Exception in plugin " <> viaShow plId <> " while processing " + <> pretty method <> ": " <> viaShow exception + LogResolveDefaultHandler (Some method) -> + "No plugin can handle" <+> pretty method <+> "request. Return object unchanged." instance Show Log where show = renderString . layoutCompact . pretty --- various error message specific builders -prettyResponseError :: ResponseError -> Doc a -prettyResponseError err = errorCode <> ":" <+> errorBody - where - errorCode = pretty $ show $ err ^. LSP.code - errorBody = pretty $ err ^. LSP.message - -pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text -pluginNotEnabled method availPlugins = - "No plugin enabled for " <> T.pack (show method) <> ", available: " - <> (T.intercalate ", " $ map (\(PluginId plid, _, _) -> plid) availPlugins) +noPluginHandles :: Recorder (WithPriority Log) -> SMethod m -> [(PluginId, HandleRequestResult)] -> IO (Either (TResponseError m) c) +noPluginHandles recorder m fs' = do + logWith recorder Warning (LogNoPluginForMethod $ Some m) + let err = TResponseError (InR ErrorCodes_MethodNotFound) msg Nothing + msg = noPluginHandlesMsg m fs' + return $ Left err + where noPluginHandlesMsg :: SMethod m -> [(PluginId, HandleRequestResult)] -> Text + noPluginHandlesMsg method [] = "No plugins are available to handle this " <> T.pack (show method) <> " request." + noPluginHandlesMsg method availPlugins = + "No plugins are available to handle this " <> T.pack (show method) <> " request.\n Plugins installed for this method, but not available to handle this request are:\n" + <> (T.intercalate "\n" $ + map (\(PluginId plid, pluginStatus) -> + plid + <> " " + <> (renderStrict . layoutCompact . pretty) pluginStatus) + availPlugins) pluginDoesntExist :: PluginId -> Text pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist" @@ -86,17 +110,21 @@ failedToParseArgs :: CommandId -- ^ command that failed to parse -> PluginId -- ^ Plugin that created the command -> String -- ^ The JSON Error message - -> J.Value -- ^ The Argument Values + -> A.Value -- ^ The Argument Values -> Text failedToParseArgs (CommandId com) (PluginId pid) err arg = "Error while parsing args for " <> com <> " in plugin " <> pid <> ": " <> T.pack err <> ", arg = " <> T.pack (show arg) +exceptionInPlugin :: PluginId -> SMethod m -> SomeException -> Text +exceptionInPlugin plId method exception = + "Exception in plugin " <> T.pack (show plId) <> " while processing "<> T.pack (show method) <> ": " <> T.pack (show exception) + -- | Build a ResponseError and log it before returning to the caller -logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> ErrorCode -> Text -> LSP.LspT Config IO (Either ResponseError a) +logAndReturnError :: A.ToJSON (ErrorData m) => Recorder (WithPriority Log) -> PluginId -> (LSPErrorCodes |? ErrorCodes) -> Text -> LSP.LspT Config IO (Either (TResponseError m) a) logAndReturnError recorder p errCode msg = do - let err = ResponseError errCode msg Nothing - logWith recorder Warning $ LogPluginError p err + let err = TResponseError errCode msg Nothing + logWith recorder Warning $ LogResponseError p err pure $ Left err -- | Map a set of plugins to the underlying ghcide engine. @@ -146,7 +174,7 @@ executeCommandPlugins recorder ecs = mempty { P.pluginHandlers = executeCommandHandlers recorder ecs } executeCommandHandlers :: Recorder (WithPriority Log) -> [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config) -executeCommandHandlers recorder ecs = requestHandler SWorkspaceExecuteCommand execCmd +executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCommand execCmd where pluginMap = Map.fromListWith (++) ecs @@ -157,53 +185,65 @@ _ -> Nothing -- The parameters to the HLS command are always the first element - - execCmd ide (ExecuteCommandParams _ cmdId args) = do - let cmdParams :: J.Value + execCmd :: IdeState -> ExecuteCommandParams -> LSP.LspT Config IO (Either (TResponseError Method_WorkspaceExecuteCommand) (A.Value |? Null)) + execCmd ide (ExecuteCommandParams mtoken cmdId args) = do + let cmdParams :: A.Value cmdParams = case args of - Just (J.List (x:_)) -> x - _ -> J.Null + Just ((x:_)) -> x + _ -> A.Null case parseCmdId cmdId of -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions Just ("hls", "fallbackCodeAction") -> - case J.fromJSON cmdParams of - J.Success (FallbackCodeActionParams mEdit mCmd) -> do + case A.fromJSON cmdParams of + A.Success (FallbackCodeActionParams mEdit mCmd) -> do -- Send off the workspace request if it has one forM_ mEdit $ \edit -> - LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) case mCmd of -- If we have a command, continue to execute it - Just (J.Command _ innerCmdId innerArgs) + Just (Command _ innerCmdId innerArgs) -> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs) - Nothing -> return $ Right J.Null + -- TODO: This should be a response error? + Nothing -> return $ Right $ InR Null - J.Error _str -> return $ Right J.Null + -- TODO: This should be a response error? + A.Error _str -> return $ Right $ InR Null -- Just an ordinary HIE command - Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams + Just (plugin, cmd) -> runPluginCommand ide plugin cmd mtoken cmdParams -- Couldn't parse the command identifier _ -> do logWith recorder Warning LogInvalidCommandIdentifier - return $ Left $ ResponseError InvalidParams "Invalid command identifier" Nothing + return $ Left $ TResponseError (InR ErrorCodes_InvalidParams) "Invalid command identifier" Nothing - runPluginCommand ide p com arg = + runPluginCommand :: IdeState -> PluginId -> CommandId -> Maybe ProgressToken -> A.Value -> LSP.LspT Config IO (Either (TResponseError Method_WorkspaceExecuteCommand) (A.Value |? Null)) + runPluginCommand ide p com mtoken arg = case Map.lookup p pluginMap of - Nothing -> logAndReturnError recorder p InvalidRequest (pluginDoesntExist p) + Nothing -> logAndReturnError recorder p (InR ErrorCodes_InvalidRequest) (pluginDoesntExist p) Just xs -> case List.find ((com ==) . commandId) xs of - Nothing -> logAndReturnError recorder p InvalidRequest (commandDoesntExist com p xs) - Just (PluginCommand _ _ f) -> case J.fromJSON arg of - J.Error err -> logAndReturnError recorder p InvalidParams (failedToParseArgs com p err arg) - J.Success a -> f ide a + Nothing -> logAndReturnError recorder p (InR ErrorCodes_InvalidRequest) (commandDoesntExist com p xs) + Just (PluginCommand _ _ f) -> case A.fromJSON arg of + A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg) + A.Success a -> do + res <- runHandlerM (runExceptT (f ide mtoken a)) `catchAny` -- See Note [Exception handling in plugins] + (\e -> pure $ Left $ PluginInternalError (exceptionInPlugin p SMethod_WorkspaceExecuteCommand e)) + case res of + (Left (PluginRequestRefused r)) -> + liftIO $ noPluginHandles recorder SMethod_WorkspaceExecuteCommand [(p,DoesNotHandleRequest r)] + (Left pluginErr) -> do + liftIO $ logErrors recorder [(p, pluginErr)] + pure $ Left $ toResponseError (p, pluginErr) + (Right result) -> pure $ Right result -- --------------------------------------------------------------------- extensiblePlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config -extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } +extensiblePlugins recorder plugins = mempty { P.pluginHandlers = handlers } where - IdeHandlers handlers' = foldMap bakePluginId xs + IdeHandlers handlers' = foldMap bakePluginId plugins bakePluginId :: (PluginId, PluginDescriptor IdeState) -> IdeHandlers bakePluginId (pid,pluginDesc) = IdeHandlers $ DMap.map (\(PluginHandler f) -> IdeHandler [(pid,pluginDesc,f pid)]) @@ -212,31 +252,124 @@ PluginHandlers hs = HLS.pluginHandlers pluginDesc handlers = mconcat $ do (IdeMethod m :=> IdeHandler fs') <- DMap.assocs handlers' - pure $ requestHandler m $ \ide params -> do + pure $ requestHandler m $ \ide params' -> do + vfs <- readTVarIO $ vfsVar $ shakeExtras ide + params <- liftIO $ preprocessMessageParams ide m params' config <- Ide.PluginUtils.getClientConfig - -- Only run plugins that are allowed to run on this request - let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs' + -- Only run plugins that are allowed to run on this request, save the + -- list of disabled plugins incase that's all we have + let (fs, dfs) = List.partition (\(_, desc, _) -> handlesRequest vfs m params desc config == HandlesRequest) fs' + let disabledPluginsReason = (\(x, desc, _) -> (x, handlesRequest vfs m params desc config)) <$> dfs -- Clients generally don't display ResponseErrors so instead we log any that we come across + -- However, some clients do display ResponseErrors! See for example the issues: + -- https://github.com/haskell/haskell-language-server/issues/4467 + -- https://github.com/haskell/haskell-language-server/issues/4451 case nonEmpty fs of Nothing -> do - logWith recorder Warning (LogNoPluginForMethod $ Some m) - let err = ResponseError InvalidRequest msg Nothing - msg = pluginNotEnabled m fs' - return $ Left err - Just fs -> do - let msg e pid = "Exception in plugin " <> T.pack (show pid) <> " while processing " <> T.pack (show m) <> ": " <> T.pack (show e) - handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs - es <- runConcurrently msg (show m) handlers ide params - - let (errs,succs) = partitionEithers $ toList $ join $ NE.zipWith (\(pId,_) -> fmap (first (pId,))) handlers es - unless (null errs) $ forM_ errs $ \(pId, err) -> - logWith recorder Warning $ LogPluginError pId err + liftIO (fallbackResolveHandler recorder m params) >>= \case + Nothing -> + liftIO $ noPluginHandles recorder m disabledPluginsReason + Just result -> + pure $ Right result + Just neFs -> do + let plidsAndHandlers = fmap (\(plid,_,handler) -> (plid,handler)) neFs + es <- runHandlerM $ runConcurrently exceptionInPlugin m plidsAndHandlers ide params + caps <- LSP.getClientCapabilities + let (errs,succs) = partitionEithers $ toList $ join $ NE.zipWith (\(pId,_) -> fmap (first (pId,))) plidsAndHandlers es + liftIO $ unless (null errs) $ logErrors recorder errs case nonEmpty succs of - Nothing -> pure $ Left $ combineErrors $ map snd errs + Nothing -> do + let noRefused (_, PluginRequestRefused _) = False + noRefused (_, _) = True + (asErrors, asRefused) = List.partition noRefused errs + convertPRR (pId, PluginRequestRefused r) = Just (pId, DoesNotHandleRequest r) + convertPRR _ = Nothing + asRefusedReason = mapMaybe convertPRR asRefused + case nonEmpty asErrors of + Nothing -> liftIO $ noPluginHandles recorder m (disabledPluginsReason <> asRefusedReason) + Just xs -> pure $ Left $ combineErrors xs Just xs -> do - caps <- LSP.getClientCapabilities pure $ Right $ combineResponses m config caps params xs + +-- | Preprocess 'MessageParams' and insert custom data. +-- +-- In issue https://github.com/haskell/haskell-language-server/issues/4056, we +-- established that HLS should rely on server-side 'Diagnostic's to compute 'CodeAction's +-- To ensure consistency, we intercept 'CodeAction's requests and explicitly inject +-- server-side 'Diagnostic's before delegating to the 'PluginHandler'. +preprocessMessageParams :: IdeState -> SMethod m -> MessageParams m -> IO (MessageParams m) +preprocessMessageParams ide m params = case m of + SMethod_TextDocumentCodeAction -> injectServerDiagnostics ide params + _ -> pure params + +-- | Fallback Handler for resolve requests. +-- For all kinds of `*/resolve` requests, if they don't have a 'data_' value, +-- produce the original item, since no other plugin has any resolve data. +-- +-- This is an internal handler, so it cannot be turned off and should be opaque +-- to the end-user. +-- This function does not take the ServerCapabilities into account, and assumes +-- clients will only send these requests, if and only if the Language Server +-- advertised support for it. +-- +-- See Note [Fallback Handler for LSP resolve requests] for justification and reasoning. +fallbackResolveHandler :: MonadIO m => Recorder (WithPriority Log) -> SMethod s -> MessageParams s -> m (Maybe (MessageResult s)) +fallbackResolveHandler recorder m params = do + let result = case m of + SMethod_InlayHintResolve + | noResolveData params -> Just params + SMethod_CompletionItemResolve + | noResolveData params -> Just params + SMethod_CodeActionResolve + | noResolveData params -> Just params + SMethod_WorkspaceSymbolResolve + | noResolveData params -> Just params + SMethod_CodeLensResolve + | noResolveData params -> Just params + SMethod_DocumentLinkResolve + | noResolveData params -> Just params + _ -> Nothing + logResolveHandling result + pure result + where + noResolveData :: JL.HasData_ p (Maybe a) => p -> Bool + noResolveData p = isNothing $ p ^. JL.data_ + + -- We only log if we are handling the request. + -- If we don't handle this request, this should be logged + -- on call-site. + logResolveHandling p = Extra.whenJust p $ \_ -> do + logWith recorder Debug $ LogResolveDefaultHandler (Some m) + +{- Note [Fallback Handler for LSP resolve requests] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We have a special fallback for `*/resolve` requests. + +We had multiple reports, where `resolve` requests (such as +`completion/resolve` and `codeAction/resolve`) are rejected +by HLS since the `_data_` field of the respective LSP feature has not been +populated by HLS. +This makes sense, as we only support `resolve` for certain kinds of +`CodeAction`/`Completions`, when they contain particularly expensive +properties, such as documentation or non-local type signatures. + +So what to do? We can see two options: + +1. Be dumb and permissive: if no plugin wants to resolve a request, then + just respond positively with the original item! Potentially this masks + real issues, but may not be too bad. If a plugin thinks it can + handle the request but it then fails to resolve it, we should still return a failure. +2. Try and be smart: we try to figure out requests that we're "supposed" to + resolve (e.g. those with a data field), and fail if no plugin wants to handle those. + This is possible since we set data. + So as long as we maintain the invariant that only things which need resolving get + data, then it could be okay. + +In 'fallbackResolveHandler', we implement the option (2). +-} + -- --------------------------------------------------------------------- extensibleNotificationPlugins :: Recorder (WithPriority Log) -> [(PluginId, PluginDescriptor IdeState)] -> Plugin Config @@ -252,43 +385,59 @@ (IdeNotification m :=> IdeNotificationHandler fs') <- DMap.assocs handlers' pure $ notificationHandler m $ \ide vfs params -> do config <- Ide.PluginUtils.getClientConfig - -- Only run plugins that are allowed to run on this request - let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs' + -- Only run plugins that are enabled for this request + let fs = filter (\(_, desc, _) -> handlesRequest vfs m params desc config == HandlesRequest) fs' case nonEmpty fs of Nothing -> do logWith recorder Warning (LogNoPluginForMethod $ Some m) - Just fs -> do + Just neFs -> do -- We run the notifications in order, so the core ghcide provider -- (which restarts the shake process) hopefully comes last - mapM_ (\(pid,_,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params) fs + mapM_ (\(pid,_,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params + `catchAny` -- See Note [Exception handling in plugins] + (\e -> logWith recorder Warning (ExceptionInPlugin pid (Some m) e))) neFs + -- --------------------------------------------------------------------- runConcurrently :: MonadUnliftIO m - => (SomeException -> PluginId -> T.Text) - -> String -- ^ label - -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d))) + => (PluginId -> SMethod method -> SomeException -> T.Text) + -> SMethod method -- ^ Method (used for errors and tracing) + -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either PluginError d))) -- ^ Enabled plugin actions that we are allowed to run -> a -> b - -> m (NonEmpty(NonEmpty (Either ResponseError d))) -runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do - f a b - `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing) + -> m (NonEmpty(NonEmpty (Either PluginError d))) +runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString (show method)) $ do + f a b -- See Note [Exception handling in plugins] + `catchAny` (\e -> pure $ pure $ Left $ PluginInternalError (msg pid method e)) -combineErrors :: [ResponseError] -> ResponseError -combineErrors [x] = x -combineErrors xs = ResponseError InternalError (T.pack (show xs)) Nothing +combineErrors :: NonEmpty (PluginId, PluginError) -> TResponseError m +combineErrors (x NE.:| []) = toResponseError x +combineErrors xs = toResponseError $ NE.last $ NE.sortWith (toPriority . snd) xs +toResponseError :: (PluginId, PluginError) -> TResponseError m +toResponseError (PluginId plId, err) = + TResponseError (toErrorCode err) (plId <> ": " <> tPretty err) Nothing + where tPretty = T.pack . show . pretty + +logErrors :: Recorder (WithPriority Log) -> [(PluginId, PluginError)] -> IO () +logErrors recorder errs = do + forM_ errs $ \(pId, err) -> + logIndividualErrors pId err + where logIndividualErrors plId err = + logWith recorder (toPriority err) $ LogPluginError plId err + + -- | Combine the 'PluginHandler' for all plugins -newtype IdeHandler (m :: J.Method FromClient Request) - = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))] +newtype IdeHandler (m :: Method ClientToServer Request) + = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> HandlerM Config (NonEmpty (Either PluginError (MessageResult m))))] -- | Combine the 'PluginHandler' for all plugins -newtype IdeNotificationHandler (m :: J.Method FromClient Notification) +newtype IdeNotificationHandler (m :: Method ClientToServer Notification) = IdeNotificationHandler [(PluginId, PluginDescriptor IdeState, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())] --- type NotificationHandler (m :: Method FromClient Notification) = MessageParams m -> IO ()` +-- type NotificationHandler (m :: Method ClientToServer Notification) = MessageParams m -> IO ()` -- | Combine the 'PluginHandlers' for all plugins newtype IdeHandlers = IdeHandlers (DMap IdeMethod IdeHandler) @@ -297,13 +446,27 @@ instance Semigroup IdeHandlers where (IdeHandlers a) <> (IdeHandlers b) = IdeHandlers $ DMap.unionWithKey go a b where - go _ (IdeHandler a) (IdeHandler b) = IdeHandler (a <> b) + go _ (IdeHandler c) (IdeHandler d) = IdeHandler (c <> d) instance Monoid IdeHandlers where mempty = IdeHandlers mempty instance Semigroup IdeNotificationHandlers where (IdeNotificationHandlers a) <> (IdeNotificationHandlers b) = IdeNotificationHandlers $ DMap.unionWithKey go a b where - go _ (IdeNotificationHandler a) (IdeNotificationHandler b) = IdeNotificationHandler (a <> b) + go _ (IdeNotificationHandler c) (IdeNotificationHandler d) = IdeNotificationHandler (c <> d) instance Monoid IdeNotificationHandlers where mempty = IdeNotificationHandlers mempty + +{- Note [Exception handling in plugins] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Plugins run in LspM, and so have access to IO. This means they are likely to +throw exceptions, even if only by accident or through calling libraries that +throw exceptions. Ultimately, we're running a bunch of less-trusted IO code, +so we should be robust to it throwing. + +We don't want these to bring down HLS. So we catch and log exceptions wherever +we run a handler defined in a plugin. + +The flip side of this is that it's okay for plugins to throw exceptions as a +way of signalling failure! +-} diff --git a/src/Development/IDE/Plugin/HLS/GhcIde.hs b/src/Development/IDE/Plugin/HLS/GhcIde.hs --- a/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -7,33 +7,35 @@ descriptors , Log(..) ) where -import Control.Monad.IO.Class + import Development.IDE -import Development.IDE.LSP.HoverDefinition +import qualified Development.IDE.LSP.HoverDefinition as Hover import qualified Development.IDE.LSP.Notifications as Notifications import Development.IDE.LSP.Outline import qualified Development.IDE.Plugin.Completions as Completions import qualified Development.IDE.Plugin.TypeLenses as TypeLenses import Ide.Types -import Language.LSP.Server (LspM) -import Language.LSP.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import Text.Regex.TDFA.Text () data Log = LogNotifications Notifications.Log | LogCompletions Completions.Log | LogTypeLenses TypeLenses.Log + | LogHover Hover.Log deriving Show instance Pretty Log where pretty = \case - LogNotifications log -> pretty log - LogCompletions log -> pretty log - LogTypeLenses log -> pretty log + LogNotifications msg -> pretty msg + LogCompletions msg -> pretty msg + LogTypeLenses msg -> pretty msg + LogHover msg -> pretty msg descriptors :: Recorder (WithPriority Log) -> [PluginDescriptor IdeState] descriptors recorder = - [ descriptor "ghcide-hover-and-symbols", + [ descriptor (cmapWithPrio LogHover recorder) "ghcide-hover-and-symbols", Completions.descriptor (cmapWithPrio LogCompletions recorder) "ghcide-completions", TypeLenses.descriptor (cmapWithPrio LogTypeLenses recorder) "ghcide-type-lenses", Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core" @@ -41,31 +43,28 @@ -- --------------------------------------------------------------------- -descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentHover hover' - <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider - <> mkPluginHandler STextDocumentDefinition (\ide _ DefinitionParams{..} -> - gotoDefinition ide TextDocumentPositionParams{..}) - <> mkPluginHandler STextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} -> - gotoTypeDefinition ide TextDocumentPositionParams{..}) - <> mkPluginHandler STextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> - documentHighlight ide TextDocumentPositionParams{..}) - <> mkPluginHandler STextDocumentReferences (\ide _ params -> references ide params) - <> mkPluginHandler SWorkspaceSymbol (\ide _ params -> wsSymbols ide params), +descriptor :: Recorder (WithPriority Hover.Log) -> PluginId -> PluginDescriptor IdeState +descriptor recorder plId = (defaultPluginDescriptor plId desc) + { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover (hover' recorder) + <> mkPluginHandler SMethod_TextDocumentDocumentSymbol moduleOutline + <> mkPluginHandler SMethod_TextDocumentDefinition (\ide _ DefinitionParams{..} -> + Hover.gotoDefinition recorder ide TextDocumentPositionParams{..}) + <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} -> + Hover.gotoTypeDefinition recorder ide TextDocumentPositionParams{..}) + <> mkPluginHandler SMethod_TextDocumentImplementation (\ide _ ImplementationParams{..} -> + Hover.gotoImplementation recorder ide TextDocumentPositionParams{..}) + <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> + Hover.documentHighlight recorder ide TextDocumentPositionParams{..}) + <> mkPluginHandler SMethod_TextDocumentReferences (Hover.references recorder) + <> mkPluginHandler SMethod_WorkspaceSymbol (Hover.wsSymbols recorder), pluginConfigDescriptor = defaultConfigDescriptor } + where + desc = "Provides core IDE features for Haskell" -- --------------------------------------------------------------------- -hover' :: IdeState -> PluginId -> HoverParams -> LspM c (Either ResponseError (Maybe Hover)) -hover' ideState _ HoverParams{..} = do - liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ - hover ideState TextDocumentPositionParams{..} - --- --------------------------------------------------------------------- -symbolsProvider :: IdeState -> PluginId -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation)) -symbolsProvider ide _ params = moduleOutline ide params - --- --------------------------------------------------------------------- +hover' :: Recorder (WithPriority Hover.Log) -> PluginMethodHandler IdeState Method_TextDocumentHover +hover' recorder ideState _ HoverParams{..} = + Hover.hover recorder ideState TextDocumentPositionParams{..} diff --git a/src/Development/IDE/Plugin/Test.hs b/src/Development/IDE/Plugin/Test.hs --- a/src/Development/IDE/Plugin/Test.hs +++ b/src/Development/IDE/Plugin/Test.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PackageImports #-} -{-# LANGUAGE PolyKinds #-} -- | A plugin that adds custom messages for use in tests module Development.IDE.Plugin.Test ( TestRequest(..) @@ -13,15 +12,21 @@ ) where import Control.Concurrent (threadDelay) +import qualified Control.Exception as E import Control.Monad +import Control.Monad.Except (ExceptT (..), throwError) import Control.Monad.IO.Class import Control.Monad.STM -import Data.Aeson -import Data.Aeson.Types +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Data.Aeson (FromJSON (parseJSON), + ToJSON (toJSON), Value) +import qualified Data.Aeson.Types as A import Data.Bifunctor import Data.CaseInsensitive (CI, original) import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as Set import Data.Maybe (isJust) +import Data.Proxy import Data.String import Data.Text (Text, pack) import Development.IDE.Core.OfInterest (getFilesOfInterest) @@ -38,14 +43,16 @@ import Development.IDE.Graph.Internal.Types (Result (resultBuilt, resultChanged, resultVisited), Step (Step)) import qualified Development.IDE.Graph.Internal.Types as Graph +import Development.IDE.Session (clearSessionLoaderPendingBarrier, + setSessionLoaderPendingBarrier) import Development.IDE.Types.Action import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) import Development.IDE.Types.Location (fromUri) import GHC.Generics (Generic) -import Ide.Plugin.Config (CheckParents) +import Ide.Plugin.Error import Ide.Types -import qualified Language.LSP.Server as LSP -import Language.LSP.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import qualified "list-t" ListT import qualified StmContainers.Map as STM import System.Time.Extra @@ -57,6 +64,7 @@ | GetShakeSessionQueueCount -- ^ :: Number | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null | WaitForIdeRule String Uri -- ^ :: WaitForIdeRuleResult + | WaitForIdeRules String [Uri] -- ^ :: [WaitForIdeRuleResult] | GetBuildKeysVisited -- ^ :: [(String] | GetBuildKeysBuilt -- ^ :: [(String] | GetBuildKeysChanged -- ^ :: [(String] @@ -72,27 +80,27 @@ deriving newtype (FromJSON, ToJSON) plugin :: PluginDescriptor IdeState -plugin = (defaultPluginDescriptor "test") { - pluginHandlers = mkPluginHandler (SCustomMethod "test") $ \st _ -> +plugin = (defaultPluginDescriptor "test" "") { + pluginHandlers = mkPluginHandler (SMethod_CustomMethod (Proxy @"test")) $ \st _ -> testRequestHandler' st } where testRequestHandler' ide req - | Just customReq <- parseMaybe parseJSON req - = testRequestHandler ide customReq + | Just customReq <- A.parseMaybe parseJSON req + = ExceptT $ testRequestHandler ide customReq | otherwise - = return $ Left - $ ResponseError InvalidRequest "Cannot parse request" Nothing + = throwError + $ PluginInvalidParams "Cannot parse request" testRequestHandler :: IdeState -> TestRequest - -> LSP.LspM c (Either ResponseError Value) + -> HandlerM config (Either PluginError Value) testRequestHandler _ (BlockSeconds secs) = do - LSP.sendNotification (SCustomMethod "ghcide/blocking/request") $ + pluginSendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/request")) $ toJSON secs liftIO $ sleep secs - return (Right Null) + return (Right A.Null) testRequestHandler s (GetInterfaceFilesDir file) = liftIO $ do let nfp = fromUri $ toNormalizedUri file sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp @@ -105,12 +113,23 @@ atomically $ do n <- countQueue $ actionQueue $ shakeExtras s when (n>0) retry - return $ Right Null + return $ Right A.Null testRequestHandler s (WaitForIdeRule k file) = liftIO $ do let nfp = fromUri $ toNormalizedUri file success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp let res = WaitForIdeRuleResult <$> success - return $ bimap mkResponseError toJSON res + return $ bimap PluginInvalidParams toJSON res +testRequestHandler s (WaitForIdeRules k files) = liftIO $ do + let nfps = fmap (fromUri . toNormalizedUri) files + uniqueCount = Set.size (Set.fromList nfps) + act = runAction ("WaitForIdeRules " <> k <> " " <> show files) s $ parseActions (fromString k) nfps + success <- + if uniqueCount > 0 + then (setSessionLoaderPendingBarrier s uniqueCount >> act) + `E.finally` clearSessionLoaderPendingBarrier s + else act + let res = fmap (fmap WaitForIdeRuleResult) success + return $ bimap PluginInvalidParams toJSON res testRequestHandler s GetBuildKeysBuilt = liftIO $ do keys <- getDatabaseKeys resultBuilt $ shakeDb s return $ Right $ toJSON $ map show keys @@ -144,9 +163,6 @@ step <- shakeGetBuildStep db return [ k | (k, res) <- keys, field res == Step step] -mkResponseError :: Text -> ResponseError -mkResponseError msg = ResponseError InvalidRequest msg Nothing - parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool) parseAction "typecheck" fp = Right . isJust <$> use TypeCheck fp parseAction "getLocatedImports" fp = Right . isJust <$> use GetLocatedImports fp @@ -159,17 +175,29 @@ parseAction "getFileContents" fp = Right . isJust <$> use GetFileContents fp parseAction other _ = return $ Left $ "Cannot parse ide rule: " <> pack (original other) +parseActions :: CI String -> [NormalizedFilePath] -> Action (Either Text [Bool]) +parseActions "typecheck" fps = Right . fmap isJust <$> uses TypeCheck fps +parseActions "getLocatedImports" fps = Right . fmap isJust <$> uses GetLocatedImports fps +parseActions "getmodsummary" fps = Right . fmap isJust <$> uses GetModSummary fps +parseActions "getmodsummarywithouttimestamps" fps = Right . fmap isJust <$> uses GetModSummaryWithoutTimestamps fps +parseActions "getparsedmodule" fps = Right . fmap isJust <$> uses GetParsedModule fps +parseActions "ghcsession" fps = Right . fmap isJust <$> uses GhcSession fps +parseActions "ghcsessiondeps" fps = Right . fmap isJust <$> uses GhcSessionDeps fps +parseActions "gethieast" fps = Right . fmap isJust <$> uses GetHieAst fps +parseActions "getFileContents" fps = Right . fmap isJust <$> uses GetFileContents fps +parseActions other _ = return $ Left $ "Cannot parse ide rule: " <> pack (original other) + -- | a command that blocks forever. Used for testing blockCommandId :: Text blockCommandId = "ghcide.command.block" blockCommandDescriptor :: PluginId -> PluginDescriptor state -blockCommandDescriptor plId = (defaultPluginDescriptor plId) { +blockCommandDescriptor plId = (defaultPluginDescriptor plId "") { pluginCommands = [PluginCommand (CommandId blockCommandId) "blocks forever" blockCommandHandler] } blockCommandHandler :: CommandFunction state ExecuteCommandParams -blockCommandHandler _ideState _params = do - LSP.sendNotification (SCustomMethod "ghcide/blocking/command") Null +blockCommandHandler _ideState _ _params = do + lift $ pluginSendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) A.Null liftIO $ threadDelay maxBound - return (Right Null) + pure $ InR Null diff --git a/src/Development/IDE/Plugin/TypeLenses.hs b/src/Development/IDE/Plugin/TypeLenses.hs --- a/src/Development/IDE/Plugin/TypeLenses.hs +++ b/src/Development/IDE/Plugin/TypeLenses.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies #-} @@ -13,85 +14,106 @@ Log(..) ) where -import Control.Concurrent.STM.Stats (atomically) -import Control.DeepSeq (rwhnf) -import Control.Monad (mzero) -import Control.Monad.Extra (whenMaybe) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Aeson.Types (Value (..), toJSON) -import qualified Data.Aeson.Types as A -import qualified Data.HashMap.Strict as Map -import Data.List (find) -import Data.Maybe (catMaybes) -import qualified Data.Text as T -import Development.IDE (GhcSession (..), - HscEnvEq (hscEnv), - RuleResult, Rules, define, - srcSpanToRange, - usePropertyAction) -import Development.IDE.Core.Compile (TcModuleResult (..)) -import Development.IDE.Core.Rules (IdeState, runAction) -import Development.IDE.Core.RuleTypes (GetBindings (GetBindings), - TypeCheck (TypeCheck)) -import Development.IDE.Core.Service (getDiagnostics) -import Development.IDE.Core.Shake (getHiddenDiagnostics, use) -import qualified Development.IDE.Core.Shake as Shake +import Control.Concurrent.STM.Stats (atomically) +import Control.DeepSeq (rwhnf) +import Control.Lens ((?~), (^?)) +import Control.Monad (mzero) +import Control.Monad.Extra (whenMaybe) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Data.Aeson.Types (toJSON) +import qualified Data.Aeson.Types as A +import Data.List (find) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, isJust, + maybeToList) +import qualified Data.Text as T +import Development.IDE (FileDiagnostic (..), + GhcSession (..), + HscEnvEq (hscEnv), + RuleResult, Rules, Uri, + _SomeStructuredMessage, + define, + fdStructuredMessageL, + srcSpanToRange, + usePropertyAction) +import Development.IDE.Core.Compile (TcModuleResult (..)) +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.PositionMapping (PositionMapping, + fromCurrentRange, + toCurrentRange) +import Development.IDE.Core.Rules (IdeState, runAction) +import Development.IDE.Core.RuleTypes (TypeCheck (TypeCheck)) +import Development.IDE.Core.Service (getDiagnostics) +import Development.IDE.Core.Shake (getHiddenDiagnostics, + use) +import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat -import Development.IDE.GHC.Util (printName) +import Development.IDE.GHC.Compat.Error (_TcRnMessage, + _TcRnMissingSignature, + msgEnvelopeErrorL) +import Development.IDE.GHC.Util (printName) import Development.IDE.Graph.Classes -import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope) -import Development.IDE.Types.Location (Position (Position, _character, _line), - Range (Range, _end, _start), - toNormalizedFilePath', - uriToFilePath') -import Development.IDE.Types.Logger (Pretty (pretty), Recorder, - WithPriority, - cmapWithPrio) -import GHC.Generics (Generic) -import Ide.Plugin.Config (Config) +import Development.IDE.Types.Location (Position (Position, _line), + Range (Range, _end, _start)) +import GHC.Core.TyCo.Tidy (tidyOpenType) +import GHC.Generics (Generic) +import Ide.Logger (Pretty (pretty), + Recorder, WithPriority, + cmapWithPrio) +import Ide.Plugin.Error import Ide.Plugin.Properties -import Ide.PluginUtils (mkLspCommand) -import Ide.Types (CommandFunction, - CommandId (CommandId), - PluginCommand (PluginCommand), - PluginDescriptor (..), - PluginId, - configCustomConfig, - defaultConfigDescriptor, - defaultPluginDescriptor, - mkCustomConfig, - mkPluginHandler) -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), - CodeLens (CodeLens), - CodeLensParams (CodeLensParams, _textDocument), - Diagnostic (..), - List (..), ResponseError, - SMethod (..), - TextDocumentIdentifier (TextDocumentIdentifier), - TextEdit (TextEdit), - WorkspaceEdit (WorkspaceEdit)) -import Text.Regex.TDFA ((=~), (=~~)) +import Ide.PluginUtils (mkLspCommand) +import Ide.Types (CommandFunction, + CommandId (CommandId), + PluginCommand (PluginCommand), + PluginDescriptor (..), + PluginId, + PluginMethodHandler, + ResolveFunction, + configCustomConfig, + defaultConfigDescriptor, + defaultPluginDescriptor, + mkCustomConfig, + mkPluginHandler, + mkResolveHandler, + pluginSendRequest) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (Method (Method_CodeLensResolve, Method_TextDocumentCodeLens), + SMethod (..)) +import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), + CodeLens (..), + CodeLensParams (CodeLensParams, _textDocument), + Command, Diagnostic (..), + Null (Null), + TextDocumentIdentifier (TextDocumentIdentifier), + TextEdit (TextEdit), + WorkspaceEdit (WorkspaceEdit), + type (|?) (..)) data Log = LogShake Shake.Log deriving Show instance Pretty Log where pretty = \case - LogShake log -> pretty log + LogShake msg -> pretty msg + typeLensCommandId :: T.Text typeLensCommandId = "typesignature.add" descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = - (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider + (defaultPluginDescriptor plId desc) + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens codeLensProvider + <> mkResolveHandler SMethod_CodeLensResolve codeLensResolveProvider , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] , pluginRules = rules recorder , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} } + where + desc = "Provides code lenses type signatures" -properties :: Properties '[ 'PropertyKey "mode" ('TEnum Mode)] +properties :: Properties '[ 'PropertyKey "mode" (TEnum Mode)] properties = emptyProperties & defineEnumProperty #mode "Control how type lenses are shown" [ (Always, "Always displays type lenses of global bindings") @@ -99,109 +121,148 @@ , (Diagnostics, "Follows error messages produced by GHC about missing signatures") ] Always -codeLensProvider :: - IdeState -> - PluginId -> - CodeLensParams -> - LSP.LspM Config (Either ResponseError (List CodeLens)) +codeLensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do - mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties - fmap (Right . List) $ case uriToFilePath' uri of - Just (toNormalizedFilePath' -> filePath) -> liftIO $ do - env <- fmap hscEnv <$> runAction "codeLens.GhcSession" ideState (use GhcSession filePath) - tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath) - bindings <- runAction "codeLens.GetBindings" ideState (use GetBindings filePath) - gblSigs <- runAction "codeLens.GetGlobalBindingTypeSigs" ideState (use GetGlobalBindingTypeSigs filePath) - - diag <- atomically $ getDiagnostics ideState - hDiag <- atomically $ getHiddenDiagnostics ideState - - let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing - generateLensForGlobal sig@GlobalBindingTypeSig{..} = do - range <- srcSpanToRange $ gbSrcSpan sig - tedit <- gblBindingTypeSigToEdit sig - let wedit = toWorkSpaceEdit [tedit] - pure $ generateLens pId range (T.pack gbRendered) wedit - gblSigs' = maybe [] (\(GlobalBindingTypeSigsResult x) -> x) gblSigs - generateLensFromDiags f = - sequence - [ pure $ generateLens pId _range title edit - | (dFile, _, dDiag@Diagnostic{_range = _range}) <- diag ++ hDiag - , dFile == filePath - , (title, tedit) <- f dDiag - , let edit = toWorkSpaceEdit tedit - ] + mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties + nfp <- getNormalizedFilePathE uri + -- We have two ways we can possibly generate code lenses for type lenses. + -- Different options are with different "modes" of the type-lenses plugin. + -- (Remember here, as the code lens is not resolved yet, we only really need + -- the range and any data that will help us resolve it later) + let -- The first option is to generate lens from diagnostics about + -- top level bindings. + generateLensFromGlobalDiags diags = + -- We don't actually pass any data to resolve, however we need this + -- dummy type to make sure HLS resolves our lens + [ CodeLens _range Nothing (Just $ toJSON TypeLensesResolve) + | diag <- diags + , let Diagnostic {_range} = fdLspDiagnostic diag + , fdFilePath diag == nfp + , isGlobalDiagnostic diag] + -- The second option is to generate lenses from the GlobalBindingTypeSig + -- rule. This is the only type that needs to have the range adjusted + -- with PositionMapping. + -- PositionMapping for diagnostics doesn't make sense, because we always + -- have fresh diagnostics even if current module parsed failed (the + -- diagnostic would then be parse failed). See + -- https://github.com/haskell/haskell-language-server/pull/3558 for this + -- discussion. + generateLensFromGlobal sigs mp = do + [ CodeLens newRange Nothing (Just $ toJSON TypeLensesResolve) + | sig <- sigs + , Just range <- [srcSpanToRange (gbSrcSpan sig)] + , Just newRange <- [toCurrentRange mp range]] + if mode == Always || mode == Exported + then do + -- In this mode we get the global bindings from the + -- GlobalBindingTypeSigs rule. + (GlobalBindingTypeSigsResult gblSigs, gblSigsMp) <- + runActionE "codeLens.GetGlobalBindingTypeSigs" ideState + $ useWithStaleE GetGlobalBindingTypeSigs nfp + -- Depending on whether we only want exported or not we filter our list + -- of signatures to get what we want + let relevantGlobalSigs = + if mode == Exported + then filter gbExported gblSigs + else gblSigs + pure $ InL $ generateLensFromGlobal relevantGlobalSigs gblSigsMp + else do + -- For this mode we exclusively use diagnostics to create the lenses. + -- However we will still use the GlobalBindingTypeSigs to resolve them. + diags <- liftIO $ atomically $ getDiagnostics ideState + hDiags <- liftIO $ atomically $ getHiddenDiagnostics ideState + let allDiags = diags <> hDiags + pure $ InL $ generateLensFromGlobalDiags allDiags - case mode of - Always -> - pure (catMaybes $ generateLensForGlobal <$> gblSigs') - <> generateLensFromDiags (suggestLocalSignature False env tmr bindings) -- we still need diagnostics for local bindings - Exported -> pure $ catMaybes $ generateLensForGlobal <$> filter gbExported gblSigs' - Diagnostics -> generateLensFromDiags $ suggestSignature False env gblSigs tmr bindings - Nothing -> pure [] +codeLensResolveProvider :: ResolveFunction IdeState TypeLensesResolve Method_CodeLensResolve +codeLensResolveProvider ideState pId lens@CodeLens{_range} uri TypeLensesResolve = do + nfp <- getNormalizedFilePathE uri + (gblSigs@(GlobalBindingTypeSigsResult _), pm) <- + runActionE "codeLens.GetGlobalBindingTypeSigs" ideState + $ useWithStaleE GetGlobalBindingTypeSigs nfp + -- regardless of how the original lens was generated, we want to get the range + -- that the global bindings rule would expect here, hence the need to reverse + -- position map the range, regardless of whether it was position mapped in the + -- beginning or freshly taken from diagnostics. + newRange <- handleMaybe PluginStaleResolve (fromCurrentRange pm _range) + -- We also pass on the PositionMapping so that the generated text edit can + -- have the range adjusted. + (title, edit) <- + handleMaybe PluginStaleResolve $ suggestGlobalSignature' False (Just gblSigs) (Just pm) newRange + pure $ lens & L.command ?~ generateLensCommand pId uri title edit -generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens -generateLens pId _range title edit = - let cId = mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit]) - in CodeLens _range (Just cId) Nothing +generateLensCommand :: PluginId -> Uri -> T.Text -> TextEdit -> Command +generateLensCommand pId uri title edit = + let wEdit = WorkspaceEdit (Just $ Map.singleton uri [edit]) Nothing Nothing + in mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON wEdit]) +-- Since the lenses are created with diagnostics, and since the globalTypeSig +-- rule can't be changed as it is also used by the hls-refactor plugin, we can't +-- rely on actions. Because we can't rely on actions it doesn't make sense to +-- recompute the edit upon command. Hence the command here just takes a edit +-- and applies it. commandHandler :: CommandFunction IdeState WorkspaceEdit -commandHandler _ideState wedit = do - _ <- LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return $ Right Null +commandHandler _ideState _ wedit = do + _ <- lift $ pluginSendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + pure $ InR Null -------------------------------------------------------------------------------- +suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> FileDiagnostic -> [(T.Text, TextEdit)] +suggestSignature isQuickFix mGblSigs diag = + maybeToList (suggestGlobalSignature isQuickFix mGblSigs diag) -suggestSignature :: Bool -> Maybe HscEnv -> Maybe GlobalBindingTypeSigsResult -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] -suggestSignature isQuickFix env mGblSigs mTmr mBindings diag = - suggestGlobalSignature isQuickFix mGblSigs diag <> suggestLocalSignature isQuickFix env mTmr mBindings diag +-- The suggestGlobalSignature is separated into two functions. The main function +-- works with a diagnostic, which then calls the secondary function with +-- whatever pieces of the diagnostic it needs. This allows the resolve function, +-- which no longer has the Diagnostic, to still call the secondary functions. +suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> FileDiagnostic -> Maybe (T.Text, TextEdit) +suggestGlobalSignature isQuickFix mGblSigs diag@FileDiagnostic {fdLspDiagnostic = Diagnostic {_range}} + | isGlobalDiagnostic diag = + suggestGlobalSignature' isQuickFix mGblSigs Nothing _range + | otherwise = Nothing -suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, [TextEdit])] -suggestGlobalSignature isQuickFix mGblSigs Diagnostic{_message, _range} - | _message - =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text) - , Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs - , Just sig <- find (\x -> sameThing (gbSrcSpan x) _range) sigs - , signature <- T.pack $ gbRendered sig - , title <- if isQuickFix then "add signature: " <> signature else signature - , Just action <- gblBindingTypeSigToEdit sig = - [(title, [action])] - | otherwise = [] +isGlobalDiagnostic :: FileDiagnostic -> Bool +isGlobalDiagnostic diag = diag ^? fdStructuredMessageL + . _SomeStructuredMessage + . msgEnvelopeErrorL + . _TcRnMessage + . _TcRnMissingSignature + & isJust -suggestLocalSignature :: Bool -> Maybe HscEnv -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] -suggestLocalSignature isQuickFix mEnv mTmr mBindings Diagnostic{_message, _range = _range@Range{..}} - | Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier]) <- - (T.unwords . T.words $ _message) - =~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text) - , Just bindings <- mBindings - , Just env <- mEnv - , localScope <- getFuzzyScope bindings _start _end - , -- we can't use srcspan to lookup scoped bindings, because the error message reported by GHC includes the entire binding, instead of simply the name - Just (name, ty) <- find (\(x, _) -> printName x == T.unpack identifier) localScope >>= \(name, mTy) -> (name,) <$> mTy - , Just TcModuleResult{tmrTypechecked = TcGblEnv{tcg_rdr_env, tcg_sigs}} <- mTmr - , -- not a top-level thing, to avoid duplication - not $ name `elemNameSet` tcg_sigs - , tyMsg <- printSDocQualifiedUnsafe (mkPrintUnqualifiedDefault env tcg_rdr_env) $ pprSigmaType ty - , signature <- T.pack $ printName name <> " :: " <> tyMsg - , startCharacter <- _character _start - , startOfLine <- Position (_line _start) startCharacter - , beforeLine <- Range startOfLine startOfLine +-- If a PositionMapping is supplied, this function will call +-- gblBindingTypeSigToEdit with it to create a TextEdit in the right location. +suggestGlobalSignature' :: Bool -> Maybe GlobalBindingTypeSigsResult -> Maybe PositionMapping -> Range -> Maybe (T.Text, TextEdit) +suggestGlobalSignature' isQuickFix mGblSigs pm range + | Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs + , Just sig <- find (\x -> sameThing (gbSrcSpan x) range) sigs + , signature <- T.pack $ gbRendered sig , title <- if isQuickFix then "add signature: " <> signature else signature - , action <- TextEdit beforeLine $ signature <> "\n" <> T.replicate (fromIntegral startCharacter) " " = - [(title, [action])] - | otherwise = [] + , Just action <- gblBindingTypeSigToEdit sig pm = + Just (title, action) + | otherwise = Nothing sameThing :: SrcSpan -> Range -> Bool sameThing s1 s2 = (_start <$> srcSpanToRange s1) == (_start <$> Just s2) -gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe TextEdit -gblBindingTypeSigToEdit GlobalBindingTypeSig{..} +gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe PositionMapping -> Maybe TextEdit +gblBindingTypeSigToEdit GlobalBindingTypeSig{..} mmp | Just Range{..} <- srcSpanToRange $ getSrcSpan gbName , startOfLine <- Position (_line _start) 0 - , beforeLine <- Range startOfLine startOfLine = - Just $ TextEdit beforeLine $ T.pack gbRendered <> "\n" + , beforeLine <- Range startOfLine startOfLine + -- If `mmp` is `Nothing`, return the original range, + -- otherwise we apply `toCurrentRange`, and the guard should fail if `toCurrentRange` failed. + , Just range <- maybe (Just beforeLine) (flip toCurrentRange beforeLine) mmp + -- We need to flatten the signature, as otherwise long signatures are + -- rendered on multiple lines with invalid formatting. + , renderedFlat <- unwords $ lines gbRendered + = Just $ TextEdit range $ T.pack renderedFlat <> "\n" | otherwise = Nothing +-- |We don't need anything to resolve our lens, but a data field is mandatory +-- to get types resolved in HLS +data TypeLensesResolve = TypeLensesResolve + deriving (Generic, A.FromJSON, A.ToJSON) + data Mode = -- | always displays type lenses of global bindings, no matter what GHC flags are set Always @@ -269,11 +330,15 @@ showDoc = showDocRdrEnv hsc rdrEnv hasSig :: (Monad m) => Name -> m a -> m (Maybe a) hasSig name f = whenMaybe (name `elemNameSet` sigs) f - bindToSig id = do - let name = idName id + bindToSig identifier = liftZonkM $ do + let name = idName identifier hasSig name $ do env <- tcInitTidyEnv - let (_, ty) = tidyOpenType env (idType id) +#if MIN_VERSION_ghc(9,11,0) + let ty = tidyOpenType env (idType identifier) +#else + let (_, ty) = tidyOpenType env (idType identifier) +#endif pure $ GlobalBindingTypeSig name (printName name <> " :: " <> showDoc (pprSigmaType ty)) (name `elemNameSet` exports) patToSig p = do let name = patSynName p diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/src/Development/IDE/Spans/AtPoint.hs @@ -1,9 +1,8 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} -- | Gives information about symbols at a given point in DAML files. -- These are all pure functions that should execute quickly. @@ -11,6 +10,7 @@ atPoint , gotoDefinition , gotoTypeDefinition + , gotoImplementation , documentHighlight , pointCommand , referencesAtPoint @@ -20,23 +20,32 @@ , getNamesAtPoint , toCurrentLocation , rowToLoc + , nameToLocation + , LookupModule ) where + +import GHC.Data.FastString (lengthFS) +import qualified GHC.Utils.Outputable as O + import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans () import Development.IDE.Types.Location -import Language.LSP.Types +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..)) +import Prelude hiding (mod) -- compiler and infrastructure +import Development.IDE.Core.Compile (setNonHomeFCHook) import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util as Util -import Development.IDE.GHC.Util (printOutputable) +import Development.IDE.GHC.Util (printOutputable, + printOutputableOneLine) import Development.IDE.Spans.Common import Development.IDE.Types.Options -import Control.Applicative import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Class @@ -49,18 +58,45 @@ import qualified Data.Array as A import Data.Either -import Data.List (isSuffixOf) import Data.List.Extra (dropEnd1, nubOrd) + +import Control.Lens ((^.)) +import Data.Either.Extra (eitherToMaybe) +import Data.List (isSuffixOf, sortOn) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Tree +import qualified Data.Tree as T import Data.Version (showVersion) +import Development.IDE.Core.LookupMod (LookupModule, lookupMod) +import Development.IDE.Core.Shake (ShakeExtras (..), + runIdeAction) import Development.IDE.Types.Shake (WithHieDb) -import HieDb hiding (pointCommand) +import GHC.Iface.Ext.Types (EvVarSource (..), + HieAST (..), + HieASTs (..), + HieArgs (..), + HieType (..), + HieTypeFix (..), + Identifier, + IdentifierDetails (..), + NodeInfo (..), Scope, + Span) +import GHC.Iface.Ext.Utils (EvidenceInfo (..), + RefMap, getEvidenceTree, + getScopeFromContext, + hieTypeToIface, + isEvidenceContext, + isEvidenceUse, + isOccurrence, nodeInfo, + recoverFullType, + selectSmallestContaining) +import HieDb hiding (pointCommand, + withHieDb) +import qualified Language.LSP.Protocol.Lens as L import System.Directory (doesFileExist) --- | Gives a Uri for the module, given the .hie file location and the the module info --- The Bool denotes if it is a boot module -type LookupModule m = FilePath -> ModuleName -> Unit -> Bool -> MaybeT m Uri - -- | HieFileResult for files of interest, along with the position mappings newtype FOIReferences = FOIReferences (HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping)) @@ -89,17 +125,17 @@ Just (HAR _ hf _ _ _,mapping) -> let names = getNamesAtPoint hf pos mapping adjustedLocs = HM.foldr go [] asts - go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs + go (HAR _ _ rf tr _, goMapping) xs = refs ++ typerefs ++ xs where - refs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation . fst) - $ concat $ mapMaybe (\n -> M.lookup (Right n) rf) names - typerefs = mapMaybe (toCurrentLocation mapping . realSrcSpanToLocation) - $ concat $ mapMaybe (`M.lookup` tr) names + refs = concatMap (mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation . fst)) + (mapMaybe (\n -> M.lookup (Right n) rf) names) + typerefs = concatMap (mapMaybe (toCurrentLocation goMapping . realSrcSpanToLocation)) + (mapMaybe (`M.lookup` tr) names) in (names, adjustedLocs,map fromNormalizedFilePath $ HM.keys asts) getNamesAtPoint :: HieASTs a -> Position -> PositionMapping -> [Name] getNamesAtPoint hf pos mapping = - concat $ pointCommand hf posFile (rights . M.keys . getNodeIds) + concat $ pointCommand hf posFile (rights . M.keys . getSourceNodeIds) where posFile = fromMaybe pos $ fromCurrentPosition mapping pos @@ -129,8 +165,8 @@ typeRefs <- forM names $ \name -> case nameModule_maybe name of Just mod | isTcClsNameSpace (occNameSpace $ nameOccName name) -> do - refs <- liftIO $ withHieDb (\hieDb -> findTypeRefs hieDb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude) - pure $ mapMaybe typeRowToLoc refs + refs' <- liftIO $ withHieDb (\hieDb -> findTypeRefs hieDb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude) + pure $ mapMaybe typeRowToLoc refs' _ -> pure [] pure $ nubOrd $ foiRefs ++ concat nonFOIRefs ++ concat typeRefs @@ -161,24 +197,25 @@ -> MaybeT m [DocumentHighlight] documentHighlight hf rf pos = pure highlights where -#if MIN_VERSION_ghc(9,0,1) -- We don't want to show document highlights for evidence variables, which are supposed to be invisible notEvidence = not . any isEvidenceContext . identInfo -#else - notEvidence = const True -#endif - ns = concat $ pointCommand hf pos (rights . M.keys . M.filter notEvidence . getNodeIds) + ns = concat $ pointCommand hf pos (rights . M.keys . M.filter notEvidence . getSourceNodeIds) highlights = do n <- ns ref <- fromMaybe [] (M.lookup (Right n) rf) - pure $ makeHighlight ref - makeHighlight (sp,dets) = - DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets) + maybeToList (makeHighlight n ref) + makeHighlight n (sp,dets) + | isTvNameSpace (nameNameSpace n) && isBadSpan n sp = Nothing + | otherwise = Just $ DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets) highlightType s = if any (isJust . getScopeFromContext) s - then HkWrite - else HkRead + then DocumentHighlightKind_Write + else DocumentHighlightKind_Read + isBadSpan :: Name -> RealSrcSpan -> Bool + isBadSpan n sp = srcSpanStartLine sp /= srcSpanEndLine sp || (srcSpanEndCol sp - srcSpanStartCol sp > lengthFS (occNameFS $ nameOccName n)) + +-- | Locate the type definition of the name at a given position. gotoTypeDefinition :: MonadIO m => WithHieDb @@ -186,7 +223,7 @@ -> IdeOptions -> HieAstResult -> Position - -> MaybeT m [Location] + -> MaybeT m [(Location, Identifier)] gotoTypeDefinition withHieDb lookupModule ideOpts srcSpans pos = lift $ typeLocationsAtPoint withHieDb lookupModule ideOpts pos srcSpans @@ -197,63 +234,203 @@ -> LookupModule m -> IdeOptions -> M.Map ModuleName NormalizedFilePath - -> HieASTs a + -> HieAstResult -> Position - -> MaybeT m [Location] + -> MaybeT m [(Location, Identifier)] gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos = lift $ locationsAtPoint withHieDb getHieFile ideOpts imports pos srcSpans +-- | Locate the implementation definition of the name at a given position. +-- Goto Implementation for an overloaded function. +gotoImplementation + :: MonadIO m + => WithHieDb + -> LookupModule m + -> IdeOptions + -> HieAstResult + -> Position + -> MaybeT m [Location] +gotoImplementation withHieDb getHieFile ideOpts srcSpans pos + = lift $ instanceLocationsAtPoint withHieDb getHieFile ideOpts pos srcSpans + -- | Synopsis for the name at a given position. atPoint :: IdeOptions + -> ShakeExtras -> HieAstResult - -> DocAndKindMap + -> DocAndTyThingMap -> HscEnv -> Position - -> Maybe (Maybe Range, [T.Text]) -atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ pointCommand hf pos hoverInfo + -> Util.EnumSet Extension + -> IO (Maybe (Maybe Range, [T.Text])) +atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@(HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km _am) env pos enabledExtensions = + listToMaybe <$> sequence (pointCommand hf pos hoverInfo) where -- Hover info for values/data - hoverInfo ast = (Just range, prettyNames ++ pTypes) + hoverInfo :: HieAST hietype -> IO (Maybe Range, [T.Text]) + hoverInfo ast = do + locationsWithIdentifier <- runIdeAction "TypeCheck" shakeExtras $ do + runMaybeT $ gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts har pos + + let locationsMap = M.fromList $ mapMaybe (\(loc, identifier) -> case identifier of + Right typeName -> + -- Filter out type variables (polymorphic names like 'a', 'b', etc.) + if isTyVarName typeName + then Nothing + else Just (typeName, loc) + Left _moduleName -> Nothing) $ fromMaybe [] locationsWithIdentifier + + prettyNames <- mapM (prettyName locationsMap) names + pure (Just range, prettyNames ++ pTypes locationsMap) where - pTypes - | Prelude.length names == 1 = dropEnd1 $ map wrapHaskell prettyTypes - | otherwise = map wrapHaskell prettyTypes + pTypes :: M.Map Name Location -> [T.Text] + pTypes locationsMap = + case names of + [_singleName] -> dropEnd1 $ prettyTypes Nothing locationsMap + _ -> prettyTypes Nothing locationsMap + range :: Range range = realSrcSpanToRange $ nodeSpan ast - wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n" + info :: NodeInfo hietype info = nodeInfoH kind ast - names = M.assocs $ nodeIdentifiers info - types = nodeType info - prettyNames :: [T.Text] - prettyNames = map prettyName names - prettyName (Right n, dets) = T.unlines $ - wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) - : maybeToList (pretty (definedAt n) (prettyPackageName n)) - ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n - ] - where maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n + -- We want evidence variables to be displayed last. + -- Evidence trees contain information of secondary relevance. + names :: [(Identifier, IdentifierDetails hietype)] + names = sortOn (any isEvidenceUse . identInfo . snd) $ M.assocs $ nodeIdentifiers info + + prettyName :: M.Map Name Location -> (Either ModuleName Name, IdentifierDetails hietype) -> IO T.Text + prettyName locationsMap (Right n, dets) + -- We want to print evidence variable using a readable tree structure. + -- Evidence variables contain information why a particular instance or + -- type equality was chosen, paired with location information. + | any isEvidenceUse (identInfo dets) = + let + -- The evidence tree may not be present for some reason, e.g., the 'Name' is not + -- present in the tree. + -- Thus, we need to handle it here, but in practice, this should never be 'Nothing'. + evidenceTree = maybe "" (printOutputable . renderEvidenceTree) (getEvidenceTree rf n) + in + pure $ evidenceTree <> "\n" + -- Identifier details that are not evidence variables are used to display type information and + -- documentation of that name. + | otherwise = do + let + typeSig = case identType dets of + Just t -> prettyType (Just n) locationsMap t + Nothing -> case safeTyThingType (Util.member LinearTypes enabledExtensions) =<< lookupNameEnv km n of + Just kind -> prettyTypeFromType (Just n) locationsMap kind + Nothing -> wrapHaskell (printOutputable n) + definitionLoc = maybeToList (pretty (definedAt n) (prettyPackageName n)) + docs = maybeToList (T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n) + + pure $ T.unlines $ [typeSig] ++ definitionLoc ++ docs + where pretty Nothing Nothing = Nothing pretty (Just define) Nothing = Just $ define <> "\n" pretty Nothing (Just pkgName) = Just $ pkgName <> "\n" pretty (Just define) (Just pkgName) = Just $ define <> " " <> pkgName <> "\n" - prettyName (Left m,_) = printOutputable m + prettyName _locationsMap (Left m,_) = packageNameForImportStatement m + prettyPackageName :: Name -> Maybe T.Text prettyPackageName n = do m <- nameModule_maybe n + pkgTxt <- packageNameWithVersion m + pure $ "*(" <> pkgTxt <> ")*" + + -- Return the module text itself and + -- the package(with version) this `ModuleName` belongs to. + packageNameForImportStatement :: ModuleName -> IO T.Text + packageNameForImportStatement mod = do + mpkg <- findImportedModule (setNonHomeFCHook env) mod :: IO (Maybe Module) + let moduleName = printOutputable mod + case mpkg >>= packageNameWithVersion of + Nothing -> pure moduleName + Just pkgWithVersion -> pure $ moduleName <> "\n\n" <> pkgWithVersion + + -- Return the package name and version of a module. + -- For example, given module `Data.List`, it should return something like `base-4.x`. + packageNameWithVersion :: Module -> Maybe T.Text + packageNameWithVersion m = do let pid = moduleUnit m conf <- lookupUnit env pid let pkgName = T.pack $ unitPackageNameString conf version = T.pack $ showVersion (unitPackageVersion conf) - pure $ "*(" <> pkgName <> "-" <> version <> ")*" + pure $ pkgName <> "-" <> version - prettyTypes = map (("_ :: "<>) . prettyType) types - prettyType t = case kind of - HieFresh -> printOutputable t - HieFromDisk full_file -> printOutputable $ hieTypeToIface $ recoverFullType t (hie_types full_file) + -- Type info for the current node, it may contain several symbols + -- for one range, like wildcard + types :: [hietype] + types = take maxHoverTypes $ nodeType info + maxHoverTypes :: Int + maxHoverTypes = 10 + + prettyTypes :: Maybe Name -> M.Map Name Location -> [T.Text] + prettyTypes boundNameMay locationsMap = + map (prettyType boundNameMay locationsMap) types + + prettyTypeFromType :: Maybe Name -> M.Map Name Location -> Type -> T.Text + prettyTypeFromType boundNameMay locationsMap ty = + prettyTypeCommon boundNameMay locationsMap (S.fromList $ namesInType ty) (printOutputableOneLine ty) + + prettyType :: Maybe Name -> M.Map Name Location -> hietype -> T.Text + prettyType boundNameMay locationsMap t = + prettyTypeCommon boundNameMay locationsMap (typeNames t) (printOutputableOneLine . expandType $ t) + + prettyTypeCommon :: Maybe Name -> M.Map Name Location -> Set Name -> T.Text -> T.Text + prettyTypeCommon boundNameMay locationsMap names expandedType = + let nameToUse = case boundNameMay of + Just n -> printOutputable n + Nothing -> "_" + expandedWithName = nameToUse <> " :: " <> expandedType + codeBlock = wrapHaskell expandedWithName + links = case boundNameMay of + Just _ -> generateLinksList locationsMap names + -- This is so we don't get flooded with links, e.g: + -- foo :: forall a. MyType a -> a + -- Go to MyType + -- _ :: forall a. MyType a -> a + -- Go to MyType -- <- we don't want this as it's already present + Nothing -> "" + in codeBlock <> links + + generateLinksList :: M.Map Name Location -> Set Name -> T.Text + generateLinksList locationsMap (S.toList -> names) = + if null generated + then "" + else "\n" <> "Go to " <> T.intercalate " | " generated <> "\n" + where + generated = mapMaybe generateLink names + + generateLink name = do + case M.lookup name locationsMap of + Just (Location uri range) -> + let nameText = printOutputable name + link = "[" <> nameText <> "](" <> getUriText uri <> "#L" <> + T.pack (show (range ^. L.start . L.line + 1)) <> ")" + in Just link + Nothing -> Nothing + + wrapHaskell :: T.Text -> T.Text + wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n" + + getUriText :: Uri -> T.Text + getUriText (Uri t) = t + + typeNames :: a -> Set Name + typeNames t = S.fromList $ case kind of + HieFresh -> namesInType t + HieFromDisk full_file -> do + namesInHieTypeFix $ recoverFullType t (hie_types full_file) + + expandType :: a -> SDoc + expandType t = case kind of + HieFresh -> ppr t + HieFromDisk full_file -> ppr $ hieTypeToIface $ recoverFullType t (hie_types full_file) + + definedAt :: Name -> Maybe T.Text definedAt name = -- do not show "at " and similar messages -- see the code of 'pprNameDefnLoc' for more information @@ -261,6 +438,67 @@ UnhelpfulLoc {} | isInternalName name || isSystemName name -> Nothing _ -> Just $ "*Defined " <> printOutputable (pprNameDefnLoc name) <> "*" + -- We want to render the root constraint even if it is a let, + -- but we don't want to render any subsequent lets + renderEvidenceTree :: Tree (EvidenceInfo a) -> SDoc + -- However, if the root constraint is simply a (Show (,), Show [], Show Int, Show Bool)@ + -- + -- It is also quite helpful to look at the @.hie@ file directly to see how the + -- evidence information is presented on disk. @hiedb dump @ + renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) [x]) + = renderEvidenceTree x + renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_), ..}) xs) + = hang (text "Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $ + vcat $ text "constructed using:" : map renderEvidenceTree' xs + renderEvidenceTree (T.Node (EvidenceInfo{..}) _) + = hang (text "Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $ + vcat $ printDets evidenceSpan evidenceDetails : map (text . T.unpack) (maybeToList $ definedAt evidenceVar) + + -- renderEvidenceTree' skips let bound evidence variables and prints the children directly + renderEvidenceTree' (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) xs) + = vcat (map renderEvidenceTree' xs) + renderEvidenceTree' (T.Node (EvidenceInfo{..}) _) + = hang (text "- `" O.<> expandType evidenceType O.<> "`") 2 $ + vcat $ + printDets evidenceSpan evidenceDetails : map (text . T.unpack) (maybeToList $ definedAt evidenceVar) + + printDets :: RealSrcSpan -> Maybe (EvVarSource, Scope, Maybe Span) -> SDoc + printDets _ Nothing = text "using an external instance" + printDets ospn (Just (src,_,mspn)) = pprSrc + $$ text "at" <+> text (T.unpack $ srcSpanToMdLink location) + where + location = realSrcSpanToLocation spn + -- Use the bind span if we have one, else use the occurrence span + spn = fromMaybe ospn mspn + pprSrc = case src of + -- Users don't know what HsWrappers are + EvWrapperBind -> "bound by type signature or pattern" + _ -> ppr src + +-- | Find 'Location's of type definition at a specific point and return them along with their 'Identifier's. typeLocationsAtPoint :: forall m . MonadIO m @@ -269,65 +507,98 @@ -> IdeOptions -> Position -> HieAstResult - -> m [Location] + -> m [(Location, Identifier)] typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) = case hieKind of HieFromDisk hf -> let arr = hie_types hf ts = concat $ pointCommand ast pos getts unfold = map (arr A.!) - getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) + getts x = nodeType ni ++ mapMaybe identType (M.elems $ nodeIdentifiers ni) where ni = nodeInfo' x - getTypes ts = flip concatMap (unfold ts) $ \case + getTypes' ts' = flip concatMap (unfold ts') $ \case HTyVarTy n -> [n] - HAppTy a (HieArgs xs) -> getTypes (a : map snd xs) - HTyConApp tc (HieArgs xs) -> ifaceTyConName tc : getTypes (map snd xs) - HForAllTy _ a -> getTypes [a] -#if MIN_VERSION_ghc(9,0,1) - HFunTy a b c -> getTypes [a,b,c] -#else - HFunTy a b -> getTypes [a,b] -#endif - HQualTy a b -> getTypes [a,b] - HCastTy a -> getTypes [a] + HAppTy a (HieArgs xs) -> getTypes' (a : map snd xs) + HTyConApp tc (HieArgs xs) -> ifaceTyConName tc : getTypes' (map snd xs) + HForAllTy _ a -> getTypes' [a] + HFunTy a b c -> getTypes' [a,b,c] + HQualTy a b -> getTypes' [a,b] + HCastTy a -> getTypes' [a] _ -> [] - in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts) + in fmap nubOrd $ concatMapM (\n -> fmap (maybe [] (fmap (,Right n))) (nameToLocation withHieDb lookupModule n)) (getTypes' ts) HieFresh -> let ts = concat $ pointCommand ast pos getts - getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) + getts x = nodeType ni ++ mapMaybe identType (M.elems $ nodeIdentifiers ni) where ni = nodeInfo x - in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts) + in fmap nubOrd $ concatMapM (\n -> fmap (maybe [] (fmap (,Right n))) (nameToLocation withHieDb lookupModule n)) (getTypes ts) namesInType :: Type -> [Name] namesInType (TyVarTy n) = [varName n] namesInType (AppTy a b) = getTypes [a,b] namesInType (TyConApp tc ts) = tyConName tc : getTypes ts namesInType (ForAllTy b t) = varName (binderVar b) : namesInType t -namesInType (FunTy a b) = getTypes [a,b] +namesInType (FunTy _ a b) = getTypes [a,b] namesInType (CastTy t _) = namesInType t namesInType (LitTy _) = [] namesInType _ = [] + getTypes :: [Type] -> [Name] -getTypes ts = concatMap namesInType ts +getTypes = concatMap namesInType +namesInHieTypeFix :: HieTypeFix -> [Name] +namesInHieTypeFix (Roll hieType) = namesInHieType hieType + +namesInHieType :: HieType HieTypeFix -> [Name] +namesInHieType (HTyVarTy n) = [n] +namesInHieType (HAppTy a (HieArgs args)) = namesInHieTypeFix a ++ concatMap (namesInHieTypeFix . snd) args +namesInHieType (HTyConApp tc (HieArgs args)) = ifaceTyConName tc : concatMap (namesInHieTypeFix . snd) args +namesInHieType (HForAllTy ((binder, constraint), _) body) = binder : namesInHieTypeFix constraint ++ namesInHieTypeFix body +namesInHieType (HFunTy mult arg res) = namesInHieTypeFix mult ++ namesInHieTypeFix arg ++ namesInHieTypeFix res +namesInHieType (HQualTy constraint body) = namesInHieTypeFix constraint ++ namesInHieTypeFix body +namesInHieType (HLitTy _) = [] +namesInHieType (HCastTy a) = namesInHieTypeFix a +namesInHieType HCoercionTy = [] + +-- | Find 'Location's of definition at a specific point and return them along with their 'Identifier's. locationsAtPoint - :: forall m a + :: forall m . MonadIO m => WithHieDb -> LookupModule m -> IdeOptions -> M.Map ModuleName NormalizedFilePath -> Position - -> HieASTs a - -> m [Location] -locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast = + -> HieAstResult + -> m [(Location, Identifier)] +locationsAtPoint withHieDb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) = let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) zeroPos = Position 0 0 zeroRange = Range zeroPos zeroPos - modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports - in fmap (nubOrd . concat) $ mapMaybeM (either (pure . modToLocation) $ nameToLocation withHieDb lookupModule) ns + modToLocation m = fmap (\fs -> pure (Location (fromNormalizedUri $ filePathToUri' fs) zeroRange)) $ M.lookup m imports + in fmap (nubOrd . concat) $ mapMaybeM + (either (\m -> pure ((fmap $ fmap (,Left m)) (modToLocation m))) + (\n -> fmap (fmap $ fmap (,Right n)) (nameToLocation withHieDb lookupModule n))) + ns +-- | Find 'Location's of a implementation definition at a specific point. +instanceLocationsAtPoint + :: forall m + . MonadIO m + => WithHieDb + -> LookupModule m + -> IdeOptions + -> Position + -> HieAstResult + -> m [Location] +instanceLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _rm _ _) = + let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) + evTrees = mapMaybe (eitherToMaybe >=> getEvidenceTree _rm) ns + evNs = concatMap (map evidenceVar . T.flatten) evTrees + in fmap (nubOrd . concat) $ mapMaybeM + (nameToLocation withHieDb lookupModule) + evNs + -- | Given a 'Name' attempt to find the location where it is defined. nameToLocation :: MonadIO m => WithHieDb -> LookupModule m -> Name -> m (Maybe [Location]) nameToLocation withHieDb lookupModule name = runMaybeT $ @@ -359,8 +630,8 @@ -- This is a hack to make find definition work better with ghcide's nascent multi-component support, -- where names from a component that has been indexed in a previous session but not loaded in this -- session may end up with different unit ids - erow <- liftIO $ withHieDb (\hieDb -> findDef hieDb (nameOccName name) (Just $ moduleName mod) Nothing) - case erow of + erow' <- liftIO $ withHieDb (\hieDb -> findDef hieDb (nameOccName name) (Just $ moduleName mod) Nothing) + case erow' of [] -> MaybeT $ pure Nothing xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs @@ -380,13 +651,15 @@ defRowToSymbolInfo :: Res DefRow -> Maybe SymbolInformation defRowToSymbolInfo (DefRow{..}:.(modInfoSrcFile -> Just srcFile)) - = Just $ SymbolInformation (printOutputable defNameOcc) kind Nothing Nothing loc Nothing + = Just $ SymbolInformation (printOutputable defNameOcc) kind Nothing Nothing Nothing loc where kind - | isVarOcc defNameOcc = SkVariable - | isDataOcc defNameOcc = SkConstructor - | isTcOcc defNameOcc = SkStruct - | otherwise = SkUnknown 1 + | isVarOcc defNameOcc = SymbolKind_Variable + | isDataOcc defNameOcc = SymbolKind_Constructor + | isTcOcc defNameOcc = SymbolKind_Struct + -- This used to be (SkUnknown 1), buth there is no SymbolKind_Unknown. + -- Changing this to File, as that is enum representation of 1 + | otherwise = SymbolKind_File loc = Location file range file = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' $ srcFile range = Range start end @@ -396,10 +669,10 @@ pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a] pointCommand hf pos k = - catMaybes $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> + M.elems $ flip M.mapMaybeWithKey (getAsts hf) $ \fs ast -> -- Since GHC 9.2: -- getAsts :: Map HiePath (HieAst a) - -- type HiePath = LexialFastString + -- type HiePath = LexicalFastString -- -- but before: -- getAsts :: Map HiePath (HieAst a) @@ -413,6 +686,7 @@ where sloc fs = mkRealSrcLoc fs (fromIntegral $ line+1) (fromIntegral $ cha+1) sp fs = mkRealSrcSpan (sloc fs) (sloc fs) + line :: UInt line = _line pos cha = _character pos diff --git a/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs --- a/src/Development/IDE/Spans/Common.hs +++ b/src/Development/IDE/Spans/Common.hs @@ -4,7 +4,6 @@ module Development.IDE.Spans.Common ( unqualIEWrapName -, safeTyThingId , safeTyThingType , SpanDoc(..) , SpanDocUris(..) @@ -12,51 +11,48 @@ , spanDocToMarkdown , spanDocToMarkdownForTest , DocMap -, KindMap +, TyThingMap +, ArgDocMap +, srcSpanToMdLink ) where import Control.DeepSeq +import Data.Bifunctor (second) import Data.List.Extra import Data.Maybe import qualified Data.Text as T -import GHC.Generics - +import Development.IDE.GHC.Util +import qualified Documentation.Haddock.Parser as H +import qualified Documentation.Haddock.Types as H import GHC +import GHC.Generics +import System.FilePath -import Data.Bifunctor (second) +import Control.Lens +import Data.IntMap (IntMap) import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () -import Development.IDE.GHC.Util -import qualified Documentation.Haddock.Parser as H -import qualified Documentation.Haddock.Types as H +import qualified Language.LSP.Protocol.Lens as JL +import Language.LSP.Protocol.Types type DocMap = NameEnv SpanDoc -type KindMap = NameEnv TyThing +type TyThingMap = NameEnv TyThing +type ArgDocMap = NameEnv (IntMap SpanDoc) -- | Shows IEWrappedName, without any modifier, qualifier or unique identifier. -unqualIEWrapName :: IEWrappedName RdrName -> T.Text +unqualIEWrapName :: IEWrappedName GhcPs -> T.Text unqualIEWrapName = printOutputable . rdrNameOcc . ieWrappedName --- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs -safeTyThingType :: TyThing -> Maybe Type -safeTyThingType thing - | Just i <- safeTyThingId thing = Just (varType i) -safeTyThingType (ATyCon tycon) = Just (tyConKind tycon) -safeTyThingType _ = Nothing - -safeTyThingId :: TyThing -> Maybe Id -safeTyThingId (AnId i) = Just i -safeTyThingId (AConLike (RealDataCon dataCon)) = Just (dataConWrapId dataCon) -safeTyThingId _ = Nothing +safeTyThingType :: Bool -> TyThing -> Maybe Type +safeTyThingType showLinearType (AConLike (RealDataCon dataCon)) + = Just (dataConDisplayType showLinearType dataCon) +safeTyThingType _ (AnId i) = Just (varType i) +safeTyThingType _ (ATyCon tycon) = Just (tyConKind tycon) +safeTyThingType _ _ = Nothing -- Possible documentation for an element in the code -#if MIN_VERSION_ghc(9,3,0) data SpanDoc = SpanDocString [HsDocString] SpanDocUris -#else -data SpanDoc - = SpanDocString HsDocString SpanDocUris -#endif | SpanDocText [T.Text] SpanDocUris deriving stock (Eq, Show, Generic) deriving anyclass NFData @@ -93,11 +89,7 @@ spanDocToMarkdown = \case (SpanDocString docs uris) -> let doc = T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ -#if MIN_VERSION_ghc(9,3,0) renderHsDocStrings docs -#else - unpackHDS docs -#endif in go [doc] uris (SpanDocText txt uris) -> go txt uris where @@ -114,8 +106,14 @@ [ linkify "Documentation" <$> mdoc , linkify "Source" <$> msrc ] - where linkify title uri = "[" <> title <> "](" <> uri <> ")" +-- | Generate a markdown link. +-- +-- >>> linkify "Title" "uri" +-- "[Title](Uri)" +linkify :: T.Text -> T.Text -> T.Text +linkify title uri = "[" <> title <> "](" <> uri <> ")" + spanDocToMarkdownForTest :: String -> String spanDocToMarkdownForTest = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing @@ -189,11 +187,10 @@ haddockToMarkdown (H.DocDefList things) = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things) --- we cannot render math by default -haddockToMarkdown (H.DocMathInline _) - = "*cannot render inline math formula*" -haddockToMarkdown (H.DocMathDisplay _) - = "\n\n*cannot render display math formula*\n\n" +haddockToMarkdown (H.DocMathInline s) + = "`" ++ s ++ "`" +haddockToMarkdown (H.DocMathDisplay s) + = "\n```latex\n" ++ s ++ "\n```\n" -- TODO: render tables haddockToMarkdown (H.DocTable _t) @@ -220,3 +217,35 @@ = case lines s of [] -> "" (first:rest) -> unlines $ first : map ((" " ++) . trimStart) rest + +-- | Generate a source link for the 'Location' according to VSCode's supported form: +-- https://github.com/microsoft/vscode/blob/b3ec8181fc49f5462b5128f38e0723ae85e295c2/src/vs/platform/opener/common/opener.ts#L151-L160 +-- +srcSpanToMdLink :: Location -> T.Text +srcSpanToMdLink location = + let + uri = location ^. JL.uri + range = location ^. JL.range + -- LSP 'Range' starts at '0', but link locations start at '1'. + intText n = T.pack $ show (n + 1) + srcRangeText = + T.concat + [ "L" + , intText (range ^. JL.start . JL.line) + , "," + , intText (range ^. JL.start . JL.character) + , "-L" + , intText (range ^. JL.end . JL.line) + , "," + , intText (range ^. JL.end . JL.character) + ] + + -- If the 'Location' is a 'FilePath', display it in shortened form. + -- This avoids some redundancy and better readability for the user. + title = case uriToFilePath uri of + Just fp -> T.pack (takeFileName fp) <> ":" <> intText (range ^. JL.start . JL.line) + Nothing -> getUri uri + + srcLink = getUri uri <> "#" <> srcRangeText + in + linkify title srcLink diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs --- a/src/Development/IDE/Spans/Documentation.hs +++ b/src/Development/IDE/Spans/Documentation.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE RankNTypes #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} module Development.IDE.Spans.Documentation ( getDocumentation @@ -17,6 +16,7 @@ import Control.Monad.IO.Class import Data.Either import Data.Foldable +import Data.IntMap (IntMap) import Data.List.Extra import qualified Data.Map as M import Data.Maybe @@ -29,47 +29,41 @@ import Development.IDE.GHC.Error import Development.IDE.GHC.Util (printOutputable) import Development.IDE.Spans.Common +import GHC.Iface.Ext.Utils (RefMap) +import Language.LSP.Protocol.Types (filePathToUri, getUri) +import Prelude hiding (mod) import System.Directory import System.FilePath -import Language.LSP.Types (filePathToUri, getUri) -#if MIN_VERSION_ghc(9,3,0) -import GHC.Types.Unique.Map -#endif mkDocMap :: HscEnv -> RefMap a -> TcGblEnv - -> IO DocAndKindMap + -> IO DocAndTyThingMap mkDocMap env rm this_mod = do -#if MIN_VERSION_ghc(9,3,0) - (Just Docs{docs_decls = UniqMap this_docs}) <- extractDocs (hsc_dflags env) this_mod -#elif MIN_VERSION_ghc(9,2,0) - (_ , DeclDocMap this_docs, _) <- extractDocs this_mod -#else - let (_ , DeclDocMap this_docs, _) = extractDocs this_mod -#endif -#if MIN_VERSION_ghc(9,3,0) + (Just Docs{docs_decls = UniqMap this_docs, docs_args = UniqMap this_arg_docs}) <- extractDocs (hsc_dflags env) this_mod d <- foldrM getDocs (fmap (\(_, x) -> (map hsDocString x) `SpanDocString` SpanDocUris Nothing Nothing) this_docs) names -#else - d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names -#endif k <- foldrM getType (tcg_type_env this_mod) names - pure $ DKMap d k + a <- foldrM getArgDocs (fmap (\(_, m) -> fmap (\x -> [hsDocString x] `SpanDocString` SpanDocUris Nothing Nothing) m) this_arg_docs) names + pure $ DKMap d k a where - getDocs n map - | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist + getDocs n nameMap + | maybe True (mod ==) $ nameModule_maybe n = pure nameMap -- we already have the docs in this_docs, or they do not exist | otherwise = do - doc <- getDocumentationTryGhc env n - pure $ extendNameEnv map n doc - getType n map - | isTcOcc $ occName n - , Nothing <- lookupNameEnv map n + (doc, _argDoc) <- getDocumentationTryGhc env n + pure $ extendNameEnv nameMap n doc + getType n nameMap + | Nothing <- lookupNameEnv nameMap n = do kind <- lookupKind env n - pure $ maybe map (extendNameEnv map n) kind - | otherwise = pure map + pure $ maybe nameMap (extendNameEnv nameMap n) kind + | otherwise = pure nameMap + getArgDocs n nameMap + | maybe True (mod ==) $ nameModule_maybe n = pure nameMap + | otherwise = do + (_doc, argDoc) <- getDocumentationTryGhc env n + pure $ extendNameEnv nameMap n argDoc names = rights $ S.toList idents idents = M.keysSet rm mod = tcg_mod this_mod @@ -78,27 +72,23 @@ lookupKind env = fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env -getDocumentationTryGhc :: HscEnv -> Name -> IO SpanDoc +getDocumentationTryGhc :: HscEnv -> Name -> IO (SpanDoc, IntMap SpanDoc) getDocumentationTryGhc env n = - (fromMaybe emptySpanDoc . listToMaybe <$> getDocumentationsTryGhc env [n]) - `catch` (\(_ :: IOEnvFailure) -> pure emptySpanDoc) + (fromMaybe (emptySpanDoc, mempty) . listToMaybe <$> getDocumentationsTryGhc env [n]) + `catch` (\(_ :: IOEnvFailure) -> pure (emptySpanDoc, mempty)) -getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [SpanDoc] +getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [(SpanDoc, IntMap SpanDoc)] getDocumentationsTryGhc env names = do - res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env names - case res of + resOr <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env names + case resOr of Left _ -> return [] Right res -> zipWithM unwrap res names where -#if MIN_VERSION_ghc(9,3,0) - unwrap (Right (Just docs, _)) n = SpanDocString (map hsDocString docs) <$> getUris n -#else - unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n -#endif + unwrap (Right (Just docs, argDocs)) n = (\uris -> (SpanDocString (map hsDocString docs) uris, fmap (\x -> SpanDocString [hsDocString x] uris) argDocs)) <$> getUris n unwrap _ n = mkSpanDocText n mkSpanDocText name = - SpanDocText [] <$> getUris name + (\uris -> (SpanDocText [] uris, mempty)) <$> getUris name -- Get the uris to the documentation and source html pages if they exist getUris name = do @@ -123,81 +113,7 @@ => [ParsedModule] -- ^ All of the possible modules it could be defined in. -> name -- ^ The name you want documentation for. -> [T.Text] --- This finds any documentation between the name you want --- documentation for and the one before it. This is only an --- approximately correct algorithm and there are easily constructed --- cases where it will be wrong (if so then usually slightly but there --- may be edge cases where it is very wrong). --- TODO : Build a version of GHC exactprint to extract this information --- more accurately. --- TODO : Implement this for GHC 9.2 with in-tree annotations --- (alternatively, just remove it and rely solely on GHC's parsing) -getDocumentation sources targetName = fromMaybe [] $ do -#if MIN_VERSION_ghc(9,2,0) - Nothing -#else - -- Find the module the target is defined in. - targetNameSpan <- realSpan $ getLoc targetName - tc <- - find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName) - $ reverse sources -- TODO : Is reversing the list here really necessary? - - -- Top level names bound by the module - let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc - , L _ (ValD _ hsbind) <- hsmodDecls - , Just n <- [name_of_bind hsbind] - ] - -- Sort the names' source spans. - let sortedSpans = sortedNameSpans bs - -- Now go ahead and extract the docs. - let docs = ann tc - nameInd <- elemIndex targetNameSpan sortedSpans - let prevNameSpan = - if nameInd >= 1 - then sortedSpans !! (nameInd - 1) - else zeroSpan $ srcSpanFile targetNameSpan - -- Annoyingly "-- |" documentation isn't annotated with a location, - -- so you have to pull it out from the elements. - pure - $ docHeaders - $ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan) - $ fold - docs - where - -- Get the name bound by a binding. We only concern ourselves with - -- @FunBind@ (which covers functions and variables). - name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName) - name_of_bind FunBind {fun_id} = Just fun_id - name_of_bind _ = Nothing - -- Get source spans from names, discard unhelpful spans, remove - -- duplicates and sort. - sortedNameSpans :: [Located RdrName] -> [RealSrcSpan] - sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls) - isBetween target before after = before <= target && target <= after -#if MIN_VERSION_ghc(9,0,0) - ann = apiAnnComments . pm_annotations -#else - ann = fmap filterReal . snd . pm_annotations - filterReal :: [Located a] -> [RealLocated a] - filterReal = mapMaybe (\(L l v) -> (`L`v) <$> realSpan l) -#endif - annotationFileName :: ParsedModule -> Maybe FastString - annotationFileName = fmap srcSpanFile . listToMaybe . map getRealSrcSpan . fold . ann - --- | Shows this part of the documentation -docHeaders :: [RealLocated AnnotationComment] - -> [T.Text] -docHeaders = mapMaybe (\(L _ x) -> wrk x) - where - wrk = \case - -- When `Opt_Haddock` is enabled. - AnnDocCommentNext s -> Just $ T.pack s - -- When `Opt_KeepRawTokenStream` enabled. - AnnLineComment s -> if "-- |" `isPrefixOf` s - then Just $ T.pack s - else Nothing - _ -> Nothing -#endif +getDocumentation _sources _targetName = [] -- These are taken from haskell-ide-engine's Haddock plugin diff --git a/src/Development/IDE/Spans/LocalBindings.hs b/src/Development/IDE/Spans/LocalBindings.hs --- a/src/Development/IDE/Spans/LocalBindings.hs +++ b/src/Development/IDE/Spans/LocalBindings.hs @@ -17,14 +17,16 @@ import qualified Data.List as L import qualified Data.Map as M import qualified Data.Set as S +import GHC.Iface.Ext.Types (IdentifierDetails (..), + Scope (..)) +import GHC.Iface.Ext.Utils (RefMap, getBindSiteFromContext, + getScopeFromContext) + import Development.IDE.GHC.Compat (Name, NameEnv, RealSrcSpan, - RefMap, Scope (..), Type, - getBindSiteFromContext, - getScopeFromContext, identInfo, - identType, isSystemName, - nameEnvElts, realSrcSpanEnd, + Type, isSystemName, + nonDetNameEnvElts, + realSrcSpanEnd, realSrcSpanStart, unitNameEnv) - import Development.IDE.GHC.Error import Development.IDE.Types.Location @@ -99,7 +101,7 @@ -- 'RealSrcSpan', getLocalScope :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] getLocalScope bs rss - = nameEnvElts + = nonDetNameEnvElts $ foldMap snd $ IM.dominators (realSrcSpanToInterval rss) $ getLocalBindings bs @@ -109,7 +111,7 @@ -- 'RealSrcSpan', getDefiningBindings :: Bindings -> RealSrcSpan -> [(Name, Maybe Type)] getDefiningBindings bs rss - = nameEnvElts + = nonDetNameEnvElts $ foldMap snd $ IM.dominators (realSrcSpanToInterval rss) $ getBindingSites bs @@ -121,7 +123,7 @@ getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)] getFuzzyScope bs a b = filter (not . isSystemName . fst) - $ nameEnvElts + $ nonDetNameEnvElts $ foldMap snd $ IM.intersections (Interval a b) $ getLocalBindings bs @@ -133,7 +135,7 @@ -- `PositionMapping` getFuzzyDefiningBindings :: Bindings -> Position -> Position -> [(Name, Maybe Type)] getFuzzyDefiningBindings bs a b - = nameEnvElts + = nonDetNameEnvElts $ foldMap snd $ IM.intersections (Interval a b) $ getBindingSites bs diff --git a/src/Development/IDE/Spans/Pragmas.hs b/src/Development/IDE/Spans/Pragmas.hs --- a/src/Development/IDE/Spans/Pragmas.hs +++ b/src/Development/IDE/Spans/Pragmas.hs @@ -9,26 +9,30 @@ , insertNewPragma , getFirstPragma ) where +import Control.Lens ((&), (.~)) import Data.Bits (Bits (setBit)) -import Data.Function ((&)) import qualified Data.List as List import qualified Data.Maybe as Maybe import Data.Text (Text, pack) import qualified Data.Text as Text -import Development.IDE (srcSpanToRange, IdeState, NormalizedFilePath, runAction, useWithStale, GhcSession (..), getFileContents, hscEnv) +import Data.Text.Utf16.Rope.Mixed (Rope) +import qualified Data.Text.Utf16.Rope.Mixed as Rope +import Development.IDE (srcSpanToRange, IdeState, NormalizedFilePath, GhcSession (..), getFileContents, hscEnv, runAction) import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util -import qualified Language.LSP.Types as LSP -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Except (ExceptT) -import Ide.Types (PluginId(..)) -import qualified Data.Text as T -import Ide.PluginUtils (handleMaybeM) +import qualified Language.LSP.Protocol.Types as LSP +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Except (ExceptT) +import Ide.Plugin.Error (PluginError) +import Ide.Types (PluginId(..)) +import qualified Data.Text as T +import Development.IDE.Core.PluginUtils +import qualified Language.LSP.Protocol.Lens as L -getNextPragmaInfo :: DynFlags -> Maybe Text -> NextPragmaInfo -getNextPragmaInfo dynFlags sourceText = - if | Just sourceText <- sourceText - , let sourceStringBuffer = stringToStringBuffer (Text.unpack sourceText) +getNextPragmaInfo :: DynFlags -> Maybe Rope -> NextPragmaInfo +getNextPragmaInfo dynFlags mbSource = + if | Just source <- mbSource + , let sourceStringBuffer = stringToStringBuffer (Text.unpack (Rope.toText source)) , POk _ parserState <- parsePreDecl dynFlags sourceStringBuffer -> case parserState of ParserStateNotDone{ nextPragma } -> nextPragma @@ -36,28 +40,21 @@ | otherwise -> NextPragmaInfo 0 Nothing --- NOTE(ozkutuk): `RecordPuns` extension is renamed to `NamedFieldPuns` --- in GHC 9.4, but we still want to insert `NamedFieldPuns` in pre-9.4 --- GHC as well, hence the replacement. --- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6156 showExtension :: Extension -> Text -showExtension NamedFieldPuns = "NamedFieldPuns" showExtension ext = pack (show ext) insertNewPragma :: NextPragmaInfo -> Extension -> LSP.TextEdit -insertNewPragma (NextPragmaInfo _ (Just (LineSplitTextEdits ins _))) newPragma = ins { LSP._newText = "{-# LANGUAGE " <> showExtension newPragma <> " #-}\n" } :: LSP.TextEdit +insertNewPragma (NextPragmaInfo _ (Just (LineSplitTextEdits ins _))) newPragma = ins & L.newText .~ "{-# LANGUAGE " <> showExtension newPragma <> " #-}\n" :: LSP.TextEdit insertNewPragma (NextPragmaInfo nextPragmaLine _) newPragma = LSP.TextEdit pragmaInsertRange $ "{-# LANGUAGE " <> showExtension newPragma <> " #-}\n" where pragmaInsertPosition = LSP.Position (fromIntegral nextPragmaLine) 0 pragmaInsertRange = LSP.Range pragmaInsertPosition pragmaInsertPosition -getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo -getFirstPragma (PluginId pId) state nfp = handleMaybeM "Could not get NextPragmaInfo" $ do - ghcSession <- liftIO $ runAction (T.unpack pId <> ".GhcSession") state $ useWithStale GhcSession nfp - (_, fileContents) <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp - case ghcSession of - Just (hscEnv -> hsc_dflags -> sessionDynFlags, _) -> pure $ Just $ getNextPragmaInfo sessionDynFlags fileContents - Nothing -> pure Nothing +getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError m NextPragmaInfo +getFirstPragma (PluginId pId) state nfp = do + (hscEnv -> hsc_dflags -> sessionDynFlags, _) <- runActionE (T.unpack pId <> ".GhcSession") state $ useWithStaleE GhcSession nfp + fileContents <- liftIO $ runAction (T.unpack pId <> ".GetFileContents") state $ getFileContents nfp + pure $ getNextPragmaInfo sessionDynFlags fileContents -- Pre-declaration comments parser ----------------------------------------------------- @@ -99,8 +96,8 @@ -- need to merge tokens that are deleted/inserted into one TextEdit each -- to work around some weird TextEdits applied in reversed order issue updateLineSplitTextEdits :: LSP.Range -> String -> Maybe LineSplitTextEdits -> LineSplitTextEdits -updateLineSplitTextEdits tokenRange tokenString prevLineSplitTextEdits - | Just prevLineSplitTextEdits <- prevLineSplitTextEdits +updateLineSplitTextEdits tokenRange tokenString mbPrevLineSplitTextEdits + | Just prevLineSplitTextEdits <- mbPrevLineSplitTextEdits , let LineSplitTextEdits { lineSplitInsertTextEdit = prevInsertTextEdit , lineSplitDeleteTextEdit = prevDeleteTextEdit } = prevLineSplitTextEdits @@ -152,21 +149,13 @@ ModeInitial -> case token of ITvarsym "#" -> defaultParserState{ isLastTokenHash = True } -#if !MIN_VERSION_ghc(9,2,0) - ITlineComment s -#else ITlineComment s _ -#endif | isDownwardLineHaddock s -> defaultParserState{ mode = ModeHaddock } | otherwise -> defaultParserState { nextPragma = NextPragmaInfo (endLine + 1) Nothing , mode = ModeComment } -#if !MIN_VERSION_ghc(9,2,0) - ITblockComment s -#else ITblockComment s _ -#endif | isPragma s -> defaultParserState { nextPragma = NextPragmaInfo (endLine + 1) Nothing @@ -182,11 +171,7 @@ ModeComment -> case token of ITvarsym "#" -> defaultParserState{ isLastTokenHash = True } -#if !MIN_VERSION_ghc(9,2,0) - ITlineComment s -#else ITlineComment s _ -#endif | hasDeleteStartedOnSameLine startLine prevLineSplitTextEdits , let currLineSplitTextEdits = updateLineSplitTextEdits range s prevLineSplitTextEdits -> defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } } @@ -198,11 +183,7 @@ , mode = ModeHaddock } | otherwise -> defaultParserState { nextPragma = NextPragmaInfo (endLine + 1) Nothing } -#if !MIN_VERSION_ghc(9,2,0) - ITblockComment s -#else ITblockComment s _ -#endif | isPragma s -> defaultParserState { nextPragma = NextPragmaInfo (endLine + 1) Nothing @@ -226,21 +207,13 @@ case token of ITvarsym "#" -> defaultParserState{ isLastTokenHash = True } -#if !MIN_VERSION_ghc(9,2,0) - ITlineComment s -#else ITlineComment s _ -#endif | hasDeleteStartedOnSameLine startLine prevLineSplitTextEdits , let currLineSplitTextEdits = updateLineSplitTextEdits range s prevLineSplitTextEdits -> defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } } | otherwise -> defaultParserState -#if !MIN_VERSION_ghc(9,2,0) - ITblockComment s -#else ITblockComment s _ -#endif | isPragma s -> defaultParserState{ nextPragma = NextPragmaInfo (endLine + 1) Nothing, @@ -254,11 +227,7 @@ ModePragma -> case token of ITvarsym "#" -> defaultParserState{ isLastTokenHash = True } -#if !MIN_VERSION_ghc(9,2,0) - ITlineComment s -#else ITlineComment s _ -#endif | hasDeleteStartedOnSameLine startLine prevLineSplitTextEdits , let currLineSplitTextEdits = updateLineSplitTextEdits range s prevLineSplitTextEdits -> defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } } @@ -268,11 +237,7 @@ defaultParserState{ nextPragma = prevNextPragma{ lineSplitTextEdits = Just currLineSplitTextEdits } } | otherwise -> defaultParserState -#if !MIN_VERSION_ghc(9,2,0) - ITblockComment s -#else ITblockComment s _ -#endif | isPragma s -> defaultParserState{ nextPragma = NextPragmaInfo (endLine + 1) Nothing, lastPragmaLine = endLine } | hasDeleteStartedOnSameLine startLine prevLineSplitTextEdits @@ -291,8 +256,8 @@ | otherwise = prevParserState where hasDeleteStartedOnSameLine :: Int -> Maybe LineSplitTextEdits -> Bool - hasDeleteStartedOnSameLine line lineSplitTextEdits - | Just lineSplitTextEdits <- lineSplitTextEdits + hasDeleteStartedOnSameLine line mbLineSplitTextEdits + | Just lineSplitTextEdits <- mbLineSplitTextEdits , let LineSplitTextEdits{ lineSplitDeleteTextEdit } = lineSplitTextEdits , let LSP.TextEdit deleteRange _ = lineSplitDeleteTextEdit , let LSP.Range _ deleteEndPosition = deleteRange @@ -303,11 +268,7 @@ lexUntilNextLineIncl :: P (Located Token) lexUntilNextLineIncl = do PState{ last_loc } <- getPState -#if MIN_VERSION_ghc(9,0,0) let PsSpan{ psRealSpan = lastRealSrcSpan } = last_loc -#else - let lastRealSrcSpan = last_loc -#endif let prevEndLine = lastRealSrcSpan & realSrcSpanEnd & srcLocLine locatedToken@(L srcSpan _token) <- lexer False pure if | RealSrcLoc currEndRealSrcLoc _ <- srcSpan & srcSpanEnd diff --git a/src/Development/IDE/Types/Action.hs b/src/Development/IDE/Types/Action.hs --- a/src/Development/IDE/Types/Action.hs +++ b/src/Development/IDE/Types/Action.hs @@ -11,12 +11,12 @@ where import Control.Concurrent.STM -import Data.Hashable (Hashable (..)) -import Data.HashSet (HashSet) -import qualified Data.HashSet as Set -import Data.Unique (Unique) -import Development.IDE.Graph (Action) -import Development.IDE.Types.Logger +import Data.Hashable (Hashable (..)) +import Data.HashSet (HashSet) +import qualified Data.HashSet as Set +import Data.Unique (Unique) +import Development.IDE.Graph (Action) +import Ide.Logger import Numeric.Natural data DelayedAction a = DelayedAction diff --git a/src/Development/IDE/Types/Diagnostics.hs b/src/Development/IDE/Types/Diagnostics.hs --- a/src/Development/IDE/Types/Diagnostics.hs +++ b/src/Development/IDE/Types/Diagnostics.hs @@ -1,36 +1,60 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} module Development.IDE.Types.Diagnostics ( LSP.Diagnostic(..), ShowDiagnostic(..), - FileDiagnostic, + FileDiagnostic(..), + fdFilePathL, + fdLspDiagnosticL, + fdShouldShowDiagnosticL, + fdStructuredMessageL, + StructuredMessage(..), + _NoStructuredMessage, + _SomeStructuredMessage, IdeResult, LSP.DiagnosticSeverity(..), DiagnosticStore, - List(..), ideErrorText, ideErrorWithSource, + ideErrorFromLspDiag, showDiagnostics, showDiagnosticsColored, - IdeResultNoDiagnosticsEarlyCutoff) where + showGhcCode, + IdeResultNoDiagnosticsEarlyCutoff, + attachReason, + attachedReason) where import Control.DeepSeq -import Data.Maybe as Maybe -import qualified Data.Text as T -import Data.Text.Prettyprint.Doc -import Data.Text.Prettyprint.Doc.Render.Terminal (Color (..), color) -import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal -import Data.Text.Prettyprint.Doc.Render.Text -import Language.LSP.Diagnostics -import Language.LSP.Types as LSP (Diagnostic (..), - DiagnosticSeverity (..), - DiagnosticSource, - List (..)) - -import Data.ByteString (ByteString) +import Control.Lens +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Lens as JSON +import Data.ByteString (ByteString) +import Data.Foldable +import Data.Maybe as Maybe +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcMessage, MsgEnvelope, + WarningFlag, flagSpecFlag, + flagSpecName, wWarningFlags) import Development.IDE.Types.Location +import GHC.Generics +import GHC.Types.Error (DiagnosticCode (..), + DiagnosticReason (..), + diagnosticCode, + diagnosticReason, + errMsgDiagnostic) +import Language.LSP.Diagnostics +import Language.LSP.Protocol.Lens (data_) +import Language.LSP.Protocol.Types as LSP +import Prettyprinter +import Prettyprinter.Render.Terminal (Color (..), color) +import qualified Prettyprinter.Render.Terminal as Terminal +import Prettyprinter.Render.Text +import Text.Printf (printf) -- | The result of an IDE operation. Warnings and errors are in the Diagnostic, @@ -48,24 +72,97 @@ -- | an IdeResult with a fingerprint type IdeResultNoDiagnosticsEarlyCutoff v = (Maybe ByteString, Maybe v) +-- | Produce a 'FileDiagnostic' for the given 'NormalizedFilePath' +-- with an error message. ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic -ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError) +ideErrorText nfp msg = + ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error) nfp msg Nothing +-- | Create a 'FileDiagnostic' from an existing 'LSP.Diagnostic' for a +-- specific 'NormalizedFilePath'. +-- The optional 'MsgEnvelope GhcMessage' is the original error message +-- that was used for creating the 'LSP.Diagnostic'. +-- It is included here, to allow downstream consumers, such as HLS plugins, +-- to provide LSP features based on the structured error messages. +-- Additionally, if available, we insert the ghc error code into the +-- 'LSP.Diagnostic'. These error codes are used in https://errors.haskell.org/ +-- to provide documentation and explanations for error messages. +ideErrorFromLspDiag + :: LSP.Diagnostic + -> NormalizedFilePath + -> Maybe (MsgEnvelope GhcMessage) + -> FileDiagnostic +ideErrorFromLspDiag lspDiag fdFilePath mbOrigMsg = + let fdShouldShowDiagnostic = ShowDiag + fdStructuredMessage = + case mbOrigMsg of + Nothing -> NoStructuredMessage + Just msg -> SomeStructuredMessage msg + fdLspDiagnostic = + lspDiag + & attachReason (fmap (diagnosticReason . errMsgDiagnostic) mbOrigMsg) + & attachDiagnosticCode ((diagnosticCode . errMsgDiagnostic) =<< mbOrigMsg) + in + FileDiagnostic {..} + +-- | Set the code of the 'LSP.Diagnostic' to the GHC diagnostic code, and include the link +-- to https://errors.haskell.org/. +attachDiagnosticCode :: Maybe DiagnosticCode -> LSP.Diagnostic -> LSP.Diagnostic +attachDiagnosticCode Nothing diag = diag +attachDiagnosticCode (Just code) diag = + let + textualCode = showGhcCode code + codeDesc = LSP.CodeDescription{ _href = Uri $ "https://errors.haskell.org/messages/" <> textualCode } + in diag { _code = Just (InR textualCode), _codeDescription = Just codeDesc} + +#if MIN_VERSION_ghc(9,9,0) +-- DiagnosticCode only got a show instance in 9.10.1 +showGhcCode :: DiagnosticCode -> T.Text +showGhcCode = T.pack . show +#else +showGhcCode :: DiagnosticCode -> T.Text +showGhcCode (DiagnosticCode prefix c) = T.pack $ prefix ++ "-" ++ printf "%05d" c +#endif + +attachedReason :: Traversal' Diagnostic (Maybe JSON.Value) +attachedReason = data_ . non (JSON.object []) . JSON.atKey "attachedReason" + +attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic +attachReason Nothing = id +attachReason (Just wr) = attachedReason .~ fmap JSON.toJSON (showReason wr) + where + showReason = \case + WarningWithFlag flag -> Just $ catMaybes [showFlag flag] +#if MIN_VERSION_ghc(9,7,0) + WarningWithFlags flags -> Just $ catMaybes (fmap showFlag $ toList flags) +#endif + _ -> Nothing + +showFlag :: WarningFlag -> Maybe T.Text +showFlag flag = ("-W" <>) . T.pack . flagSpecName <$> find ((== flag) . flagSpecFlag) wWarningFlags + ideErrorWithSource - :: Maybe DiagnosticSource + :: Maybe T.Text -> Maybe DiagnosticSeverity - -> a + -> NormalizedFilePath -> T.Text - -> (a, ShowDiagnostic, Diagnostic) -ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic { - _range = noRange, - _severity = sev, - _code = Nothing, - _source = source, - _message = msg, - _relatedInformation = Nothing, - _tags = Nothing - }) + -> Maybe (MsgEnvelope GhcMessage) + -> FileDiagnostic +ideErrorWithSource source sev fdFilePath msg origMsg = + let lspDiagnostic = + LSP.Diagnostic { + _range = noRange, + _severity = sev, + _code = Nothing, + _source = source, + _message = msg, + _relatedInformation = Nothing, + _tags = Nothing, + _codeDescription = Nothing, + _data_ = Nothing + } + in + ideErrorFromLspDiag lspDiagnostic fdFilePath origMsg -- | Defines whether a particular diagnostic should be reported -- back to the user. @@ -82,14 +179,79 @@ instance NFData ShowDiagnostic where rnf = rwhnf +-- | A Maybe-like wrapper for a GhcMessage that doesn't try to compare, show, or +-- force the GhcMessage inside, so that we can derive Show, Eq, Ord, NFData on +-- FileDiagnostic. FileDiagnostic only uses this as metadata so we can safely +-- ignore it in fields. +-- +-- Instead of pattern matching on these constructors directly, consider 'Prism' from +-- the 'lens' package. This allows to conveniently pattern match deeply into the 'MsgEnvelope GhcMessage' +-- constructor. +-- The module 'Development.IDE.GHC.Compat.Error' implements additional 'Lens's and 'Prism's, +-- allowing you to avoid importing GHC modules directly. +-- +-- For example, to pattern match on a 'TcRnMessage' you can use the lens: +-- +-- @ +-- message ^? _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage +-- @ +-- +-- This produces a value of type `Maybe TcRnMessage`. +-- +-- Further, consider utility functions such as 'stripTcRnMessageContext', which strip +-- context from error messages which may be more convenient in certain situations. +data StructuredMessage + = NoStructuredMessage + | SomeStructuredMessage (MsgEnvelope GhcMessage) + deriving (Generic) + +instance Show StructuredMessage where + show NoStructuredMessage = "NoStructuredMessage" + show SomeStructuredMessage {} = "SomeStructuredMessage" + +instance Eq StructuredMessage where + (==) NoStructuredMessage NoStructuredMessage = True + (==) SomeStructuredMessage {} SomeStructuredMessage {} = True + (==) _ _ = False + +instance Ord StructuredMessage where + compare NoStructuredMessage NoStructuredMessage = EQ + compare SomeStructuredMessage {} SomeStructuredMessage {} = EQ + compare NoStructuredMessage SomeStructuredMessage {} = GT + compare SomeStructuredMessage {} NoStructuredMessage = LT + +instance NFData StructuredMessage where + rnf NoStructuredMessage = () + rnf SomeStructuredMessage {} = () + -- | Human readable diagnostics for a specific file. -- -- This type packages a pretty printed, human readable error message -- along with the related source location so that we can display the error -- on either the console or in the IDE at the right source location. -- -type FileDiagnostic = (NormalizedFilePath, ShowDiagnostic, Diagnostic) +-- It also optionally keeps a structured diagnostic message GhcMessage in +-- StructuredMessage. +-- +data FileDiagnostic = FileDiagnostic + { fdFilePath :: NormalizedFilePath + , fdShouldShowDiagnostic :: ShowDiagnostic + , fdLspDiagnostic :: Diagnostic + -- | The original diagnostic that was used to produce 'fdLspDiagnostic'. + -- We keep it here, so downstream consumers, e.g. HLS plugins, can use the + -- the structured error messages and don't have to resort to parsing + -- error messages via regexes or similar. + -- + -- The optional GhcMessage inside of this StructuredMessage is ignored for + -- Eq, Ord, Show, and NFData instances. This is fine because this field + -- should only ever be metadata and should never be used to distinguish + -- between FileDiagnostics. + , fdStructuredMessage :: StructuredMessage + } + deriving (Eq, Ord, Show, Generic) +instance NFData FileDiagnostic + prettyRange :: Range -> Doc Terminal.AnsiStyle prettyRange Range{..} = f _start <> "-" <> f _end where f Position{..} = pretty (show $ _line+1) <> colon <> pretty (show $ _character+1) @@ -108,23 +270,27 @@ prettyDiagnostics = vcat . map prettyDiagnostic prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle -prettyDiagnostic (fp, sh, LSP.Diagnostic{..}) = +prettyDiagnostic FileDiagnostic { fdFilePath, fdShouldShowDiagnostic, fdLspDiagnostic = LSP.Diagnostic{..} } = vcat - [ slabel_ "File: " $ pretty (fromNormalizedFilePath fp) - , slabel_ "Hidden: " $ if sh == ShowDiag then "no" else "yes" + [ slabel_ "File: " $ pretty (fromNormalizedFilePath fdFilePath) + , slabel_ "Hidden: " $ if fdShouldShowDiagnostic == ShowDiag then "no" else "yes" , slabel_ "Range: " $ prettyRange _range , slabel_ "Source: " $ pretty _source , slabel_ "Severity:" $ pretty $ show sev + , slabel_ "Code: " $ case _code of + Just (InR text) -> pretty text + Just (InL i) -> pretty i + Nothing -> "" , slabel_ "Message: " $ case sev of - LSP.DsError -> annotate $ color Red - LSP.DsWarning -> annotate $ color Yellow - LSP.DsInfo -> annotate $ color Blue - LSP.DsHint -> annotate $ color Magenta + LSP.DiagnosticSeverity_Error -> annotate $ color Red + LSP.DiagnosticSeverity_Warning -> annotate $ color Yellow + LSP.DiagnosticSeverity_Information -> annotate $ color Blue + LSP.DiagnosticSeverity_Hint -> annotate $ color Magenta $ stringParagraphs _message ] where - sev = fromMaybe LSP.DsError _severity + sev = fromMaybe LSP.DiagnosticSeverity_Error _severity -- | Label a document. @@ -152,3 +318,9 @@ defaultTermWidth :: Int defaultTermWidth = 80 + +makePrisms ''StructuredMessage + +makeLensesWith + (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) + ''FileDiagnostic diff --git a/src/Development/IDE/Types/Exports.hs b/src/Development/IDE/Types/Exports.hs --- a/src/Development/IDE/Types/Exports.hs +++ b/src/Development/IDE/Types/Exports.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE RankNTypes #-} module Development.IDE.Types.Exports ( IdentInfo(..), @@ -23,21 +22,18 @@ import Control.DeepSeq (NFData (..), force, ($!!)) import Control.Monad -import Data.Bifunctor (Bifunctor (second)) import Data.Char (isUpper) import Data.Hashable (Hashable) -import Data.HashMap.Strict (HashMap, elems) -import qualified Data.HashMap.Strict as Map import Data.HashSet (HashSet) import qualified Data.HashSet as Set -import Data.List (foldl', isSuffixOf) +import Data.List (isSuffixOf) import Data.Text (Text, uncons) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () -import Development.IDE.GHC.Util import GHC.Generics (Generic) -import HieDb +import HieDb hiding (withHieDb) +import Prelude hiding (mod) data ExportsMap = ExportsMap @@ -46,14 +42,14 @@ } instance NFData ExportsMap where - rnf (ExportsMap a b) = foldOccEnv (\a b -> rnf a `seq` b) (seqEltsUFM rnf b) a + rnf (ExportsMap a b) = nonDetFoldOccEnv (\c d -> rnf c `seq` d) (seqEltsUFM rnf b) a instance Show ExportsMap where show (ExportsMap occs mods) = unwords [ "ExportsMap { getExportsMap =" - , printWithoutUniques $ mapOccEnv (text . show) occs + , printWithoutUniques $ mapOccEnv (textDoc . show) occs , "getModuleExportsMap =" - , printWithoutUniques $ mapUFM (text . show) mods + , printWithoutUniques $ mapUFM (textDoc . show) mods , "}" ] @@ -63,13 +59,13 @@ updateExportsMap :: ExportsMap -> ExportsMap -> ExportsMap updateExportsMap old new = ExportsMap { getExportsMap = delListFromOccEnv (getExportsMap old) old_occs `plusOccEnv` getExportsMap new -- plusOccEnv is right biased - , getModuleExportsMap = (getModuleExportsMap old) `plusUFM` (getModuleExportsMap new) -- plusUFM is right biased + , getModuleExportsMap = getModuleExportsMap old `plusUFM` getModuleExportsMap new -- plusUFM is right biased } where old_occs = concat [map name $ Set.toList (lookupWithDefaultUFM_Directly (getModuleExportsMap old) mempty m_uniq) | m_uniq <- nonDetKeysUFM (getModuleExportsMap new)] size :: ExportsMap -> Int -size = sum . map (Set.size) . nonDetOccEnvElts . getExportsMap +size = sum . map Set.size . nonDetOccEnvElts . getExportsMap mkVarOrDataOcc :: Text -> OccName mkVarOrDataOcc t = mkOcc $ mkFastStringByteString $ encodeUtf8 t @@ -83,7 +79,7 @@ mkTypeOcc t = mkTcOccFS $ mkFastStringByteString $ encodeUtf8 t exportsMapSize :: ExportsMap -> Int -exportsMapSize = foldOccEnv (\_ x -> x+1) 0 . getExportsMap +exportsMapSize = nonDetFoldOccEnv (\_ x -> x+1) 0 . getExportsMap instance Semigroup ExportsMap where ExportsMap a b <> ExportsMap c d = ExportsMap (plusOccEnv_C (<>) a c) (plusUFM_C (<>) b d) @@ -144,8 +140,8 @@ mkIdentInfos mod (AvailTC parent (n:nn) flds) -- Following the GHC convention that parent == n if parent is exported | n == parent - = [ IdentInfo (nameOccName n) (Just $! nameOccName parent) mod - | n <- nn ++ map flSelector flds + = [ IdentInfo (nameOccName name) (Just $! nameOccName parent) mod + | name <- nn ++ map flSelector flds ] ++ [ IdentInfo (nameOccName n) Nothing mod] @@ -162,7 +158,7 @@ where doOne modIFace = do let getModDetails = unpackAvail $ moduleName $ mi_module modIFace - concatMap (getModDetails) (mi_exports modIFace) + concatMap getModDetails (mi_exports modIFace) createExportsMapMg :: [ModGuts] -> ExportsMap createExportsMapMg modGuts = do @@ -202,7 +198,7 @@ | nonInternalModules mn = map f . mkIdentInfos mn | otherwise = const [] where - f id@IdentInfo {..} = (name, mn, Set.singleton id) + f identInfo@IdentInfo {..} = (name, mn, Set.singleton identInfo) identInfoToKeyVal :: IdentInfo -> (ModuleName, IdentInfo) @@ -211,7 +207,7 @@ buildModuleExportMap:: [(ModuleName, HashSet IdentInfo)] -> ModuleNameEnv (HashSet IdentInfo) buildModuleExportMap exportsMap = do - let lst = concatMap (Set.toList. snd) exportsMap + let lst = concatMap (Set.toList . snd) exportsMap let lstThree = map identInfoToKeyVal lst sortAndGroup lstThree @@ -227,4 +223,4 @@ (modName, functionSet) sortAndGroup :: [(ModuleName, IdentInfo)] -> ModuleNameEnv (HashSet IdentInfo) -sortAndGroup assocs = listToUFM_C (<>) [(k, Set.fromList [v]) | (k, v) <- assocs] +sortAndGroup assocs = listToUFM_C (<>) [(k, Set.singleton v) | (k, v) <- assocs] diff --git a/src/Development/IDE/Types/HscEnvEq.hs b/src/Development/IDE/Types/HscEnvEq.hs --- a/src/Development/IDE/Types/HscEnvEq.hs +++ b/src/Development/IDE/Types/HscEnvEq.hs @@ -1,48 +1,38 @@ +{-# LANGUAGE CPP #-} module Development.IDE.Types.HscEnvEq ( HscEnvEq, hscEnv, newHscEnvEq, - hscEnvWithImportPaths, - newHscEnvEqPreserveImportPaths, - newHscEnvEqWithImportPaths, - envImportPaths, + updateHscEnvEq, envPackageExports, envVisibleModuleNames, - deps ) where import Control.Concurrent.Async (Async, async, waitCatch) import Control.Concurrent.Strict (modifyVar, newVar) -import Control.DeepSeq (force) +import Control.DeepSeq (force, rwhnf) import Control.Exception (evaluate, mask, throwIO) import Control.Monad.Extra (eitherM, join, mapMaybeM) import Data.Either (fromRight) -import Data.Set (Set) -import qualified Data.Set as Set +import Data.IORef import Data.Unique (Unique) import qualified Data.Unique as Unique -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat hiding (newUnique) import qualified Development.IDE.GHC.Compat.Util as Maybes import Development.IDE.GHC.Error (catchSrcErrors) import Development.IDE.GHC.Util (lookupPackageConfig) import Development.IDE.Graph.Classes import Development.IDE.Types.Exports (ExportsMap, createExportsMap) +import GHC.Driver.Env (hsc_all_home_unit_ids) import OpenTelemetry.Eventlog (withSpan) -import System.Directory (makeAbsolute) -import System.FilePath + -- | An 'HscEnv' with equality. Two values are considered equal --- if they are created with the same call to 'newHscEnvEq'. +-- if they are created with the same call to 'newHscEnvEq' or +-- 'updateHscEnvEq'. data HscEnvEq = HscEnvEq { envUnique :: !Unique , hscEnv :: !HscEnv - , deps :: [(UnitId, DynFlags)] - -- ^ In memory components for this HscEnv - -- This is only used at the moment for the import dirs in - -- the DynFlags - , envImportPaths :: Maybe (Set FilePath) - -- ^ If Just, import dirs originally configured in this env - -- If Nothing, the env import dirs are unaltered , envPackageExports :: IO ExportsMap , envVisibleModuleNames :: IO (Maybe [ModuleName]) -- ^ 'listVisibleModuleNames' is a pure function, @@ -51,20 +41,45 @@ -- If Nothing, 'listVisibleModuleNames' panic } --- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEq cradlePath hscEnv0 deps = do - let relativeToCradle = (takeDirectory cradlePath ) - hscEnv = removeImportPaths hscEnv0 +updateHscEnvEq :: HscEnvEq -> HscEnv -> IO HscEnvEq +updateHscEnvEq oldHscEnvEq newHscEnv = do + let update newUnique = oldHscEnvEq { envUnique = newUnique, hscEnv = newHscEnv } + update <$> Unique.newUnique - -- Make Absolute since targets are also absolute - importPathsCanon <- - mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) +-- | Wrap an 'HscEnv' into an 'HscEnvEq'. +newHscEnvEq :: HscEnv -> IO HscEnvEq +newHscEnvEq hscEnv' = do - newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps + mod_cache <- newIORef emptyInstalledModuleEnv + -- This finder cache is for things which are outside of things which are tracked + -- by HLS. For example, non-home modules, dependent object files etc +#if MIN_VERSION_ghc(9,11,0) + let hscEnv = hscEnv' + { hsc_FC = FinderCache + { flushFinderCaches = \_ -> error "GHC should never call flushFinderCaches outside the driver" +#if MIN_VERSION_ghc(9,13,0) + , addToFinderCache = \im val -> do +#else + , addToFinderCache = \(GWIB im _) val -> do +#endif + if moduleUnit im `elem` hsc_all_home_unit_ids hscEnv' + then error "tried to add home module to FC" + else atomicModifyIORef' mod_cache $ \c -> (extendInstalledModuleEnv c im val, ()) +#if MIN_VERSION_ghc(9,13,0) + , lookupFinderCache = \im -> do +#else + , lookupFinderCache = \(GWIB im _) -> do +#endif + if moduleUnit im `elem` hsc_all_home_unit_ids hscEnv' + then error ("tried to lookup home module from FC" ++ showSDocUnsafe (ppr (im, hsc_all_home_unit_ids hscEnv'))) + else lookupInstalledModuleEnv <$> readIORef mod_cache <*> pure im + , lookupFileCache = \fp -> error ("not used by HLS" ++ fp) + } + } -newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do +#else + let hscEnv = hscEnv' +#endif let dflags = hsc_dflags hscEnv @@ -84,7 +99,7 @@ -- When module is re-exported from another package, -- the origin module is represented by value in Just Just otherPkgMod -> otherPkgMod - Nothing -> mkModule (unitInfoId pkg) modName + Nothing -> mkModule (mkUnit pkg) modName ] doOne m = do @@ -106,23 +121,6 @@ return HscEnvEq{..} --- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEqPreserveImportPaths - :: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing - --- | Unwrap the 'HscEnv' with the original import paths. --- Used only for locating imports -hscEnvWithImportPaths :: HscEnvEq -> HscEnv -hscEnvWithImportPaths HscEnvEq{..} - | Just imps <- envImportPaths - = hscSetFlags (setImportPaths (Set.toList imps) (hsc_dflags hscEnv)) hscEnv - | otherwise - = hscEnv - -removeImportPaths :: HscEnv -> HscEnv -removeImportPaths hsc = hscSetFlags (setImportPaths [] (hsc_dflags hsc)) hsc - instance Show HscEnvEq where show HscEnvEq{envUnique} = "HscEnvEq " ++ show (Unique.hashUnique envUnique) @@ -130,9 +128,9 @@ a == b = envUnique a == envUnique b instance NFData HscEnvEq where - rnf (HscEnvEq a b c d _ _) = + rnf (HscEnvEq a b _ _) = -- deliberately skip the package exports map and visible module names - rnf (Unique.hashUnique a) `seq` b `seq` c `seq` rnf d + rnf (Unique.hashUnique a) `seq` rwhnf b instance Hashable HscEnvEq where hashWithSalt s = hashWithSalt s . envUnique diff --git a/src/Development/IDE/Types/KnownTargets.hs b/src/Development/IDE/Types/KnownTargets.hs --- a/src/Development/IDE/Types/KnownTargets.hs +++ b/src/Development/IDE/Types/KnownTargets.hs @@ -1,6 +1,11 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} -module Development.IDE.Types.KnownTargets (KnownTargets, Target(..), toKnownFiles) where +module Development.IDE.Types.KnownTargets ( KnownTargets(..) + , emptyKnownTargets + , mkKnownTargets + , unionKnownTargets + , Target(..) + , toKnownFiles) where import Control.DeepSeq import Data.Hashable @@ -14,11 +19,33 @@ import GHC.Generics -- | A mapping of module name to known files -type KnownTargets = HashMap Target (HashSet NormalizedFilePath) +newtype KnownTargets = KnownTargets + { targetMap :: (HashMap Target (HashSet NormalizedFilePath)) } + deriving Show + +unionKnownTargets :: KnownTargets -> KnownTargets -> KnownTargets +unionKnownTargets (KnownTargets tm) (KnownTargets tm') = + KnownTargets (HMap.unionWith (<>) tm tm') + +mkKnownTargets :: [(Target, HashSet NormalizedFilePath)] -> KnownTargets +mkKnownTargets vs = KnownTargets (HMap.fromList vs) + +instance NFData KnownTargets where + rnf (KnownTargets tm) = rnf tm `seq` () + +instance Eq KnownTargets where + k1 == k2 = targetMap k1 == targetMap k2 + +instance Hashable KnownTargets where + hashWithSalt s (KnownTargets hm) = hashWithSalt s hm + +emptyKnownTargets :: KnownTargets +emptyKnownTargets = KnownTargets HMap.empty + data Target = TargetModule ModuleName | TargetFile NormalizedFilePath - deriving ( Eq, Generic, Show ) + deriving ( Eq, Ord, Generic, Show ) deriving anyclass (Hashable, NFData) toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath -toKnownFiles = HSet.unions . HMap.elems +toKnownFiles = HSet.unions . HMap.elems . targetMap diff --git a/src/Development/IDE/Types/Location.hs b/src/Development/IDE/Types/Location.hs --- a/src/Development/IDE/Types/Location.hs +++ b/src/Development/IDE/Types/Location.hs @@ -2,7 +2,6 @@ -- SPDX-License-Identifier: Apache-2.0 {-# LANGUAGE CPP #-} - -- | Types and functions for working with source code locations. module Development.IDE.Types.Location ( Location(..) @@ -31,18 +30,13 @@ import Data.Hashable (Hashable (hash)) import Data.Maybe (fromMaybe) import Data.String +import Language.LSP.Protocol.Types (Location (..), Position (..), + Range (..)) +import qualified Language.LSP.Protocol.Types as LSP +import Text.ParserCombinators.ReadP as ReadP -#if MIN_VERSION_ghc(9,0,0) import GHC.Data.FastString import GHC.Types.SrcLoc as GHC -#else -import FastString -import SrcLoc as GHC -#endif -import Language.LSP.Types (Location (..), Position (..), - Range (..)) -import qualified Language.LSP.Types as LSP -import Text.ParserCombinators.ReadP as ReadP toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath -- We want to keep empty paths instead of normalising them to "." diff --git a/src/Development/IDE/Types/Logger.hs b/src/Development/IDE/Types/Logger.hs deleted file mode 100644 --- a/src/Development/IDE/Types/Logger.hs +++ /dev/null @@ -1,393 +0,0 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} --- | This is a compatibility module that abstracts over the --- concrete choice of logging framework so users can plug in whatever --- framework they want to. -module Development.IDE.Types.Logger - ( Priority(..) - , Logger(..) - , Recorder(..) - , logError, logWarning, logInfo, logDebug - , noLogging - , WithPriority(..) - , logWith - , cmap - , cmapIO - , cfilter - , withDefaultRecorder - , makeDefaultStderrRecorder - , priorityToHsLoggerPriority - , LoggingColumn(..) - , cmapWithPrio - , withBacklog - , lspClientMessageRecorder - , lspClientLogRecorder - , module PrettyPrinterModule - , renderStrict - , toCologActionWithPrio - ) where - -import Control.Concurrent (myThreadId) -import Control.Concurrent.Extra (Lock, newLock, withLock) -import Control.Concurrent.STM (atomically, - flushTBQueue, - isFullTBQueue, - newTBQueueIO, newTVarIO, - readTVarIO, - writeTBQueue, writeTVar) -import Control.Exception (IOException) -import Control.Monad (forM_, unless, when, - (>=>)) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Foldable (for_) -import Data.Functor.Contravariant (Contravariant (contramap)) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Data.Time (defaultTimeLocale, - formatTime, - getCurrentTime) -import GHC.Stack (CallStack, HasCallStack, - SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine), - callStack, getCallStack, - withFrozenCallStack) -import Language.LSP.Server -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (LogMessageParams (..), - MessageType (..), - SMethod (SWindowLogMessage, SWindowShowMessage), - ShowMessageParams (..)) -#if MIN_VERSION_prettyprinter(1,7,0) -import Prettyprinter as PrettyPrinterModule -import Prettyprinter.Render.Text (renderStrict) -#else -import Data.Text.Prettyprint.Doc as PrettyPrinterModule -import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) -#endif -import Colog.Core (LogAction (..), - Severity, - WithSeverity (..)) -import qualified Colog.Core as Colog -import System.IO (Handle, - IOMode (AppendMode), - hClose, hFlush, - hSetEncoding, openFile, - stderr, utf8) -import qualified System.Log.Formatter as HSL -import qualified System.Log.Handler as HSL -import qualified System.Log.Handler.Simple as HSL -import qualified System.Log.Logger as HsLogger -import UnliftIO (MonadUnliftIO, - displayException, - finally, try) - -data Priority --- Don't change the ordering of this type or you will mess up the Ord --- instance - = Debug -- ^ Verbose debug logging. - | Info -- ^ Useful information in case an error has to be understood. - | Warning - -- ^ These error messages should not occur in a expected usage, and - -- should be investigated. - | Error -- ^ Such log messages must never occur in expected usage. - deriving (Eq, Show, Ord, Enum, Bounded) - --- | Note that this is logging actions _of the program_, not of the user. --- You shouldn't call warning/error if the user has caused an error, only --- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). -newtype Logger = Logger {logPriority :: Priority -> T.Text -> IO ()} - -instance Semigroup Logger where - l1 <> l2 = Logger $ \p t -> logPriority l1 p t >> logPriority l2 p t - -instance Monoid Logger where - mempty = Logger $ \_ _ -> pure () - -logError :: Logger -> T.Text -> IO () -logError x = logPriority x Error - -logWarning :: Logger -> T.Text -> IO () -logWarning x = logPriority x Warning - -logInfo :: Logger -> T.Text -> IO () -logInfo x = logPriority x Info - -logDebug :: Logger -> T.Text -> IO () -logDebug x = logPriority x Debug - -noLogging :: Logger -noLogging = Logger $ \_ _ -> return () - -data WithPriority a = WithPriority { priority :: Priority, callStack_ :: CallStack, payload :: a } deriving Functor - --- | Note that this is logging actions _of the program_, not of the user. --- You shouldn't call warning/error if the user has caused an error, only --- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). -newtype Recorder msg = Recorder - { logger_ :: forall m. (MonadIO m) => msg -> m () } - -logWith :: (HasCallStack, MonadIO m) => Recorder (WithPriority msg) -> Priority -> msg -> m () -logWith recorder priority msg = withFrozenCallStack $ logger_ recorder (WithPriority priority callStack msg) - -instance Semigroup (Recorder msg) where - (<>) Recorder{ logger_ = logger_1 } Recorder{ logger_ = logger_2 } = - Recorder - { logger_ = \msg -> logger_1 msg >> logger_2 msg } - -instance Monoid (Recorder msg) where - mempty = - Recorder - { logger_ = \_ -> pure () } - -instance Contravariant Recorder where - contramap f Recorder{ logger_ } = - Recorder - { logger_ = logger_ . f } - -cmap :: (a -> b) -> Recorder b -> Recorder a -cmap = contramap - -cmapWithPrio :: (a -> b) -> Recorder (WithPriority b) -> Recorder (WithPriority a) -cmapWithPrio f = cmap (fmap f) - -cmapIO :: (a -> IO b) -> Recorder b -> Recorder a -cmapIO f Recorder{ logger_ } = - Recorder - { logger_ = (liftIO . f) >=> logger_ } - -cfilter :: (a -> Bool) -> Recorder a -> Recorder a -cfilter p Recorder{ logger_ } = - Recorder - { logger_ = \msg -> when (p msg) (logger_ msg) } - -textHandleRecorder :: Handle -> Recorder Text -textHandleRecorder handle = - Recorder - { logger_ = \text -> liftIO $ Text.hPutStrLn handle text *> hFlush handle } - --- | Priority is actually for hslogger compatibility -makeDefaultStderrRecorder :: MonadIO m => Maybe [LoggingColumn] -> Priority -> m (Recorder (WithPriority (Doc a))) -makeDefaultStderrRecorder columns minPriority = do - lock <- liftIO newLock - makeDefaultHandleRecorder columns minPriority lock stderr - --- | If no path given then use stderr, otherwise use file. --- Kinda complicated because we also need to setup `hslogger` for --- `hie-bios` log compatibility reasons. If `hie-bios` can be set to use our --- logger instead or if `hie-bios` doesn't use `hslogger` then `hslogger` can --- be removed completely. See `setupHsLogger` comment. -withDefaultRecorder - :: MonadUnliftIO m - => Maybe FilePath - -- ^ Log file path. `Nothing` uses stderr - -> Maybe [LoggingColumn] - -- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns` - -> Priority - -- ^ min priority for hslogger compatibility - -> (Recorder (WithPriority (Doc d)) -> m a) - -- ^ action given a recorder - -> m a -withDefaultRecorder path columns minPriority action = do - lock <- liftIO newLock - let makeHandleRecorder = makeDefaultHandleRecorder columns minPriority lock - case path of - Nothing -> do - recorder <- makeHandleRecorder stderr - let message = "No log file specified; using stderr." - logWith recorder Info message - action recorder - Just path -> do - fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode) - case fileHandle of - Left e -> do - recorder <- makeHandleRecorder stderr - let exceptionMessage = pretty $ displayException e - let message = vcat [exceptionMessage, "Couldn't open log file" <+> pretty path <> "; falling back to stderr."] - logWith recorder Warning message - action recorder - Right fileHandle -> finally (makeHandleRecorder fileHandle >>= action) (liftIO $ hClose fileHandle) - -makeDefaultHandleRecorder - :: MonadIO m - => Maybe [LoggingColumn] - -- ^ built-in logging columns to display. Nothing uses the default - -> Priority - -- ^ min priority for hslogger compatibility - -> Lock - -- ^ lock to take when outputting to handle - -> Handle - -- ^ handle to output to - -> m (Recorder (WithPriority (Doc a))) -makeDefaultHandleRecorder columns minPriority lock handle = do - let Recorder{ logger_ } = textHandleRecorder handle - let threadSafeRecorder = Recorder { logger_ = \msg -> liftIO $ withLock lock (logger_ msg) } - let loggingColumns = fromMaybe defaultLoggingColumns columns - let textWithPriorityRecorder = cmapIO (textWithPriorityToText loggingColumns) threadSafeRecorder - -- see `setupHsLogger` comment - liftIO $ setupHsLogger lock handle ["hls", "hie-bios"] (priorityToHsLoggerPriority minPriority) - pure (cmap docToText textWithPriorityRecorder) - where - docToText = fmap (renderStrict . layoutPretty defaultLayoutOptions) - -priorityToHsLoggerPriority :: Priority -> HsLogger.Priority -priorityToHsLoggerPriority = \case - Debug -> HsLogger.DEBUG - Info -> HsLogger.INFO - Warning -> HsLogger.WARNING - Error -> HsLogger.ERROR - --- | The purpose of setting up `hslogger` at all is that `hie-bios` uses --- `hslogger` to output compilation logs. The easiest way to merge these logs --- with our log output is to setup an `hslogger` that uses the same handle --- and same lock as our loggers. That way the output from our loggers and --- `hie-bios` don't interleave strangely. --- It may be possible to have `hie-bios` use our logger by decorating the --- `Cradle.cradleOptsProg.runCradle` we get in the Cradle from --- `HieBios.findCradle`, but I remember trying that and something not good --- happened. I'd have to try it again to remember if that was a real issue. --- Once that is figured out or `hie-bios` doesn't use `hslogger`, then all --- references to `hslogger` can be removed entirely. -setupHsLogger :: Lock -> Handle -> [String] -> HsLogger.Priority -> IO () -setupHsLogger lock handle extraLogNames level = do - hSetEncoding handle utf8 - - logH <- HSL.streamHandler handle level - - let logHandle = logH - { HSL.writeFunc = \a s -> withLock lock $ HSL.writeFunc logH a s } - logFormatter = HSL.tfLogFormatter logDateFormat logFormat - logHandler = HSL.setFormatter logHandle logFormatter - - HsLogger.updateGlobalLogger HsLogger.rootLoggerName $ HsLogger.setHandlers ([] :: [HSL.GenericHandler Handle]) - HsLogger.updateGlobalLogger "haskell-lsp" $ HsLogger.setHandlers [logHandler] - HsLogger.updateGlobalLogger "haskell-lsp" $ HsLogger.setLevel level - - -- Also route the additional log names to the same log - forM_ extraLogNames $ \logName -> do - HsLogger.updateGlobalLogger logName $ HsLogger.setHandlers [logHandler] - HsLogger.updateGlobalLogger logName $ HsLogger.setLevel level - where - logFormat = "$time [$tid] $prio $loggername:\t$msg" - logDateFormat = "%Y-%m-%d %H:%M:%S%Q" - -data LoggingColumn - = TimeColumn - | ThreadIdColumn - | PriorityColumn - | DataColumn - | SourceLocColumn - -defaultLoggingColumns :: [LoggingColumn] -defaultLoggingColumns = [TimeColumn, PriorityColumn, DataColumn] - -textWithPriorityToText :: [LoggingColumn] -> WithPriority Text -> IO Text -textWithPriorityToText columns WithPriority{ priority, callStack_, payload } = do - textColumns <- mapM loggingColumnToText columns - pure $ Text.intercalate " | " textColumns - where - showAsText :: Show a => a -> Text - showAsText = Text.pack . show - - utcTimeToText utcTime = Text.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime - - priorityToText :: Priority -> Text - priorityToText = showAsText - - threadIdToText = showAsText - - callStackToSrcLoc :: CallStack -> Maybe SrcLoc - callStackToSrcLoc callStack = - case getCallStack callStack of - (_, srcLoc) : _ -> Just srcLoc - _ -> Nothing - - srcLocToText = \case - Nothing -> "" - Just SrcLoc{ srcLocModule, srcLocStartLine, srcLocStartCol } -> - Text.pack srcLocModule <> "#" <> showAsText srcLocStartLine <> ":" <> showAsText srcLocStartCol - - loggingColumnToText :: LoggingColumn -> IO Text - loggingColumnToText = \case - TimeColumn -> do - utcTime <- getCurrentTime - pure (utcTimeToText utcTime) - SourceLocColumn -> pure $ (srcLocToText . callStackToSrcLoc) callStack_ - ThreadIdColumn -> do - threadId <- myThreadId - pure (threadIdToText threadId) - PriorityColumn -> pure (priorityToText priority) - DataColumn -> pure payload - --- | Given a 'Recorder' that requires an argument, produces a 'Recorder' --- that queues up messages until the argument is provided using the callback, at which --- point it sends the backlog and begins functioning normally. -withBacklog :: (v -> Recorder a) -> IO (Recorder a, v -> IO ()) -withBacklog recFun = do - -- Arbitrary backlog capacity - backlog <- newTBQueueIO 100 - let backlogRecorder = Recorder $ \it -> liftIO $ atomically $ do - -- If the queue is full just drop the message on the floor. This is most likely - -- to happen if the callback is just never going to be called; in which case - -- we want neither to build up an unbounded backlog in memory, nor block waiting - -- for space! - full <- isFullTBQueue backlog - unless full $ writeTBQueue backlog it - - -- The variable holding the recorder starts out holding the recorder that writes - -- to the backlog. - recVar <- newTVarIO backlogRecorder - -- The callback atomically swaps out the recorder for the final one, and flushes - -- the backlog to it. - let cb arg = do - let recorder = recFun arg - toRecord <- atomically $ writeTVar recVar recorder >> flushTBQueue backlog - for_ toRecord (logger_ recorder) - - -- The recorder we actually return looks in the variable and uses whatever is there. - let varRecorder = Recorder $ \it -> do - r <- liftIO $ readTVarIO recVar - logger_ r it - - pure (varRecorder, cb) - --- | Creates a recorder that sends logs to the LSP client via @window/showMessage@ notifications. -lspClientMessageRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text) -lspClientMessageRecorder env = Recorder $ \WithPriority {..} -> - liftIO $ LSP.runLspT env $ LSP.sendNotification SWindowShowMessage - ShowMessageParams - { _xtype = priorityToLsp priority, - _message = payload - } - --- | Creates a recorder that sends logs to the LSP client via @window/logMessage@ notifications. -lspClientLogRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text) -lspClientLogRecorder env = Recorder $ \WithPriority {..} -> - liftIO $ LSP.runLspT env $ LSP.sendNotification SWindowLogMessage - LogMessageParams - { _xtype = priorityToLsp priority, - _message = payload - } - -priorityToLsp :: Priority -> MessageType -priorityToLsp = - \case - Debug -> MtLog - Info -> MtInfo - Warning -> MtWarning - Error -> MtError - -toCologActionWithPrio :: (MonadIO m, HasCallStack) => Recorder (WithPriority msg) -> LogAction m (WithSeverity msg) -toCologActionWithPrio (Recorder _logger) = LogAction $ \WithSeverity{..} -> do - let priority = severityToPriority getSeverity - _logger $ WithPriority priority callStack getMsg - where - severityToPriority :: Severity -> Priority - severityToPriority Colog.Debug = Debug - severityToPriority Colog.Info = Info - severityToPriority Colog.Warning = Warning - severityToPriority Colog.Error = Error diff --git a/src/Development/IDE/Types/Options.hs b/src/Development/IDE/Types/Options.hs --- a/src/Development/IDE/Types/Options.hs +++ b/src/Development/IDE/Types/Options.hs @@ -2,7 +2,6 @@ -- SPDX-License-Identifier: Apache-2.0 -- | Options -{-# LANGUAGE RankNTypes #-} module Development.IDE.Types.Options ( IdeOptions(..) , IdePreprocessedSource(..) @@ -19,6 +18,7 @@ , ProgressReportingStyle(..) ) where +import Control.Lens import qualified Data.Text as T import Data.Typeable import Development.IDE.Core.RuleTypes @@ -27,7 +27,8 @@ import Development.IDE.Types.Diagnostics import Ide.Plugin.Config import Ide.Types (DynFlagsModifications) -import qualified Language.LSP.Types.Capabilities as LSP +import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Types as LSP data IdeOptions = IdeOptions { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource @@ -67,10 +68,12 @@ , optCheckParents :: IO CheckParents -- ^ When to typecheck reverse dependencies of a file , optHaddockParse :: OptHaddockParse - -- ^ Whether to return result of parsing module with Opt_Haddock. - -- Otherwise, return the result of parsing without Opt_Haddock, so - -- that the parsed module contains the result of Opt_KeepRawTokenStream, - -- which might be necessary for hlint. + -- ^ Whether to parse modules with '-haddock' by default. + -- If 'HaddockParse' is given, we parse local haskell modules with the + -- '-haddock' flag enables. + -- If a plugin requires the parsed sources *without* '-haddock', it needs + -- to use rules that explicitly disable the '-haddock' flag. + -- See call sites of 'withoutOptHaddock' for rules that parse without '-haddock'. , optModifyDynFlags :: Config -> DynFlagsModifications -- ^ Will be called right after setting up a new cradle, -- allowing to customize the Ghc options used @@ -88,9 +91,9 @@ deriving (Eq,Ord,Show,Enum) data IdePreprocessedSource = IdePreprocessedSource - { preprocWarnings :: [(GHC.SrcSpan, String)] + { preprocWarnings :: [(GHC.SrcSpan, String)] -- TODO: Future work could we make these warnings structured as well? -- ^ Warnings emitted by the preprocessor. - , preprocErrors :: [(GHC.SrcSpan, String)] + , preprocErrors :: [(GHC.SrcSpan, String)] -- TODO: Future work could we make these errors structured as well? -- ^ Errors emitted by the preprocessor. , preprocSource :: GHC.ParsedSource -- ^ New parse tree emitted by the preprocessor. @@ -110,7 +113,7 @@ clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress clientSupportsProgress caps = IdeReportProgress $ Just True == - (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)) + ((\x -> x ^. L.workDoneProgress) =<< LSP._window (caps :: LSP.ClientCapabilities)) defaultIdeOptions :: Action IdeGhcSession -> IdeOptions defaultIdeOptions session = IdeOptions diff --git a/src/Development/IDE/Types/Shake.hs b/src/Development/IDE/Types/Shake.hs --- a/src/Development/IDE/Types/Shake.hs +++ b/src/Development/IDE/Types/Shake.hs @@ -1,20 +1,18 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} module Development.IDE.Types.Shake ( Q (..), A (..), Value (..), ValueWithDiagnostics (..), Values, - Key (..), + Key, BadDependency (..), ShakeValue(..), currentValue, isBadDependency, - toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey,fromKey,fromKeyType,WithHieDb) + toShakeValue,encodeShakeValue,decodeShakeValue,toKey,toNoFileKey,fromKey,fromKeyType,WithHieDb,WithHieDbShield(..)) where import Control.DeepSeq @@ -26,7 +24,8 @@ import Data.Vector (Vector) import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes (FileVersion) -import Development.IDE.Graph (Key (..), RuleResult, newKey) +import Development.IDE.Graph (Key, RuleResult, newKey, + pattern Key) import qualified Development.IDE.Graph as Shake import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location @@ -34,15 +33,17 @@ import HieDb.Types (HieDb) import qualified StmContainers.Map as STM import Type.Reflection (SomeTypeRep (SomeTypeRep), - pattern App, pattern Con, - typeOf, typeRep, - typeRepTyCon) -import Unsafe.Coerce (unsafeCoerce) + eqTypeRep, pattern App, + type (:~~:) (HRefl), + typeOf, typeRep) -- | Intended to represent HieDb calls wrapped with (currently) retry -- functionality type WithHieDb = forall a. (HieDb -> IO a) -> IO a +-- used to smuggle RankNType WithHieDb through dbMVar +newtype WithHieDbShield = WithHieDbShield WithHieDb + data Value v = Succeeded (Maybe FileVersion) v | Stale (Maybe PositionDelta) (Maybe FileVersion) v @@ -84,11 +85,12 @@ -- | 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 +fromKeyType (Key k) + | App tc a <- typeOf k + , Just HRefl <- tc `eqTypeRep` (typeRep @Q) + , Q (_, f) <- k + = Just (SomeTypeRep a, f) + | otherwise = Nothing toNoFileKey :: (Show k, Typeable k, Eq k, Hashable k) => k -> Key toNoFileKey k = newKey $ Q (k, emptyFilePath) @@ -99,12 +101,10 @@ instance Show k => Show (Q k) where show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file --- | Invariant: the 'v' must be in normal form (fully evaluated). +-- | Invariant: the @v@ must be in normal form (fully evaluated). -- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database newtype A v = A (Value v) deriving Show - -instance NFData (A v) where rnf (A v) = v `seq` () -- In the Shake database we only store one type of key/result pairs, -- namely Q (question) / A (answer). diff --git a/src/Generics/SYB/GHC.hs b/src/Generics/SYB/GHC.hs --- a/src/Generics/SYB/GHC.hs +++ b/src/Generics/SYB/GHC.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DerivingVia #-} -{-# LANGUAGE RankNTypes #-} -- | Custom SYB traversals explicitly designed for operating over the GHC AST. module Generics.SYB.GHC @@ -31,7 +30,7 @@ SrcSpan -> GenericQ (Maybe (Bool, ast)) genericIsSubspan _ dst = mkQ Nothing $ \case - (L span ast :: Located ast) -> Just (dst `isSubspanOf` span, ast) + (L srcSpan ast :: Located ast) -> Just (dst `isSubspanOf` srcSpan, ast) -- | Lift a function that replaces a value with several values into a generic diff --git a/src/Text/Fuzzy/Levenshtein.hs b/src/Text/Fuzzy/Levenshtein.hs new file mode 100644 --- /dev/null +++ b/src/Text/Fuzzy/Levenshtein.hs @@ -0,0 +1,16 @@ +module Text.Fuzzy.Levenshtein where + +import Data.List (sortOn) +import Data.Text (Text) +import qualified Data.Text as T +import Text.EditDistance +import Text.Fuzzy.Parallel + +-- | Sort the given list according to it's levenshtein distance relative to the +-- given string. +levenshteinScored :: Int -> Text -> [Text] -> [Scored Text] +levenshteinScored chunkSize needle haystack = do + let levenshtein = levenshteinDistance $ defaultEditCosts {substitutionCosts=ConstantCost 2} + sortOn score $ + matchPar chunkSize needle haystack id $ + \a b -> Just $ levenshtein (T.unpack a) (T.unpack b) diff --git a/src/Text/Fuzzy/Parallel.hs b/src/Text/Fuzzy/Parallel.hs --- a/src/Text/Fuzzy/Parallel.hs +++ b/src/Text/Fuzzy/Parallel.hs @@ -1,9 +1,9 @@ -- | Parallel versions of 'filter' and 'simpleFilter' module Text.Fuzzy.Parallel -( filter, - simpleFilter, - match, +( filter, filter', matchPar, + simpleFilter, simpleFilter', + match, defChunkSize, defMaxResults, Scored(..) ) where @@ -29,7 +29,6 @@ -- Just 5 -- {-# INLINABLE match #-} - match :: T.Text -- ^ Pattern in lowercase except for first character -> T.Text -- ^ The text to search in. -> Maybe Int -- ^ The score @@ -70,23 +69,14 @@ toLowerAscii w = if (w - 65) < 26 then w .|. 0x20 else w --- | The function to filter a list of values by fuzzy search on the text extracted from them. -filter :: Int -- ^ Chunk size. 1000 works well. - -> Int -- ^ Max. number of results wanted - -> T.Text -- ^ Pattern. - -> [t] -- ^ The list of values containing the text to search in. - -> (t -> T.Text) -- ^ The function to extract the text from the container. - -> [Scored t] -- ^ The list of results, sorted, highest score first. -filter chunkSize maxRes pattern ts extract = partialSortByAscScore maxRes perfectScore (concat vss) - where - -- Preserve case for the first character, make all others lowercase - pattern' = case T.uncons pattern of - Just (c, rest) -> T.cons c (T.toLower rest) - _ -> pattern - vss = map (mapMaybe (\t -> flip Scored t <$> match pattern' (extract t))) (chunkList chunkSize ts) - `using` parList (evalList rseq) - perfectScore = fromMaybe (error $ T.unpack pattern) $ match pattern' pattern' +-- | Sensible default value for chunk size to use when calling simple filter. +defChunkSize :: Int +defChunkSize = 1000 +-- | Sensible default value for the number of max results to use when calling simple filter. +defMaxResults :: Int +defMaxResults = 10 + -- | Return all elements of the list that have a fuzzy -- match against the pattern. Runs with default settings where -- nothing is added around the matches, as case insensitive. @@ -99,9 +89,68 @@ -> T.Text -- ^ Pattern to look for. -> [T.Text] -- ^ List of texts to check. -> [Scored T.Text] -- ^ The ones that match. -simpleFilter chunk maxRes pattern xs = - filter chunk maxRes pattern xs id +simpleFilter chunk maxRes pat xs = filter chunk maxRes pat xs id + +-- | The function to filter a list of values by fuzzy search on the text extracted from them, +-- using a custom matching function which determines how close words are. +filter' :: Int -- ^ Chunk size. 1000 works well. + -> Int -- ^ Max. number of results wanted + -> T.Text -- ^ Pattern. + -> [t] -- ^ The list of values containing the text to search in. + -> (t -> T.Text) -- ^ The function to extract the text from the container. + -> (T.Text -> T.Text -> Maybe Int) + -- ^ Custom scoring function to use for calculating how close words are + -- When the function returns Nothing, this means the values are incomparable. + -> [Scored t] -- ^ The list of results, sorted, highest score first. +filter' chunkSize maxRes pat ts extract match' = partialSortByAscScore maxRes perfectScore $ + matchPar chunkSize pat' ts extract match' + where + perfectScore = fromMaybe (error $ T.unpack pat) $ match' pat pat + -- Preserve case for the first character, make all others lowercase + pat' = case T.uncons pat of + Just (c, rest) -> T.cons c (T.toLower rest) + _ -> pat + +matchPar + :: Int -- ^ Chunk size. 1000 works well. + -> T.Text -- ^ Pattern. + -> [t] -- ^ The list of values containing the text to search in. + -> (t -> T.Text) -- ^ The function to extract the text from the container. + -> (T.Text -> T.Text -> Maybe Int) + -- ^ Custom scoring function to use for calculating how close words are + -- When the function returns Nothing, this means the values are incomparable. + -> [Scored t] -- ^ The list of results, sorted, highest score first. +{-# INLINABLE matchPar #-} +matchPar chunkSize pat ts extract match' = concat vss + where + vss = map (mapMaybe (\t -> flip Scored t <$> match' pat (extract t))) (chunkList chunkSize ts) + `using` parList (evalList rseq) + +-- | The function to filter a list of values by fuzzy search on the text extracted from them, +-- using a custom matching function which determines how close words are. +filter :: Int -- ^ Chunk size. 1000 works well. + -> Int -- ^ Max. number of results wanted + -> T.Text -- ^ Pattern. + -> [t] -- ^ The list of values containing the text to search in. + -> (t -> T.Text) -- ^ The function to extract the text from the container. + -> [Scored t] -- ^ The list of results, sorted, highest score first. +filter chunkSize maxRes pat ts extract = + filter' chunkSize maxRes pat ts extract match + +-- | Return all elements of the list that have a fuzzy match against the pattern, +-- the closeness of the match is determined using the custom scoring match function that is passed. +-- Runs with default settings where nothing is added around the matches, as case insensitive. +{-# INLINABLE simpleFilter' #-} +simpleFilter' :: Int -- ^ Chunk size. 1000 works well. + -> Int -- ^ Max. number of results wanted + -> T.Text -- ^ Pattern to look for. + -> [T.Text] -- ^ List of texts to check. + -> (T.Text -> T.Text -> Maybe Int) + -- ^ Custom scoring function to use for calculating how close words are + -> [Scored T.Text] -- ^ The ones that match. +simpleFilter' chunk maxRes pat xs match' = + filter' chunk maxRes pat xs id match' -------------------------------------------------------------------------------- chunkList :: Int -> [a] -> [[a]] diff --git a/test/cabal/Development/IDE/Test/Runfiles.hs b/test/cabal/Development/IDE/Test/Runfiles.hs deleted file mode 100644 --- a/test/cabal/Development/IDE/Test/Runfiles.hs +++ /dev/null @@ -1,9 +0,0 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -module Development.IDE.Test.Runfiles - ( locateGhcideExecutable - ) where - -locateGhcideExecutable :: IO FilePath -locateGhcideExecutable = pure "ghcide" diff --git a/test/data/TH/THA.hs b/test/data/TH/THA.hs deleted file mode 100644 --- a/test/data/TH/THA.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module THA where -import Language.Haskell.TH - -th_a :: DecsQ -th_a = [d| a = () |] diff --git a/test/data/TH/THB.hs b/test/data/TH/THB.hs deleted file mode 100644 --- a/test/data/TH/THB.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module THB where -import THA - -$th_a diff --git a/test/data/TH/THC.hs b/test/data/TH/THC.hs deleted file mode 100644 --- a/test/data/TH/THC.hs +++ /dev/null @@ -1,5 +0,0 @@ -module THC where -import THB - -c ::() -c = a diff --git a/test/data/TH/hie.yaml b/test/data/TH/hie.yaml deleted file mode 100644 --- a/test/data/TH/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "THA", "THB", "THC"]}} diff --git a/test/data/THCoreFile/THA.hs b/test/data/THCoreFile/THA.hs deleted file mode 100644 --- a/test/data/THCoreFile/THA.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module THA where -import Language.Haskell.TH -import Control.Monad (when) - -th_a :: DecsQ -th_a = do - when (show (StrictConstructor1 123 True 4567) /= "StrictConstructor1 123 True 4567") $ error "TH validation error" - when (show (StrictConstructor2 123 True 4567) /= "StrictConstructor2 123 True 4567") $ error "TH validation error" - when (show (StrictConstructor3 123 True 4567) /= "StrictConstructor3 123 True 4567") $ error "TH validation error" - when (show (classMethod 'z') /= "True") $ error "TH validation error" - when (show (classMethod 'a') /= "False") $ error "TH validation error" - [d| a = () |] - -data StrictType1 = StrictConstructor1 !Int !Bool Int deriving Show -data StrictType2 = StrictConstructor2 !Int !Bool !Int deriving Show -data StrictType3 = StrictConstructor3 !Int !Bool !Int deriving Show - -class SingleMethodClass a where - classMethod :: a -> Bool - -instance SingleMethodClass Char where - classMethod = (== 'z') diff --git a/test/data/THCoreFile/THB.hs b/test/data/THCoreFile/THB.hs deleted file mode 100644 --- a/test/data/THCoreFile/THB.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module THB where -import THA -import Control.Monad (when) - -$(do - -- Need to verify in both defining module and usage module" - when (show (StrictConstructor1 123 True 4567) /= "StrictConstructor1 123 True 4567") $ error "TH validation error" - when (show (StrictConstructor2 123 True 4567) /= "StrictConstructor2 123 True 4567") $ error "TH validation error" - when (show (StrictConstructor3 123 True 4567) /= "StrictConstructor3 123 True 4567") $ error "TH validation error" - when (show (classMethod 'z') /= "True") $ error "TH validation error" - when (show (classMethod 'a') /= "False") $ error "TH validation error" - th_a) diff --git a/test/data/THCoreFile/THC.hs b/test/data/THCoreFile/THC.hs deleted file mode 100644 --- a/test/data/THCoreFile/THC.hs +++ /dev/null @@ -1,5 +0,0 @@ -module THC where -import THB - -c ::() -c = a diff --git a/test/data/THCoreFile/hie.yaml b/test/data/THCoreFile/hie.yaml deleted file mode 100644 --- a/test/data/THCoreFile/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["-package template-haskell", "THA", "THB", "THC"]}} diff --git a/test/data/THLoading/A.hs b/test/data/THLoading/A.hs deleted file mode 100644 --- a/test/data/THLoading/A.hs +++ /dev/null @@ -1,5 +0,0 @@ -module A where -import B (bar) - -foo :: () -foo = bar diff --git a/test/data/THLoading/B.hs b/test/data/THLoading/B.hs deleted file mode 100644 --- a/test/data/THLoading/B.hs +++ /dev/null @@ -1,4 +0,0 @@ -module B where - -bar :: () -bar = () diff --git a/test/data/THLoading/THA.hs b/test/data/THLoading/THA.hs deleted file mode 100644 --- a/test/data/THLoading/THA.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module THA where -import Language.Haskell.TH -import A (foo) - -th_a :: DecsQ -th_a = [d| a = foo |] diff --git a/test/data/THLoading/THB.hs b/test/data/THLoading/THB.hs deleted file mode 100644 --- a/test/data/THLoading/THB.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module THB where -import THA - -$th_a diff --git a/test/data/THLoading/hie.yaml b/test/data/THLoading/hie.yaml deleted file mode 100644 --- a/test/data/THLoading/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["-package template-haskell", "THA", "THB", "A", "B"]}} diff --git a/test/data/THNewName/A.hs b/test/data/THNewName/A.hs deleted file mode 100644 --- a/test/data/THNewName/A.hs +++ /dev/null @@ -1,6 +0,0 @@ -module A (template) where - -import Language.Haskell.TH - -template :: DecsQ -template = (\consA -> [DataD [] (mkName "A") [] Nothing [NormalC consA []] []]) <$> newName "A" diff --git a/test/data/THNewName/B.hs b/test/data/THNewName/B.hs deleted file mode 100644 --- a/test/data/THNewName/B.hs +++ /dev/null @@ -1,5 +0,0 @@ -module B(A(A)) where - -import A - -template diff --git a/test/data/THNewName/C.hs b/test/data/THNewName/C.hs deleted file mode 100644 --- a/test/data/THNewName/C.hs +++ /dev/null @@ -1,4 +0,0 @@ -module C where -import B - -a = A diff --git a/test/data/THNewName/hie.yaml b/test/data/THNewName/hie.yaml deleted file mode 100644 --- a/test/data/THNewName/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["-XTemplateHaskell","-Wmissing-signatures","A", "B", "C"]}} diff --git a/test/data/THUnboxed/THA.hs b/test/data/THUnboxed/THA.hs deleted file mode 100644 --- a/test/data/THUnboxed/THA.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE TemplateHaskell, UnboxedTuples, BangPatterns #-} -module THA where -import Language.Haskell.TH - -data Foo = Foo !Int !Char !String - deriving Show - -newtype Bar = Bar Int - deriving Show - - -f :: Int -> (# Int, Int, Foo, Bar#) -f x = (# x , x+1 , Foo x 'a' "test", Bar 1 #) - -th_a :: DecsQ -th_a = case f 1 of (# a , b, Foo _ _ _, Bar !_ #) -> [d| a = () |] diff --git a/test/data/THUnboxed/THB.hs b/test/data/THUnboxed/THB.hs deleted file mode 100644 --- a/test/data/THUnboxed/THB.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module THB where -import THA - -$th_a diff --git a/test/data/THUnboxed/THC.hs b/test/data/THUnboxed/THC.hs deleted file mode 100644 --- a/test/data/THUnboxed/THC.hs +++ /dev/null @@ -1,5 +0,0 @@ -module THC where -import THB - -c ::() -c = a diff --git a/test/data/THUnboxed/hie.yaml b/test/data/THUnboxed/hie.yaml deleted file mode 100644 --- a/test/data/THUnboxed/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["-Wmissing-signatures", "-package template-haskell", "THA", "THB", "THC"]}} diff --git a/test/data/boot/A.hs b/test/data/boot/A.hs deleted file mode 100644 --- a/test/data/boot/A.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module A where - -import B( TB(..) ) - -newtype TA = MkTA Int - deriving Eq - -f :: TB -> TA -f (MkTB x) = MkTA x diff --git a/test/data/boot/A.hs-boot b/test/data/boot/A.hs-boot deleted file mode 100644 --- a/test/data/boot/A.hs-boot +++ /dev/null @@ -1,3 +0,0 @@ -module A where -newtype TA = MkTA Int -instance Eq TA diff --git a/test/data/boot/B.hs b/test/data/boot/B.hs deleted file mode 100644 --- a/test/data/boot/B.hs +++ /dev/null @@ -1,7 +0,0 @@ -module B(TA(..), TB(..)) where -import {-# SOURCE #-} A( TA(..) ) - -data TB = MkTB !Int - -g :: TA -> TB -g (MkTA x) = MkTB x diff --git a/test/data/boot/C.hs b/test/data/boot/C.hs deleted file mode 100644 --- a/test/data/boot/C.hs +++ /dev/null @@ -1,8 +0,0 @@ -module C where - -import B -import A hiding (MkTA(..)) - -x = MkTA -y = MkTB -z = f diff --git a/test/data/boot/hie.yaml b/test/data/boot/hie.yaml deleted file mode 100644 --- a/test/data/boot/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["A.hs", "A.hs-boot", "B.hs", "C.hs"]}} diff --git a/test/data/boot2/A.hs b/test/data/boot2/A.hs deleted file mode 100644 --- a/test/data/boot2/A.hs +++ /dev/null @@ -1,12 +0,0 @@ -module A where - --- E source imports B --- In interface file see source module dependencies: B {-# SOURCE #-} -import E --- C imports B --- In interface file see source module dependencies: B -import C - --- Instance for B only available from B.hi not B.hi-boot, so tests we load --- that. -main = print B diff --git a/test/data/boot2/B.hs b/test/data/boot2/B.hs deleted file mode 100644 --- a/test/data/boot2/B.hs +++ /dev/null @@ -1,8 +0,0 @@ -module B where - -import D - -data B = B - -instance Show B where - show B = "B" diff --git a/test/data/boot2/B.hs-boot b/test/data/boot2/B.hs-boot deleted file mode 100644 --- a/test/data/boot2/B.hs-boot +++ /dev/null @@ -1,3 +0,0 @@ -module B where - -data B = B diff --git a/test/data/boot2/C.hs b/test/data/boot2/C.hs deleted file mode 100644 --- a/test/data/boot2/C.hs +++ /dev/null @@ -1,3 +0,0 @@ -module C where - -import B diff --git a/test/data/boot2/D.hs b/test/data/boot2/D.hs deleted file mode 100644 --- a/test/data/boot2/D.hs +++ /dev/null @@ -1,3 +0,0 @@ -module D where - -import {-# SOURCE #-} B diff --git a/test/data/boot2/E.hs b/test/data/boot2/E.hs deleted file mode 100644 --- a/test/data/boot2/E.hs +++ /dev/null @@ -1,3 +0,0 @@ -module E(B(B)) where - -import {-# SOURCE #-} B diff --git a/test/data/boot2/hie.yaml b/test/data/boot2/hie.yaml deleted file mode 100644 --- a/test/data/boot2/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["A.hs", "B.hs-boot", "B.hs", "C.hs", "D.hs", "E.hs"]}} diff --git a/test/data/cabal-exe/a/a.cabal b/test/data/cabal-exe/a/a.cabal deleted file mode 100644 --- a/test/data/cabal-exe/a/a.cabal +++ /dev/null @@ -1,14 +0,0 @@ -cabal-version: 2.2 - -name: a -version: 0.1.0.0 -author: Fendor -maintainer: power.walross@gmail.com -build-type: Simple - -executable a - main-is: Main.hs - hs-source-dirs: src - ghc-options: -Wall - build-depends: base - default-language: Haskell2010 diff --git a/test/data/cabal-exe/a/src/Main.hs b/test/data/cabal-exe/a/src/Main.hs deleted file mode 100644 --- a/test/data/cabal-exe/a/src/Main.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Main where - -main = putStrLn "Hello, Haskell!" diff --git a/test/data/cabal-exe/cabal.project b/test/data/cabal-exe/cabal.project deleted file mode 100644 --- a/test/data/cabal-exe/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: ./a diff --git a/test/data/cabal-exe/hie.yaml b/test/data/cabal-exe/hie.yaml deleted file mode 100644 --- a/test/data/cabal-exe/hie.yaml +++ /dev/null @@ -1,3 +0,0 @@ -cradle: - cabal: - component: "exe:a" diff --git a/test/data/hover/Bar.hs b/test/data/hover/Bar.hs deleted file mode 100644 --- a/test/data/hover/Bar.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Bar (Bar(..)) where - --- | Bar Haddock -data Bar = Bar diff --git a/test/data/hover/Foo.hs b/test/data/hover/Foo.hs deleted file mode 100644 --- a/test/data/hover/Foo.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Foo (Bar, foo) where - -import Bar - --- | foo Haddock -foo = Bar diff --git a/test/data/hover/GotoHover.hs b/test/data/hover/GotoHover.hs deleted file mode 100644 --- a/test/data/hover/GotoHover.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} -{- HLINT ignore -} -module GotoHover ( module GotoHover) where -import Data.Text (Text, pack) -import Foo (Bar, foo) - - -data TypeConstructor = DataConstructor - { fff :: Text - , ggg :: Int } -aaa :: TypeConstructor -aaa = DataConstructor - { fff = "dfgy" - , ggg = 832 - } -bbb :: TypeConstructor -bbb = DataConstructor "mjgp" 2994 -ccc :: (Text, Int) -ccc = (fff bbb, ggg aaa) -ddd :: Num a => a -> a -> a -ddd vv ww = vv +! ww -a +! b = a - b -hhh (Just a) (><) = a >< a -iii a b = a `b` a -jjj s = pack $ s <> s -class MyClass a where - method :: a -> Int -instance MyClass Int where - method = succ -kkk :: MyClass a => Int -> a -> Int -kkk n c = n + method c - -doBind :: Maybe () -doBind = do unwrapped <- Just () - return unwrapped - -listCompBind :: [Char] -listCompBind = [ succ c | c <- "ptfx" ] - -multipleClause :: Bool -> Char -multipleClause True = 't' -multipleClause False = 'f' - --- | Recognizable docs: kpqz -documented :: Monad m => Either Int (m a) -documented = Left 7518 - -listOfInt = [ 8391 :: Int, 6268 ] - -outer :: Bool -outer = undefined inner where - - inner :: Char - inner = undefined - -imported :: Bar -imported = foo - -aa2 :: Bool -aa2 = $(id [| True |]) - -hole :: Int -hole = _ - -hole2 :: a -> Maybe a -hole2 = _ diff --git a/test/data/hover/RecordDotSyntax.hs b/test/data/hover/RecordDotSyntax.hs deleted file mode 100644 --- a/test/data/hover/RecordDotSyntax.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 902 -{-# LANGUAGE OverloadedRecordDot, DuplicateRecordFields, NoFieldSelectors #-} - -module RecordDotSyntax ( module RecordDotSyntax) where - -import qualified Data.Maybe as M - -data MyRecord = MyRecord - { a :: String - , b :: Integer - , c :: MyChild - } deriving (Eq, Show) - -newtype MyChild = MyChild - { z :: String - } deriving (Eq, Show) - -x = MyRecord { a = "Hello", b = 12, c = MyChild { z = "there" } } -y = x.a ++ show x.b ++ x.c.z -#endif diff --git a/test/data/hover/hie.yaml b/test/data/hover/hie.yaml deleted file mode 100644 --- a/test/data/hover/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}} diff --git a/test/data/ignore-fatal/IgnoreFatal.hs b/test/data/ignore-fatal/IgnoreFatal.hs deleted file mode 100644 --- a/test/data/ignore-fatal/IgnoreFatal.hs +++ /dev/null @@ -1,8 +0,0 @@ --- "missing signature" is declared a fatal warning in the cabal file, --- but is ignored in this module. - -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} - -module IgnoreFatal where - -a = 'a' diff --git a/test/data/ignore-fatal/cabal.project b/test/data/ignore-fatal/cabal.project deleted file mode 100644 --- a/test/data/ignore-fatal/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: ignore-fatal.cabal diff --git a/test/data/ignore-fatal/hie.yaml b/test/data/ignore-fatal/hie.yaml deleted file mode 100644 --- a/test/data/ignore-fatal/hie.yaml +++ /dev/null @@ -1,4 +0,0 @@ -cradle: - cabal: - - path: "." - component: "lib:ignore-fatal" diff --git a/test/data/ignore-fatal/ignore-fatal.cabal b/test/data/ignore-fatal/ignore-fatal.cabal deleted file mode 100644 --- a/test/data/ignore-fatal/ignore-fatal.cabal +++ /dev/null @@ -1,10 +0,0 @@ -name: ignore-fatal -version: 1.0.0 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base - exposed-modules: IgnoreFatal - hs-source-dirs: . - ghc-options: -Werror=missing-signatures diff --git a/test/data/multi/a/A.hs b/test/data/multi/a/A.hs deleted file mode 100644 --- a/test/data/multi/a/A.hs +++ /dev/null @@ -1,3 +0,0 @@ -module A(foo) where -import Control.Concurrent.Async -foo = () diff --git a/test/data/multi/a/a.cabal b/test/data/multi/a/a.cabal deleted file mode 100644 --- a/test/data/multi/a/a.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: a -version: 1.0.0 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base, async - exposed-modules: A - hs-source-dirs: . diff --git a/test/data/multi/b/B.hs b/test/data/multi/b/B.hs deleted file mode 100644 --- a/test/data/multi/b/B.hs +++ /dev/null @@ -1,3 +0,0 @@ -module B(module B) where -import A -qux = foo diff --git a/test/data/multi/b/b.cabal b/test/data/multi/b/b.cabal deleted file mode 100644 --- a/test/data/multi/b/b.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: b -version: 1.0.0 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base, a - exposed-modules: B - hs-source-dirs: . diff --git a/test/data/multi/c/C.hs b/test/data/multi/c/C.hs deleted file mode 100644 --- a/test/data/multi/c/C.hs +++ /dev/null @@ -1,3 +0,0 @@ -module C(module C) where -import A -cux = foo diff --git a/test/data/multi/c/c.cabal b/test/data/multi/c/c.cabal deleted file mode 100644 --- a/test/data/multi/c/c.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: c -version: 1.0.0 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base, a - exposed-modules: C - hs-source-dirs: . diff --git a/test/data/multi/cabal.project b/test/data/multi/cabal.project deleted file mode 100644 --- a/test/data/multi/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: a b c diff --git a/test/data/multi/hie.yaml b/test/data/multi/hie.yaml deleted file mode 100644 --- a/test/data/multi/hie.yaml +++ /dev/null @@ -1,8 +0,0 @@ -cradle: - cabal: - - path: "./a" - component: "lib:a" - - path: "./b" - component: "lib:b" - - path: "./c" - component: "lib:c" diff --git a/test/data/plugin-knownnat/KnownNat.hs b/test/data/plugin-knownnat/KnownNat.hs deleted file mode 100644 --- a/test/data/plugin-knownnat/KnownNat.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} -{-# LANGUAGE DataKinds, ScopedTypeVariables, TypeOperators #-} -module KnownNat where -import Data.Proxy -import GHC.TypeLits - -f :: forall n. KnownNat n => Proxy n -> Integer -f _ = natVal (Proxy :: Proxy n) + natVal (Proxy :: Proxy (n+2)) -foo :: Int -> Int -> Int -foo a _b = a + c diff --git a/test/data/plugin-knownnat/cabal.project b/test/data/plugin-knownnat/cabal.project deleted file mode 100644 --- a/test/data/plugin-knownnat/cabal.project +++ /dev/null @@ -1,4 +0,0 @@ -packages: . - --- Needed for ghc >= 9.0.2 and ghc-typelits-natnormalise == 0.7.6 -allow-newer: ghc-typelits-natnormalise:ghc-bignum diff --git a/test/data/plugin-knownnat/plugin.cabal b/test/data/plugin-knownnat/plugin.cabal deleted file mode 100644 --- a/test/data/plugin-knownnat/plugin.cabal +++ /dev/null @@ -1,9 +0,0 @@ -cabal-version: 1.18 -name: plugin -version: 1.0.0 -build-type: Simple - -library - build-depends: base, ghc-typelits-knownnat - exposed-modules: KnownNat - hs-source-dirs: . diff --git a/test/data/plugin-recorddot/RecordDot.hs b/test/data/plugin-recorddot/RecordDot.hs deleted file mode 100644 --- a/test/data/plugin-recorddot/RecordDot.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields, TypeApplications, TypeFamilies, UndecidableInstances, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} -module RecordDot (Company(..), display) where -data Company = Company {name :: String} -display :: Company -> String -display c = c.name diff --git a/test/data/plugin-recorddot/cabal.project b/test/data/plugin-recorddot/cabal.project deleted file mode 100644 --- a/test/data/plugin-recorddot/cabal.project +++ /dev/null @@ -1,1 +0,0 @@ -packages: . diff --git a/test/data/plugin-recorddot/plugin.cabal b/test/data/plugin-recorddot/plugin.cabal deleted file mode 100644 --- a/test/data/plugin-recorddot/plugin.cabal +++ /dev/null @@ -1,9 +0,0 @@ -cabal-version: 1.18 -name: plugin -version: 1.0.0 -build-type: Simple - -library - build-depends: base, record-dot-preprocessor, record-hasfield - exposed-modules: RecordDot - hs-source-dirs: . diff --git a/test/data/recomp/A.hs b/test/data/recomp/A.hs deleted file mode 100644 --- a/test/data/recomp/A.hs +++ /dev/null @@ -1,6 +0,0 @@ -module A(x) where - -import B - -x :: Int -x = y diff --git a/test/data/recomp/B.hs b/test/data/recomp/B.hs deleted file mode 100644 --- a/test/data/recomp/B.hs +++ /dev/null @@ -1,4 +0,0 @@ -module B(y) where - -y :: Int -y = undefined diff --git a/test/data/recomp/P.hs b/test/data/recomp/P.hs deleted file mode 100644 --- a/test/data/recomp/P.hs +++ /dev/null @@ -1,5 +0,0 @@ -module P() where -import A -import B - -bar = x :: Int diff --git a/test/data/recomp/hie.yaml b/test/data/recomp/hie.yaml deleted file mode 100644 --- a/test/data/recomp/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["-Wmissing-signatures","B", "A", "P"]}} diff --git a/test/data/references/Main.hs b/test/data/references/Main.hs deleted file mode 100644 --- a/test/data/references/Main.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Main where - -import References - -main :: IO () -main = return () - - - -a = 2 :: Int -b = a + 1 - -acc :: Account -acc = Savings diff --git a/test/data/references/OtherModule.hs b/test/data/references/OtherModule.hs deleted file mode 100644 --- a/test/data/references/OtherModule.hs +++ /dev/null @@ -1,9 +0,0 @@ -module OtherModule (symbolDefinedInOtherModule, symbolDefinedInOtherOtherModule) where - -import OtherOtherModule - -symbolDefinedInOtherModule = 1 - -symbolLocalToOtherModule = 2 - -someFxn x = x + symbolLocalToOtherModule diff --git a/test/data/references/OtherOtherModule.hs b/test/data/references/OtherOtherModule.hs deleted file mode 100644 --- a/test/data/references/OtherOtherModule.hs +++ /dev/null @@ -1,3 +0,0 @@ -module OtherOtherModule where - -symbolDefinedInOtherOtherModule = "asdf" diff --git a/test/data/references/References.hs b/test/data/references/References.hs deleted file mode 100644 --- a/test/data/references/References.hs +++ /dev/null @@ -1,25 +0,0 @@ -module References where - -import OtherModule - -foo = bar - -bar = let x = bar 42 in const "hello" - -baz = do - x <- bar 23 - return $ bar 14 - -data Account = - Checking - | Savings - -bobsAccount = Checking - -bobHasChecking = case bobsAccount of - Checking -> True - Savings -> False - -x = symbolDefinedInOtherModule - -y = symbolDefinedInOtherOtherModule diff --git a/test/data/references/hie.yaml b/test/data/references/hie.yaml deleted file mode 100644 --- a/test/data/references/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["Main","OtherModule","OtherOtherModule","References"]}} diff --git a/test/data/rootUri/dirA/Foo.hs b/test/data/rootUri/dirA/Foo.hs deleted file mode 100644 --- a/test/data/rootUri/dirA/Foo.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Foo () where - -foo = () diff --git a/test/data/rootUri/dirA/foo.cabal b/test/data/rootUri/dirA/foo.cabal deleted file mode 100644 --- a/test/data/rootUri/dirA/foo.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: foo -version: 1.0.0 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base - exposed-modules: Foo - hs-source-dirs: . diff --git a/test/data/rootUri/dirB/Foo.hs b/test/data/rootUri/dirB/Foo.hs deleted file mode 100644 --- a/test/data/rootUri/dirB/Foo.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Foo () where - -foo = () diff --git a/test/data/rootUri/dirB/foo.cabal b/test/data/rootUri/dirB/foo.cabal deleted file mode 100644 --- a/test/data/rootUri/dirB/foo.cabal +++ /dev/null @@ -1,9 +0,0 @@ -name: foo -version: 1.0.0 -build-type: Simple -cabal-version: >= 1.2 - -library - build-depends: base - exposed-modules: Foo - hs-source-dirs: . diff --git a/test/data/symlink/hie.yaml b/test/data/symlink/hie.yaml deleted file mode 100644 --- a/test/data/symlink/hie.yaml +++ /dev/null @@ -1,10 +0,0 @@ - -cradle: - direct: - arguments: - - -i - - -isrc - - -iother_loc/ - - other_loc/Sym.hs - - src/Foo.hs - - -Wall diff --git a/test/data/symlink/some_loc/Sym.hs b/test/data/symlink/some_loc/Sym.hs deleted file mode 100644 --- a/test/data/symlink/some_loc/Sym.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Sym where - -foo :: String -foo = "" diff --git a/test/data/symlink/src/Foo.hs b/test/data/symlink/src/Foo.hs deleted file mode 100644 --- a/test/data/symlink/src/Foo.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Foo where - -import Sym - diff --git a/test/exe/FuzzySearch.hs b/test/exe/FuzzySearch.hs deleted file mode 100644 --- a/test/exe/FuzzySearch.hs +++ /dev/null @@ -1,132 +0,0 @@ -module FuzzySearch (tests) where - -import Control.Monad (guard) -import Data.Char (toLower) -import Data.Maybe (catMaybes) -import qualified Data.Monoid.Textual as T -import Data.Text (Text, inits, pack) -import qualified Data.Text as Text -import Prelude hiding (filter) -import System.Directory (doesFileExist) -import System.Info.Extra (isWindows) -import System.IO.Unsafe (unsafePerformIO) -import Test.QuickCheck -import Test.Tasty -import Test.Tasty.ExpectedFailure -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck (testProperty) -import qualified Text.Fuzzy as Fuzzy -import Text.Fuzzy (Fuzzy (..)) -import Text.Fuzzy.Parallel - -tests :: TestTree -tests = - testGroup - "Fuzzy search" - [ needDictionary $ - testGroup - "match works as expected on the english dictionary" - [ testProperty "for legit words" propLegit, - testProperty "for prefixes" propPrefix, - testProperty "for typos" propTypo - ] - ] - -test :: Text -> Bool -test candidate = do - let previous = - catMaybes - [ (d,) . Fuzzy.score - <$> referenceImplementation candidate d "" "" id - | d <- dictionary - ] - new = catMaybes [(d,) <$> match candidate d | d <- dictionary] - previous == new - -propLegit :: Property -propLegit = forAll (elements dictionary) test - -propPrefix :: Property -propPrefix = forAll (elements dictionary >>= elements . inits) test - -propTypo :: Property -propTypo = forAll typoGen test - -typoGen :: Gen Text -typoGen = do - w <- elements dictionary - l <- elements [0 .. Text.length w -1] - let wl = Text.index w l - c <- elements [ c | c <- ['a' .. 'z'], c /= wl] - return $ replaceAt w l c - -replaceAt :: Text -> Int -> Char -> Text -replaceAt t i c = - let (l, r) = Text.splitAt i t - in l <> Text.singleton c <> r - -dictionaryPath :: FilePath -dictionaryPath = "/usr/share/dict/words" - -{-# NOINLINE dictionary #-} -dictionary :: [Text] -dictionary = unsafePerformIO $ do - existsDictionary <- doesFileExist dictionaryPath - if existsDictionary - then map pack . words <$> readFile dictionaryPath - else pure [] - -referenceImplementation :: - (T.TextualMonoid s) => - -- | Pattern in lowercase except for first character - s -> - -- | The value containing the text to search in. - t -> - -- | The text to add before each match. - s -> - -- | The text to add after each match. - s -> - -- | The function to extract the text from the container. - (t -> s) -> - -- | The original value, rendered string and score. - Maybe (Fuzzy t s) -referenceImplementation pattern t pre post extract = - if null pat then Just (Fuzzy t result totalScore) else Nothing - where - null :: (T.TextualMonoid s) => s -> Bool - null = not . T.any (const True) - - s = extract t - (totalScore, _currScore, result, pat, _) = - T.foldl' - undefined - ( \(tot, cur, res, pat, isFirst) c -> - case T.splitCharacterPrefix pat of - Nothing -> (tot, 0, res <> T.singleton c, pat, isFirst) - Just (x, xs) -> - -- the case of the first character has to match - -- otherwise use lower case since the pattern is assumed lower - let !c' = if isFirst then c else toLower c - in if x == c' - then - let cur' = cur * 2 + 1 - in ( tot + cur', - cur', - res <> pre <> T.singleton c <> post, - xs, - False - ) - else (tot, 0, res <> T.singleton c, pat, isFirst) - ) - ( 0, - 1, -- matching at the start gives a bonus (cur = 1) - mempty, - pattern, - True - ) - s - -needDictionary :: TestTree -> TestTree -needDictionary - | null dictionary = ignoreTestBecause ("not found: " <> dictionaryPath) - | otherwise = id diff --git a/test/exe/HieDbRetry.hs b/test/exe/HieDbRetry.hs deleted file mode 100644 --- a/test/exe/HieDbRetry.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -module HieDbRetry (tests) where - -import Control.Concurrent.Extra (Var, modifyVar, newVar, readVar, - withVar) -import Control.Exception (ErrorCall (ErrorCall), evaluate, - throwIO, tryJust) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Tuple.Extra (dupe) -import qualified Database.SQLite.Simple as SQLite -import Development.IDE.Session (retryOnException, - retryOnSqliteBusy) -import qualified Development.IDE.Session as Session -import Development.IDE.Types.Logger (Recorder (Recorder, logger_), - WithPriority (WithPriority, payload), - cmapWithPrio) -import qualified System.Random as Random -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) - -data Log - = LogSession Session.Log - deriving Show - -makeLogger :: Var [Log] -> Recorder (WithPriority Log) -makeLogger msgsVar = - Recorder { - logger_ = \WithPriority{ payload = msg } -> liftIO $ modifyVar msgsVar (\msgs -> pure (msg : msgs, ())) - } - -rng :: Random.StdGen -rng = Random.mkStdGen 0 - -retryOnSqliteBusyForTest :: Recorder (WithPriority Log) -> Int -> IO a -> IO a -retryOnSqliteBusyForTest recorder maxRetryCount = retryOnException isErrorBusy (cmapWithPrio LogSession recorder) 1 1 maxRetryCount rng - -isErrorBusy :: SQLite.SQLError -> Maybe SQLite.SQLError -isErrorBusy e - | SQLite.SQLError { sqlError = SQLite.ErrorBusy } <- e = Just e - | otherwise = Nothing - -errorBusy :: SQLite.SQLError -errorBusy = SQLite.SQLError{ sqlError = SQLite.ErrorBusy, sqlErrorDetails = "", sqlErrorContext = "" } - -isErrorCall :: ErrorCall -> Maybe ErrorCall -isErrorCall e - | ErrorCall _ <- e = Just e - | otherwise = Nothing - -tests :: TestTree -tests = testGroup "RetryHieDb" - [ testCase "retryOnException throws exception after max retries" $ do - logMsgsVar <- newVar [] - let logger = makeLogger logMsgsVar - let maxRetryCount = 1 - - result <- tryJust isErrorBusy (retryOnSqliteBusyForTest logger maxRetryCount (throwIO errorBusy)) - - case result of - Left exception -> do - exception @?= errorBusy - withVar logMsgsVar $ \logMsgs -> - length logMsgs @?= 2 - -- uncomment if want to compare log msgs - -- logMsgs @?= [] - Right _ -> assertFailure "Expected ErrorBusy exception" - - , testCase "retryOnException doesn't throw if given function doesn't throw" $ do - let expected = 1 :: Int - let maxRetryCount = 0 - - actual <- retryOnSqliteBusyForTest mempty maxRetryCount (pure expected) - - actual @?= expected - - , testCase "retryOnException retries the number of times it should" $ do - countVar <- newVar 0 - let maxRetryCount = 3 - let incrementThenThrow = modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy - - _ <- tryJust isErrorBusy (retryOnSqliteBusyForTest mempty maxRetryCount incrementThenThrow) - - withVar countVar $ \count -> - count @?= maxRetryCount + 1 - - , testCase "retryOnException doesn't retry if exception is not ErrorBusy" $ do - countVar <- newVar (0 :: Int) - let maxRetryCount = 1 - - let throwThenIncrement = do - count <- readVar countVar - if count == 0 then - evaluate (error "dummy exception") - else - modifyVar countVar (\count -> pure (dupe (count + 1))) - - - _ <- tryJust isErrorCall (retryOnSqliteBusyForTest mempty maxRetryCount throwThenIncrement) - - withVar countVar $ \count -> - count @?= 0 - - , testCase "retryOnSqliteBusy retries on ErrorBusy" $ do - countVar <- newVar (0 :: Int) - - let incrementThenThrowThenIncrement = do - count <- readVar countVar - if count == 0 then - modifyVar countVar (\count -> pure (dupe (count + 1))) >> throwIO errorBusy - else - modifyVar countVar (\count -> pure (dupe (count + 1))) - - _ <- retryOnSqliteBusy mempty rng incrementThenThrowThenIncrement - - withVar countVar $ \count -> - count @?= 2 - - , testCase "retryOnException exponentially backs off" $ do - logMsgsVar <- newVar ([] :: [Log]) - - let maxDelay = 100 - let baseDelay = 1 - let maxRetryCount = 6 - let logger = makeLogger logMsgsVar - - result <- tryJust isErrorBusy (retryOnException isErrorBusy (cmapWithPrio LogSession logger) maxDelay baseDelay maxRetryCount rng (throwIO errorBusy)) - - case result of - Left _ -> do - withVar logMsgsVar $ \logMsgs -> - -- uses log messages to check backoff... - if | (LogSession (Session.LogHieDbRetriesExhausted baseDelay maximumDelay maxRetryCount _) : _) <- logMsgs -> do - baseDelay @?= 64 - maximumDelay @?= 100 - maxRetryCount @?= 0 - | otherwise -> assertFailure "Expected more than 0 log messages" - Right _ -> assertFailure "Expected ErrorBusy exception" - ] diff --git a/test/exe/Main.hs b/test/exe/Main.hs deleted file mode 100644 --- a/test/exe/Main.hs +++ /dev/null @@ -1,3604 +0,0 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{- - NOTE On enforcing determinism - - The tests below use two mechanisms to enforce deterministic LSP sequences: - - 1. Progress reporting: waitForProgress(Begin|Done) - 2. Diagnostics: expectDiagnostics - - Either is fine, but diagnostics are generally more reliable. - - Mixing them both in the same test is NOT FINE as it will introduce race - conditions since multiple interleavings are possible. In other words, - the sequence of diagnostics and progress reports is not deterministic. - For example: - - < do something > - waitForProgressDone - expectDiagnostics [...] - - - When the diagnostics arrive after the progress done message, as they usually do, the test will pass - - When the diagnostics arrive before the progress done msg, when on a slow machine occasionally, the test will timeout - - Therefore, avoid mixing both progress reports and diagnostics in the same test - -} - -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} - -module Main (main) where - -import Control.Applicative.Combinators -import Control.Concurrent -import Control.Exception (bracket_, catch, - finally) -import qualified Control.Lens as Lens -import Control.Monad -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson (toJSON) -import qualified Data.Aeson as A -import Data.Default -import Data.Foldable -import Data.List.Extra -import Data.Maybe -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Text.Utf16.Rope (Rope) -import qualified Data.Text.Utf16.Rope as Rope -import Development.IDE.Core.PositionMapping (PositionResult (..), - fromCurrent, - positionResultToMaybe, - toCurrent) -import Development.IDE.GHC.Compat (GhcVersion (..), - ghcVersion) -import Development.IDE.GHC.Util -import qualified Development.IDE.Main as IDE -import Development.IDE.Plugin.TypeLenses (typeLensCommandId) -import Development.IDE.Spans.Common -import Development.IDE.Test (Cursor, - canonicalizeUri, - configureCheckProject, - diagnostic, - expectCurrentDiagnostics, - expectDiagnostics, - expectDiagnosticsWithTags, - expectNoMoreDiagnostics, - flushMessages, - getInterfaceFilesDir, - getStoredKeys, - isReferenceReady, - referenceReady, - standardizeQuotes, - waitForAction, - waitForGC, - waitForTypecheck) -import Development.IDE.Test.Runfiles -import qualified Development.IDE.Types.Diagnostics as Diagnostics -import Development.IDE.Types.Location -import Development.Shake (getDirectoryFilesIO) -import Ide.Plugin.Config -import Language.LSP.Test -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start), - mkRange) -import Language.LSP.Types.Capabilities -import qualified Language.LSP.Types.Lens as Lens (label) -import qualified Language.LSP.Types.Lens as Lsp (diagnostics, - message, - params) -import Language.LSP.VFS (VfsLog, applyChange) -import Network.URI -import System.Directory -import System.Environment.Blank (getEnv, setEnv, - unsetEnv) -import System.Exit (ExitCode (ExitSuccess)) -import System.FilePath -import System.Info.Extra (isMac, isWindows) -import qualified System.IO.Extra -import System.IO.Extra hiding (withTempDir) -import System.Mem (performGC) -import System.Process.Extra (CreateProcess (cwd), - createPipe, proc, - readCreateProcessWithExitCode) -import Test.QuickCheck --- import Test.QuickCheck.Instances () -import Control.Concurrent.Async -import Control.Lens (to, (.~), (^.)) -import Control.Monad.Extra (whenJust) -import Data.Function ((&)) -import Data.Functor.Identity (runIdentity) -import Data.IORef -import Data.IORef.Extra (atomicModifyIORef_) -import Data.String (IsString (fromString)) -import Data.Tuple.Extra -import Development.IDE.Core.FileStore (getModTime) -import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide -import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), - WaitForIdeRuleResult (..), - blockCommandId) -import Development.IDE.Types.Logger (Logger (Logger), - LoggingColumn (DataColumn, PriorityColumn), - Pretty (pretty), - Priority (Debug), - Recorder (Recorder, logger_), - WithPriority (WithPriority, priority), - cfilter, - cmapWithPrio, - makeDefaultStderrRecorder, - toCologActionWithPrio) -import qualified FuzzySearch -import GHC.Stack (emptyCallStack) -import qualified HieDbRetry -import Ide.PluginUtils (pluginDescToIdePlugins) -import Ide.Types -import qualified Language.LSP.Types as LSP -import Language.LSP.Types.Lens (didChangeWatchedFiles, - workspace) -import qualified Language.LSP.Types.Lens as L -import qualified Progress -import System.Time.Extra -import qualified Test.QuickCheck.Monadic as MonadicQuickCheck -import Test.QuickCheck.Monadic (forAllM, monadicIO) -import Test.Tasty -import Test.Tasty.ExpectedFailure -import Test.Tasty.HUnit -import Test.Tasty.Ingredients.Rerun -import Test.Tasty.QuickCheck -import Text.Printf (printf) -import Text.Regex.TDFA ((=~)) - -data Log - = LogGhcIde Ghcide.Log - | LogIDEMain IDE.Log - | LogVfs VfsLog - -instance Pretty Log where - pretty = \case - LogGhcIde log -> pretty log - LogIDEMain log -> pretty log - LogVfs log -> pretty log - --- | Wait for the next progress begin step -waitForProgressBegin :: Session () -waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (Begin _))) -> Just () - _ -> Nothing - --- | Wait for the first progress end step --- Also implemented in hls-test-utils Test.Hls -waitForProgressDone :: Session () -waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () - _ -> Nothing - --- | Wait for all progress to be done --- Needs at least one progress done notification to return --- Also implemented in hls-test-utils Test.Hls -waitForAllProgressDone :: Session () -waitForAllProgressDone = loop - where - loop = do - ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () - _ -> Nothing - done <- null <$> getIncompleteProgressSessions - unless done loop - -main :: IO () -main = do - docWithPriorityRecorder <- makeDefaultStderrRecorder (Just [PriorityColumn, DataColumn]) Debug - - let docWithFilteredPriorityRecorder@Recorder{ logger_ } = - docWithPriorityRecorder - & cfilter (\WithPriority{ priority } -> priority >= Debug) - - -- exists so old-style logging works. intended to be phased out - let logger = Logger $ \p m -> logger_ (WithPriority p emptyCallStack (pretty m)) - - let recorder = docWithFilteredPriorityRecorder - & cmapWithPrio pretty - - -- We mess with env vars so run single-threaded. - defaultMainWithRerun $ testGroup "ghcide" - [ testSession "open close" $ do - doc <- createDoc "Testing.hs" "haskell" "" - void (skipManyTill anyMessage $ message SWindowWorkDoneProgressCreate) - waitForProgressBegin - closeDoc doc - waitForProgressDone - , initializeResponseTests - , completionTests - , cppTests - , diagnosticTests - , codeLensesTests - , outlineTests - , highlightTests - , findDefinitionAndHoverTests - , pluginSimpleTests - , pluginParsedResultTests - , preprocessorTests - , thTests - , symlinkTests - , safeTests - , unitTests recorder logger - , haddockTests - , positionMappingTests recorder - , watchedFilesTests - , cradleTests - , dependentFileTest - , nonLspCommandLine - , ifaceTests - , bootTests - , rootUriTests - , asyncTests - , clientSettingsTest - , referenceTests - , garbageCollectionTests - , HieDbRetry.tests - ] - -initializeResponseTests :: TestTree -initializeResponseTests = withResource acquire release tests where - - -- these tests document and monitor the evolution of the - -- capabilities announced by the server in the initialize - -- response. Currently the server advertises almost no capabilities - -- at all, in some cases failing to announce capabilities that it - -- actually does provide! Hopefully this will change ... - tests :: IO (ResponseMessage Initialize) -> TestTree - tests getInitializeResponse = - testGroup "initialize response capabilities" - [ chk " text doc sync" _textDocumentSync tds - , chk " hover" _hoverProvider (Just $ InL True) - , chk " completion" _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just True)) - , chk "NO signature help" _signatureHelpProvider Nothing - , chk " goto definition" _definitionProvider (Just $ InL True) - , chk " goto type definition" _typeDefinitionProvider (Just $ InL True) - -- BUG in lsp-test, this test fails, just change the accepted response - -- for now - , chk "NO goto implementation" _implementationProvider (Just $ InL False) - , chk " find references" _referencesProvider (Just $ InL True) - , chk " doc highlight" _documentHighlightProvider (Just $ InL True) - , chk " doc symbol" _documentSymbolProvider (Just $ InL True) - , chk " workspace symbol" _workspaceSymbolProvider (Just $ InL True) - , chk " code action" _codeActionProvider (Just $ InL False) - , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just False)) - , chk "NO doc formatting" _documentFormattingProvider (Just $ InL False) - , chk "NO doc range formatting" - _documentRangeFormattingProvider (Just $ InL False) - , chk "NO doc formatting on typing" - _documentOnTypeFormattingProvider Nothing - , chk "NO renaming" _renameProvider (Just $ InL False) - , chk "NO doc link" _documentLinkProvider Nothing - , chk "NO color" (^. L.colorProvider) (Just $ InL False) - , chk "NO folding range" _foldingRangeProvider (Just $ InL False) - , che " execute command" _executeCommandProvider [typeLensCommandId, blockCommandId] - , chk " workspace" (^. L.workspace) (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )})) - , chk "NO experimental" (^. L.experimental) Nothing - ] where - - tds = Just (InL (TextDocumentSyncOptions - { _openClose = Just True - , _change = Just TdSyncIncremental - , _willSave = Nothing - , _willSaveWaitUntil = Nothing - , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) - - chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree - chk title getActual expected = - testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir - - che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree - che title getActual expected = testCase title doTest - where - doTest = do - ir <- getInitializeResponse - let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir - commandNames = (!! 2) . T.splitOn ":" <$> commands - zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames) - - innerCaps :: ResponseMessage Initialize -> ServerCapabilities - innerCaps (ResponseMessage _ _ (Right (InitializeResult c _))) = c - innerCaps (ResponseMessage _ _ (Left _)) = error "Initialization error" - - acquire :: IO (ResponseMessage Initialize) - acquire = run initializeResponse - - release :: ResponseMessage Initialize -> IO () - release = const $ pure () - - -diagnosticTests :: TestTree -diagnosticTests = testGroup "diagnostics" - [ testSessionWait "fix syntax error" $ do - let content = T.unlines [ "module Testing wher" ] - doc <- createDoc "Testing.hs" "haskell" content - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 15) (Position 0 19)) - , _rangeLength = Nothing - , _text = "where" - } - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [])] - , testSessionWait "introduce syntax error" $ do - let content = T.unlines [ "module Testing where" ] - doc <- createDoc "Testing.hs" "haskell" content - void $ skipManyTill anyMessage (message SWindowWorkDoneProgressCreate) - waitForProgressBegin - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 15) (Position 0 18)) - , _rangeLength = Nothing - , _text = "wher" - } - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] - , testSessionWait "update syntax error" $ do - let content = T.unlines [ "module Testing(missing) where" ] - doc <- createDoc "Testing.hs" "haskell" content - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'missing'")])] - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 15) (Position 0 16)) - , _rangeLength = Nothing - , _text = "l" - } - changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'lissing'")])] - , testSessionWait "variable not in scope" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> Int -> Int" - , "foo a _b = a + ab" - , "bar :: Int -> Int -> Int" - , "bar _a b = cd + b" - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [ (DsError, (2, 15), "Variable not in scope: ab") - , (DsError, (4, 11), "Variable not in scope: cd") - ] - ) - ] - , testSessionWait "type error" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> String -> Int" - , "foo a b = a + b" - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")] - ) - ] - , testSessionWait "typed hole" $ do - let content = T.unlines - [ "module Testing where" - , "foo :: Int -> String" - , "foo a = _ a" - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs" - , [(DsError, (2, 8), "Found hole: _ :: Int -> String")] - ) - ] - - , testGroup "deferral" $ - let sourceA a = T.unlines - [ "module A where" - , "a :: Int" - , "a = " <> a] - sourceB = T.unlines - [ "module B where" - , "import A ()" - , "b :: Float" - , "b = True"] - bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'" - expectedDs aMessage = - [ ("A.hs", [(DsError, (2,4), aMessage)]) - , ("B.hs", [(DsError, (3,4), bMessage)])] - deferralTest title binding msg = testSessionWait title $ do - _ <- createDoc "A.hs" "haskell" $ sourceA binding - _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics $ expectedDs msg - in - [ deferralTest "type error" "True" "Couldn't match expected type" - , deferralTest "typed hole" "_" "Found hole" - , deferralTest "out of scope var" "unbound" "Variable not in scope" - ] - - , testSessionWait "remove required module" $ do - let contentA = T.unlines [ "module ModuleA where" ] - docA <- createDoc "ModuleA.hs" "haskell" contentA - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA" - ] - _ <- createDoc "ModuleB.hs" "haskell" contentB - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 0) (Position 0 20)) - , _rangeLength = Nothing - , _text = "" - } - changeDoc docA [change] - expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])] - , testSessionWait "add missing module" $ do - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA ()" - ] - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] - let contentA = T.unlines [ "module ModuleA where" ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - expectDiagnostics [("ModuleB.hs", [])] - , testCase "add missing module (non workspace)" $ - -- By default lsp-test sends FileWatched notifications for all files, which we don't want - -- as non workspace modules will not be watched by the LSP server. - -- To work around this, we tell lsp-test that our client doesn't have the - -- FileWatched capability, which is enough to disable the notifications - withTempDir $ \tmpDir -> runInDir'' lspTestCapsNoFileWatches tmpDir "." "." [] $ do - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA ()" - ] - _ <- createDoc (tmpDir "ModuleB.hs") "haskell" contentB - expectDiagnostics [(tmpDir "ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] - let contentA = T.unlines [ "module ModuleA where" ] - _ <- createDoc (tmpDir "ModuleA.hs") "haskell" contentA - expectDiagnostics [(tmpDir "ModuleB.hs", [])] - , testSessionWait "cyclic module dependency" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "import ModuleB" - ] - let contentB = T.unlines - [ "module ModuleB where" - , "import ModuleA" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics - [ ( "ModuleA.hs" - , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] - ) - , ( "ModuleB.hs" - , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] - ) - ] - , testSession' "deeply nested cyclic module dependency" $ \path -> do - let contentA = unlines - [ "module ModuleA where" , "import ModuleB" ] - let contentB = unlines - [ "module ModuleB where" , "import ModuleA" ] - let contentC = unlines - [ "module ModuleC where" , "import ModuleB" ] - let contentD = T.unlines - [ "module ModuleD where" , "import ModuleC" ] - cradle = - "cradle: {direct: {arguments: [ModuleA, ModuleB, ModuleC, ModuleD]}}" - liftIO $ writeFile (path "ModuleA.hs") contentA - liftIO $ writeFile (path "ModuleB.hs") contentB - liftIO $ writeFile (path "ModuleC.hs") contentC - liftIO $ writeFile (path "hie.yaml") cradle - _ <- createDoc "ModuleD.hs" "haskell" contentD - expectDiagnostics - [ ( "ModuleB.hs" - , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] - ) - ] - , testSessionWait "cyclic module dependency with hs-boot" $ do - let contentA = T.unlines - [ "module ModuleA where" - , "import {-# SOURCE #-} ModuleB" - ] - let contentB = T.unlines - [ "{-# OPTIONS -Wmissing-signatures#-}" - , "module ModuleB where" - , "import ModuleA" - -- introduce an artificial diagnostic - , "foo = ()" - ] - let contentBboot = T.unlines - [ "module ModuleB where" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot - expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])] - , testSessionWait "correct reference used with hs-boot" $ do - let contentB = T.unlines - [ "module ModuleB where" - , "import {-# SOURCE #-} ModuleA()" - ] - let contentA = T.unlines - [ "module ModuleA where" - , "import ModuleB()" - , "x = 5" - ] - let contentAboot = T.unlines - [ "module ModuleA where" - ] - let contentC = T.unlines - [ "{-# OPTIONS -Wmissing-signatures #-}" - , "module ModuleC where" - , "import ModuleA" - -- this reference will fail if it gets incorrectly - -- resolved to the hs-boot file - , "y = x" - ] - _ <- createDoc "ModuleB.hs" "haskell" contentB - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot - _ <- createDoc "ModuleC.hs" "haskell" contentC - expectDiagnostics [("ModuleC.hs", [(DsWarning, (3,0), "Top-level binding")])] - , testSessionWait "redundant import" $ do - let contentA = T.unlines ["module ModuleA where"] - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wunused-imports #-}" - , "module ModuleB where" - , "import ModuleA" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnosticsWithTags - [ ( "ModuleB.hs" - , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant", Just DtUnnecessary)] - ) - ] - , testSessionWait "redundant import even without warning" $ do - let contentA = T.unlines ["module ModuleA where"] - let contentB = T.unlines - [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}" - , "module ModuleB where" - , "import ModuleA" - -- introduce an artificial warning for testing purposes - , "foo = ()" - ] - _ <- createDoc "ModuleA.hs" "haskell" contentA - _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])] - , testSessionWait "package imports" $ do - let thisDataListContent = T.unlines - [ "module Data.List where" - , "x :: Integer" - , "x = 123" - ] - let mainContent = T.unlines - [ "{-# LANGUAGE PackageImports #-}" - , "module Main where" - , "import qualified \"this\" Data.List as ThisList" - , "import qualified \"base\" Data.List as BaseList" - , "useThis = ThisList.x" - , "useBase = BaseList.map" - , "wrong1 = ThisList.map" - , "wrong2 = BaseList.x" - , "main = pure ()" - ] - _ <- createDoc "Data/List.hs" "haskell" thisDataListContent - _ <- createDoc "Main.hs" "haskell" mainContent - expectDiagnostics - [ ( "Main.hs" - , [(DsError, (6, 9), - if ghcVersion >= GHC94 - then "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 - else "Not in scope: \8216ThisList.map\8217") - ,(DsError, (7, 9), - if ghcVersion >= GHC94 - then "Variable not in scope: x" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 - else "Not in scope: \8216BaseList.x\8217") - ] - ) - ] - , testSessionWait "unqualified warnings" $ do - let fooContent = T.unlines - [ "{-# OPTIONS_GHC -Wredundant-constraints #-}" - , "module Foo where" - , "foo :: Ord a => a -> Int" - , "foo _a = 1" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics - [ ( "Foo.hs" - -- The test is to make sure that warnings contain unqualified names - -- where appropriate. The warning should use an unqualified name 'Ord', not - -- something like 'GHC.Classes.Ord'. The choice of redundant-constraints to - -- test this is fairly arbitrary. - , [(DsWarning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a") - ] - ) - ] - , testSessionWait "lower-case drive" $ do - let aContent = T.unlines - [ "module A.A where" - , "import A.B ()" - ] - bContent = T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module A.B where" - , "import Data.List" - ] - uriB <- getDocUri "A/B.hs" - Just pathB <- pure $ uriToFilePath uriB - uriB <- pure $ - let (drive, suffix) = splitDrive pathB - in filePathToUri (joinDrive (lower drive) suffix) - liftIO $ createDirectoryIfMissing True (takeDirectory pathB) - liftIO $ writeFileUTF8 pathB $ T.unpack bContent - uriA <- getDocUri "A/A.hs" - Just pathA <- pure $ uriToFilePath uriA - uriA <- pure $ - let (drive, suffix) = splitDrive pathA - in filePathToUri (joinDrive (lower drive) suffix) - let itemA = TextDocumentItem uriA "haskell" 0 aContent - let a = TextDocumentIdentifier uriA - sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams itemA) - NotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic - -- Check that if we put a lower-case drive in for A.A - -- the diagnostics for A.B will also be lower-case. - liftIO $ fileUri @?= uriB - let msg = head (toList diags) ^. L.message - liftIO $ unless ("redundant" `T.isInfixOf` msg) $ - assertFailure ("Expected redundant import but got " <> T.unpack msg) - closeDoc a - , testSessionWait "haddock parse error" $ do - let fooContent = T.unlines - [ "module Foo where" - , "foo :: Int" - , "foo = 1 {-|-}" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - if ghcVersion >= GHC90 then - -- Haddock parse errors are ignored on ghc-9.0 - pure () - else - expectDiagnostics - [ ( "Foo.hs" - , [(DsWarning, (2, 8), "Haddock parse error on input")] - ) - ] - , testSessionWait "strip file path" $ do - let - name = "Testing" - content = T.unlines - [ "module " <> name <> " where" - , "value :: Maybe ()" - , "value = [()]" - ] - _ <- createDoc (T.unpack name <> ".hs") "haskell" content - notification <- skipManyTill anyMessage diagnostic - let - offenders = - Lsp.params . - Lsp.diagnostics . - Lens.folded . - Lsp.message . - Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:")) - failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg - Lens.mapMOf_ offenders failure notification - , testSession' "-Werror in cradle is ignored" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wall\", \"-Werror\"]}}" - let fooContent = T.unlines - [ "module Foo where" - , "foo = ()" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics - [ ( "Foo.hs" - , [(DsWarning, (1, 0), "Top-level binding with no type signature:") - ] - ) - ] - , testSessionWait "-Werror in pragma is ignored" $ do - let fooContent = T.unlines - [ "{-# OPTIONS_GHC -Wall -Werror #-}" - , "module Foo() where" - , "foo :: Int" - , "foo = 1" - ] - _ <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics - [ ( "Foo.hs" - , [(DsWarning, (3, 0), "Defined but not used:") - ] - ) - ] - , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir "B.hs" - pPath = dir "P.hs" - aPath = dir "A.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - aSource <- liftIO $ readFileUtf8 aPath -- x = y :: Int - - bdoc <- createDoc bPath "haskell" bSource - _pdoc <- createDoc pPath "haskell" pSource - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded - - -- Change y from Int to B which introduces a type error in A (imported from P) - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ - T.unlines ["module B where", "y :: Bool", "y = undefined"]] - expectDiagnostics - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ] - - -- Open A and edit to fix the type error - adoc <- createDoc aPath "haskell" aSource - changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing $ - T.unlines ["module A where", "import B", "x :: Bool", "x = y"]] - - expectDiagnostics - [ ( "P.hs", - [ (DsError, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"), - (DsWarning, (4, 0), "Top-level binding") - ] - ), - ("A.hs", []) - ] - expectNoMoreDiagnostics 1 - - , testSessionWait "deduplicate missing module diagnostics" $ do - let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ] - doc <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])] - - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module Foo() where" ] - expectDiagnostics [] - - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines - [ "module Foo() where" , "import MissingModule" ] ] - expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])] - - , testGroup "Cancellation" - [ cancellationTestGroup "edit header" editHeader yesSession noParse noTc - , cancellationTestGroup "edit import" editImport noSession yesParse noTc - , cancellationTestGroup "edit body" editBody yesSession yesParse yesTc - ] - ] - where - editPair x y = let p = Position x y ; p' = Position x (y+2) in - (TextDocumentContentChangeEvent {_range=Just (Range p p), _rangeLength=Nothing, _text="fd"} - ,TextDocumentContentChangeEvent {_range=Just (Range p p'), _rangeLength=Nothing, _text=""}) - editHeader = editPair 0 0 - editImport = editPair 2 10 - editBody = editPair 3 10 - - noParse = False - yesParse = True - - noSession = False - yesSession = True - - noTc = False - yesTc = True - -cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> TestTree -cancellationTestGroup name edits sessionDepsOutcome parseOutcome tcOutcome = testGroup name - [ cancellationTemplate edits Nothing - , cancellationTemplate edits $ Just ("GetFileContents", True) - , cancellationTemplate edits $ Just ("GhcSession", True) - -- the outcome for GetModSummary is always True because parseModuleHeader never fails (!) - , cancellationTemplate edits $ Just ("GetModSummary", True) - , cancellationTemplate edits $ Just ("GetModSummaryWithoutTimestamps", True) - -- getLocatedImports never fails - , cancellationTemplate edits $ Just ("GetLocatedImports", True) - , cancellationTemplate edits $ Just ("GhcSessionDeps", sessionDepsOutcome) - , cancellationTemplate edits $ Just ("GetParsedModule", parseOutcome) - , cancellationTemplate edits $ Just ("TypeCheck", tcOutcome) - , cancellationTemplate edits $ Just ("GetHieAst", tcOutcome) - ] - -cancellationTemplate :: (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Maybe (String, Bool) -> TestTree -cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ runTestNoKick $ do - doc <- createDoc "Foo.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "module Foo where" - , "import Data.List()" - , "f0 x = (x,x)" - ] - - -- for the example above we expect one warning - let missingSigDiags = [(DsWarning, (3, 0), "Top-level binding") ] - typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags - - -- Now we edit the document and wait for the given key (if any) - changeDoc doc [edit] - whenJust mbKey $ \(key, expectedResult) -> do - WaitForIdeRuleResult{ideResultSuccess} <- waitForAction key doc - liftIO $ ideResultSuccess @?= expectedResult - - -- The 2nd edit cancels the active session and unbreaks the file - -- wait for typecheck and check that the current diagnostics are accurate - changeDoc doc [undoEdit] - typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags - - expectNoMoreDiagnostics 0.5 - where - -- similar to run except it disables kick - runTestNoKick s = withTempDir $ \dir -> runInDir' dir "." "." ["--test-no-kick"] s - - typeCheck doc = do - 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 - -- flush messages to ensure current diagnostics state is updated - flushMessages - -codeLensesTests :: TestTree -codeLensesTests = testGroup "code lenses" - [ addSigLensesTests - ] - -watchedFilesTests :: TestTree -watchedFilesTests = testGroup "watched files" - [ testGroup "Subscriptions" - [ testSession' "workspace files" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}" - _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule" - watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics - - -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle - liftIO $ length watchedFileRegs @?= 2 - - , testSession' "non workspace file" $ \sessionDir -> do - tmpDir <- liftIO getTemporaryDirectory - let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}" - liftIO $ writeFile (sessionDir "hie.yaml") yaml - _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" - watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics - - -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle - liftIO $ length watchedFileRegs @?= 2 - - -- TODO add a test for didChangeWorkspaceFolder - ] - , testGroup "Changes" - [ - testSession' "workspace files" $ \sessionDir -> do - liftIO $ writeFile (sessionDir "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}" - liftIO $ writeFile (sessionDir "B.hs") $ unlines - ["module B where" - ,"b :: Bool" - ,"b = False"] - _doc <- createDoc "A.hs" "haskell" $ T.unlines - ["module A where" - ,"import B" - ,"a :: ()" - ,"a = b" - ] - expectDiagnostics [("A.hs", [(DsError, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'")])] - -- modify B off editor - liftIO $ writeFile (sessionDir "B.hs") $ unlines - ["module B where" - ,"b :: Int" - ,"b = 0"] - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri $ sessionDir "B.hs") FcChanged ] - expectDiagnostics [("A.hs", [(DsError, (3, 4), "Couldn't match expected type '()' with actual type 'Int'")])] - ] - ] - -addSigLensesTests :: TestTree -addSigLensesTests = - let pragmas = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}" - moduleH exported = - T.unlines - [ "{-# LANGUAGE PatternSynonyms,TypeApplications,DataKinds,RankNTypes,ScopedTypeVariables,TypeOperators,GADTs,BangPatterns #-}" - , "module Sigs(" <> exported <> ") where" - , "import qualified Data.Complex as C" - , "import Data.Data (Proxy (..), type (:~:) (..), mkCharType)" - , "data T1 a where" - , " MkT1 :: (Show b) => a -> b -> T1 a" - ] - before enableGHCWarnings exported (def, _) others = - T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported, def] <> others - after' enableGHCWarnings exported (def, sig) others = - T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others - createConfig mode = A.object ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]] - sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do - let originalCode = before enableGHCWarnings exported def others - let expectedCode = after' enableGHCWarnings exported def others - sendNotification SWorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode - doc <- createDoc "Sigs.hs" "haskell" originalCode - waitForProgressDone - codeLenses <- getCodeLenses doc - if not $ null $ snd def - then do - liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses - executeCommand $ fromJust $ head codeLenses ^. L.command - modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc) - liftIO $ expectedCode @=? modifiedCode - else liftIO $ null codeLenses @? "Expected no code lens, but got: " <> show codeLenses - cases = - [ ("abc = True", "abc :: Bool") - , ("foo a b = a + b", "foo :: Num a => a -> a -> a") - , ("bar a b = show $ a + b", "bar :: (Show a, Num a) => a -> a -> String") - , ("(!!!) a b = a > b", "(!!!) :: Ord a => a -> a -> Bool") - , ("a >>>> b = a + b", "(>>>>) :: Num a => a -> a -> a") - , ("a `haha` b = a b", "haha :: (t1 -> t2) -> t1 -> t2") - , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a") - , ("pattern Some a <- Just a", "pattern Some :: a -> Maybe a") - , ("pattern Some a <- Just a\n where Some a = Just a", "pattern Some :: a -> Maybe a") - , ("pattern Some a <- Just !a\n where Some !a = Just a", "pattern Some :: a -> Maybe a") - , ("pattern Point{x, y} = (x, y)", "pattern Point :: a -> b -> (a, b)") - , ("pattern Point{x, y} <- (x, y)", "pattern Point :: a -> b -> (a, b)") - , ("pattern Point{x, y} <- (x, y)\n where Point x y = (x, y)", "pattern Point :: a -> b -> (a, b)") - , ("pattern MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") - , ("pattern MkT1' b <- MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") - , ("pattern MkT1' b <- MkT1 42 b\n where MkT1' b = MkT1 42 b", "pattern MkT1' :: (Eq a, Num a) => Show b => b -> T1 a") - , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a") - , ("head = 233", "head :: Integer") - , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")") - , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"") - , ("promotedKindTest = Proxy @Nothing", "promotedKindTest :: Proxy 'Nothing") - , ("typeOperatorTest = Refl", if ghcVersion >= GHC92 then "typeOperatorTest :: forall {k} {a :: k}. a :~: a" else "typeOperatorTest :: a :~: a") - , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType") - ] - in testGroup - "add signature" - [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False "always" "" (def, Just sig) [] | (def, sig) <- cases] - , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) - , testGroup - "diagnostics mode works" - [ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) [] - , sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) [] - ] - ] - -linkToLocation :: [LocationLink] -> [Location] -linkToLocation = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange) - -checkDefs :: [Location] |? [LocationLink] -> Session [Expect] -> Session () -checkDefs (either id linkToLocation . toEither -> defs) mkExpectations = traverse_ check =<< mkExpectations where - check (ExpectRange expectedRange) = do - assertNDefinitionsFound 1 defs - assertRangeCorrect (head defs) expectedRange - check (ExpectLocation expectedLocation) = do - assertNDefinitionsFound 1 defs - liftIO $ do - canonActualLoc <- canonicalizeLocation (head defs) - canonExpectedLoc <- canonicalizeLocation expectedLocation - canonActualLoc @?= canonExpectedLoc - check ExpectNoDefinitions = do - assertNDefinitionsFound 0 defs - check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file" - check _ = pure () -- all other expectations not relevant to getDefinition - - assertNDefinitionsFound :: Int -> [a] -> Session () - assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs) - - assertRangeCorrect Location{_range = foundRange} expectedRange = - liftIO $ expectedRange @=? foundRange - -canonicalizeLocation :: Location -> IO Location -canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range - -findDefinitionAndHoverTests :: TestTree -findDefinitionAndHoverTests = let - - tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree - tst (get, check) pos sfp targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do - - -- Dirty the cache to check that definitions work even in the presence of iface files - liftIO $ runInDir dir $ do - let fooPath = dir "Foo.hs" - fooSource <- liftIO $ readFileUtf8 fooPath - fooDoc <- createDoc fooPath "haskell" fooSource - _ <- getHover fooDoc $ Position 4 3 - closeDoc fooDoc - - doc <- openTestDataDoc (dir sfp) - waitForProgressDone - found <- get doc pos - check found targetRange - - - - checkHover :: Maybe Hover -> Session [Expect] -> Session () - checkHover hover expectations = traverse_ check =<< expectations where - - check expected = - case hover of - Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" - Just Hover{_contents = (HoverContents MarkupContent{_value = standardizeQuotes -> msg}) - ,_range = rangeInHover } -> - case expected of - ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets - ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool) - ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover - _ -> pure () -- all other expectations not relevant to hover - _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover - - extractLineColFromHoverMsg :: T.Text -> [T.Text] - extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":") - - checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () - checkHoverRange expectedRange rangeInHover msg = - let - lineCol = extractLineColFromHoverMsg msg - -- looks like hovers use 1-based numbering while definitions use 0-based - -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. - adjust Position{_line = l, _character = c} = - Position{_line = l + 1, _character = c + 1} - in - case map (read . T.unpack) lineCol of - [l,c] -> liftIO $ adjust (_start expectedRange) @=? Position l c - _ -> liftIO $ assertFailure $ - "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> - "\n but got: " <> show (msg, rangeInHover) - - assertFoundIn :: T.Text -> T.Text -> Assertion - assertFoundIn part whole = assertBool - (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) - (part `T.isInfixOf` whole) - - sourceFilePath = T.unpack sourceFileName - sourceFileName = "GotoHover.hs" - - mkFindTests tests = testGroup "get" - [ testGroup "definition" $ mapMaybe fst tests - , testGroup "hover" $ mapMaybe snd tests - , checkFileCompiles sourceFilePath $ - expectDiagnostics - [ ( "GotoHover.hs", [(DsError, (62, 7), "Found hole: _")]) - , ( "GotoHover.hs", [(DsError, (65, 8), "Found hole: _")]) - ] - , testGroup "type-definition" typeDefinitionTests - , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ] - - typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 sourceFilePath (pure tcData) "Saturated data con" - , tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"] - - recordDotSyntaxTests - | ghcVersion >= GHC92 = - [ tst (getHover, checkHover) (Position 19 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent" - , tst (getHover, checkHover) (Position 19 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child" - , tst (getHover, checkHover) (Position 19 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child" - ] - | otherwise = [] - - test runDef runHover look expect = testM runDef runHover look (return expect) - - testM runDef runHover look expect title = - ( runDef $ tst def look sourceFilePath expect title - , runHover $ tst hover look sourceFilePath expect title ) where - def = (getDefinitions, checkDefs) - hover = (getHover , checkHover) - - -- search locations expectations on results - fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR] - fffL8 = Position 12 4 ; - fffL14 = Position 18 7 ; - aL20 = Position 19 15 - aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] - dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] - dcL12 = Position 16 11 ; - xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]] - tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]] - vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6] - opL16 = Position 20 15 ; op = [mkR 21 2 21 4] - opL18 = Position 22 22 ; opp = [mkR 22 13 22 17] - aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11] - b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7] - xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["pack", ":: String -> Text", "Data.Text", "text"]] - clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]] - clL25 = Position 29 9 - eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num", "base"]] - dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21] - dnbL30 = Position 34 23 - lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27] - lclL33 = Position 37 22 - mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14] - mclL37 = Position 41 1 - spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]] - docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]] - ; constr = [ExpectHoverText ["Monad m"]] - eitL40 = Position 44 28 ; kindE = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type -> Type -> Type\n" else ":: * -> * -> *\n"]] - intL40 = Position 44 34 ; kindI = [ExpectHoverText [if ghcVersion >= GHC92 then ":: Type\n" else ":: *\n"]] - tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]] - intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]] - chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]] - txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]] - lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]] - outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 50 0 50 5] - innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] - holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]] - holeL65 = Position 65 8 ; hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]] - cccL17 = Position 17 16 ; docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"] - imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3] - reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)] - thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]] - in - mkFindTests - -- def hover look expect - [ - if ghcVersion >= GHC90 then - -- It suggests either going to the constructor or to the field - test broken yes fffL4 fff "field in record definition" - else - test yes yes fffL4 fff "field in record definition" - , test yes yes fffL8 fff "field in record construction #1102" - , test yes yes fffL14 fff "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs - , test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes dcL7 tcDC "data constructor record #1029" - , test yes yes dcL12 tcDC "data constructor plain" -- https://github.com/haskell/ghcide/pull/121 - , test yes yes tcL6 tcData "type constructor #1028" -- https://github.com/haskell/ghcide/pull/147 - , test broken yes xtcL5 xtc "type constructor external #717,1028" - , test broken yes xvL20 xvMsg "value external package #717" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes vvL16 vv "plain parameter" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes aL18 apmp "pattern match name" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes opL16 op "top-level operator #713" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes opL18 opp "parameter operator" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes b'L19 bp "name in backticks" -- https://github.com/haskell/ghcide/pull/120 - , test yes yes clL23 cls "class in instance declaration #1027" - , test yes yes clL25 cls "class in signature #1027" -- https://github.com/haskell/ghcide/pull/147 - , test broken yes eclL15 ecls "external class in signature #717,1027" - , test yes yes dnbL29 dnb "do-notation bind #1073" - , test yes yes dnbL30 dnb "do-notation lookup" - , test yes yes lcbL33 lcb "listcomp bind #1073" - , test yes yes lclL33 lcb "listcomp lookup" - , test yes yes mclL36 mcl "top-level fn 1st clause" - , test yes yes mclL37 mcl "top-level fn 2nd clause #1030" - , if ghcVersion >= GHC810 then - test yes yes spaceL37 space "top-level fn on space #1002" - else - test yes broken spaceL37 space "top-level fn on space #1002" - , test no yes docL41 doc "documentation #1129" - , test no yes eitL40 kindE "kind of Either #1017" - , test no yes intL40 kindI "kind of Int #1017" - , test no broken tvrL40 kindV "kind of (* -> *) type variable #1017" - , test no broken intL41 litI "literal Int in hover info #1016" - , test no broken chrL36 litC "literal Char in hover info #1016" - , test no broken txtL8 litT "literal Text in hover info #1016" - , test no broken lstL43 litL "literal List in hover info #1016" - , if ghcVersion >= GHC90 then - test no yes docL41 constr "type constraint in hover info #1012" - else - test no broken docL41 constr "type constraint in hover info #1012" - , test no yes outL45 outSig "top-level signature #767" - , test broken broken innL48 innSig "inner signature #767" - , test no yes holeL60 hleInfo "hole without internal name #831" - , test no yes holeL65 hleInfo2 "hole with variable" - , test no yes cccL17 docLink "Haddock html links" - , testM yes yes imported importedSig "Imported symbol" - , if | isWindows -> - -- Flaky on Windows: https://github.com/haskell/haskell-language-server/issues/2997 - testM no yes reexported reexportedSig "Imported symbol (reexported)" - | otherwise -> - testM yes yes reexported reexportedSig "Imported symbol (reexported)" - , if | ghcVersion == GHC90 && isWindows -> - test no broken thLocL57 thLoc "TH Splice Hover" - | ghcVersion == GHC92 && (isWindows || isMac) -> - -- Some GHC 9.2 distributions ship without .hi docs - -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903 - test no broken thLocL57 thLoc "TH Splice Hover" - | otherwise -> - test no yes thLocL57 thLoc "TH Splice Hover" - ] - where yes, broken :: (TestTree -> Maybe TestTree) - yes = Just -- test should run and pass - broken = Just . (`xfail` "known broken") - no = const Nothing -- don't run this test at all - skip = const Nothing -- unreliable, don't run - -checkFileCompiles :: FilePath -> Session () -> TestTree -checkFileCompiles fp diag = - testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do - void (openTestDataDoc (dir fp)) - diag - - -pluginSimpleTests :: TestTree -pluginSimpleTests = - ignoreInWindowsForGHC810 $ - -- Build profile: -w ghc-9.4.2 -O1 - -- In order, the following will be built (use -v for more details): - -- - ghc-typelits-natnormalise-0.7.7 (lib) (requires build) - -- - ghc-typelits-knownnat-0.7.7 (lib) (requires build) - -- - plugin-1.0.0 (lib) (first run) - -- Starting ghc-typelits-natnormalise-0.7.7 (lib) - -- Building ghc-typelits-natnormalise-0.7.7 (lib) - - -- Failed to build ghc-typelits-natnormalise-0.7.7. - -- Build log ( - -- C:\cabal\logs\ghc-9.4.2\ghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.log - -- ): - -- Preprocessing library for ghc-typelits-natnormalise-0.7.7.. - -- Building library for ghc-typelits-natnormalise-0.7.7.. - -- [1 of 3] Compiling GHC.TypeLits.Normalise.SOP ( src\GHC\TypeLits\Normalise\SOP.hs, dist\build\GHC\TypeLits\Normalise\SOP.o ) - -- [2 of 3] Compiling GHC.TypeLits.Normalise.Unify ( src\GHC\TypeLits\Normalise\Unify.hs, dist\build\GHC\TypeLits\Normalise\Unify.o ) - -- [3 of 3] Compiling GHC.TypeLits.Normalise ( src-ghc-9.4\GHC\TypeLits\Normalise.hs, dist\build\GHC\TypeLits\Normalise.o ) - -- C:\tools\ghc-9.4.2\lib\../mingw/bin/llvm-ar.exe: error: dist\build\objs-5156\libHSghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.a: No such file or directory - - -- Error: cabal: Failed to build ghc-typelits-natnormalise-0.7.7 (which is - -- required by plugin-1.0.0). See the build log above for details. - ignoreFor (BrokenSpecific Windows [GHC94]) "ghc-typelist-natnormalise fails to build on GHC 9.4.2 for windows only" $ - testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do - _ <- openDoc (dir "KnownNat.hs") "haskell" - liftIO $ writeFile (dir"hie.yaml") - "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}" - - expectDiagnostics - [ ( "KnownNat.hs", - [(DsError, (9, 15), "Variable not in scope: c")] - ) - ] - -pluginParsedResultTests :: TestTree -pluginParsedResultTests = - ignoreInWindowsForGHC810 $ - ignoreForGHC92Plus "No need for this plugin anymore!" $ - testSessionWithExtraFiles "plugin-recorddot" "parsedResultAction plugin" $ \dir -> do - _ <- openDoc (dir "RecordDot.hs") "haskell" - expectNoMoreDiagnostics 2 - -cppTests :: TestTree -cppTests = - testGroup "cpp" - [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do - let content = - T.unlines - [ "{-# LANGUAGE CPP #-}", - "module Testing where", - "#ifdef FOO", - "foo = 42" - ] - -- The error locations differ depending on which C-preprocessor is used. - -- Some give the column number and others don't (hence maxBound == -1 unsigned). Assert either - -- of them. - (run $ expectError content (2, maxBound)) - `catch` ( \e -> do - let _ = e :: HUnitFailure - run $ expectError content (2, 1) - ) - , testSessionWait "cpp-ghcide" $ do - _ <- createDoc "A.hs" "haskell" $ T.unlines - ["{-# LANGUAGE CPP #-}" - ,"main =" - ,"#ifdef __GHCIDE__" - ," worked" - ,"#else" - ," failed" - ,"#endif" - ] - expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])] - ] - where - expectError :: T.Text -> Cursor -> Session () - expectError content cursor = do - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs", - [(DsError, cursor, "error: unterminated")] - ) - ] - expectNoMoreDiagnostics 0.5 - -preprocessorTests :: TestTree -preprocessorTests = testSessionWait "preprocessor" $ do - let content = - T.unlines - [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}" - , "module Testing where" - , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic - ] - _ <- createDoc "Testing.hs" "haskell" content - expectDiagnostics - [ ( "Testing.hs", - [(DsError, (2, 8), "Variable not in scope: z")] - ) - ] - - -safeTests :: TestTree -safeTests = - testGroup - "SafeHaskell" - [ -- Test for https://github.com/haskell/ghcide/issues/424 - testSessionWait "load" $ do - let sourceA = - T.unlines - ["{-# LANGUAGE Trustworthy #-}" - ,"module A where" - ,"import System.IO.Unsafe" - ,"import System.IO ()" - ,"trustWorthyId :: a -> a" - ,"trustWorthyId i = unsafePerformIO $ do" - ," putStrLn \"I'm safe\"" - ," return i"] - sourceB = - T.unlines - ["{-# LANGUAGE Safe #-}" - ,"module B where" - ,"import A" - ,"safeId :: a -> a" - ,"safeId = trustWorthyId" - ] - - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - expectNoMoreDiagnostics 1 ] - -thTests :: TestTree -thTests = - testGroup - "TemplateHaskell" - [ -- Test for https://github.com/haskell/ghcide/pull/212 - testSessionWait "load" $ do - let sourceA = - T.unlines - [ "{-# LANGUAGE PackageImports #-}", - "{-# LANGUAGE TemplateHaskell #-}", - "module A where", - "import \"template-haskell\" Language.Haskell.TH", - "a :: Integer", - "a = $(litE $ IntegerL 3)" - ] - sourceB = - T.unlines - [ "{-# LANGUAGE PackageImports #-}", - "{-# LANGUAGE TemplateHaskell #-}", - "module B where", - "import A", - "import \"template-haskell\" Language.Haskell.TH", - "b :: Integer", - "b = $(litE $ IntegerL $ a) + n" - ] - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ] - , testSessionWait "newtype-closure" $ do - let sourceA = - T.unlines - [ "{-# LANGUAGE DeriveDataTypeable #-}" - ,"{-# LANGUAGE TemplateHaskell #-}" - ,"module A (a) where" - ,"import Data.Data" - ,"import Language.Haskell.TH" - ,"newtype A = A () deriving (Data)" - ,"a :: ExpQ" - ,"a = [| 0 |]"] - let sourceB = - T.unlines - [ "{-# LANGUAGE TemplateHaskell #-}" - ,"module B where" - ,"import A" - ,"b :: Int" - ,"b = $( a )" ] - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - return () - , thReloadingTest False - , thLoadingTest - , thCoreTest - , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True - -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 - , thLinkingTest False - , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True - , testSessionWait "findsTHIdentifiers" $ do - let sourceA = - T.unlines - [ "{-# LANGUAGE TemplateHaskell #-}" - , "module A (a) where" - , "import Language.Haskell.TH (ExpQ)" - , "a :: ExpQ" -- TH 2.17 requires an explicit type signature since splices are polymorphic - , "a = [| glorifiedID |]" - , "glorifiedID :: a -> a" - , "glorifiedID = id" ] - let sourceB = - T.unlines - [ "{-# OPTIONS_GHC -Wall #-}" - , "{-# LANGUAGE TemplateHaskell #-}" - , "module B where" - , "import A" - , "main = $a (putStrLn \"success!\")"] - _ <- createDoc "A.hs" "haskell" sourceA - _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics [ ( "B.hs", [(DsWarning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ] - , testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do - - -- This test defines a TH value with the meaning "data A = A" in A.hs - -- Loads and export the template in B.hs - -- And checks wether the constructor A can be loaded in C.hs - -- This test does not fail when either A and B get manually loaded before C.hs - -- or when we remove the seemingly unnecessary TH pragma from C.hs - - let cPath = dir "C.hs" - _ <- openDoc cPath "haskell" - expectDiagnostics [ ( cPath, [(DsWarning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ] - ] - --- | Tests for projects that use symbolic links one way or another -symlinkTests :: TestTree -symlinkTests = - testGroup "Projects using Symlinks" - [ testCase "Module is symlinked" $ runWithExtraFiles "symlink" $ \dir -> do - liftIO $ createFileLink (dir "some_loc" "Sym.hs") (dir "other_loc" "Sym.hs") - let fooPath = dir "src" "Foo.hs" - _ <- openDoc fooPath "haskell" - expectDiagnosticsWithTags [("src" "Foo.hs", [(DsWarning, (2, 0), "The import of 'Sym' is redundant", Just DtUnnecessary)])] - pure () - ] - --- | Test that all modules have linkables -thLoadingTest :: TestTree -thLoadingTest = testCase "Loading linkables" $ runWithExtraFiles "THLoading" $ \dir -> do - let thb = dir "THB.hs" - _ <- openDoc thb "haskell" - expectNoMoreDiagnostics 1 - -thCoreTest :: TestTree -thCoreTest = testCase "Verifying TH core files" $ runWithExtraFiles "THCoreFile" $ \dir -> do - let thc = dir "THC.hs" - _ <- openDoc thc "haskell" - expectNoMoreDiagnostics 1 - --- | test that TH is reevaluated on typecheck -thReloadingTest :: Bool -> TestTree -thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do - - let aPath = dir "THA.hs" - bPath = dir "THB.hs" - cPath = dir "THC.hs" - - aSource <- liftIO $ readFileUtf8 aPath -- th = [d|a = ()|] - bSource <- liftIO $ readFileUtf8 bPath -- $th - cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () - - adoc <- createDoc aPath "haskell" aSource - bdoc <- createDoc bPath "haskell" bSource - cdoc <- createDoc cPath "haskell" cSource - - expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] - - -- Change th from () to Bool - let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"] - changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource'] - -- generate an artificial warning to avoid timing out if the TH change does not propagate - changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing $ cSource <> "\nfoo=()"] - - -- Check that the change propagates to C - expectDiagnostics - [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) - ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")]) - ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level bindin")]) - ] - - closeDoc adoc - closeDoc bdoc - closeDoc cdoc - where - name = "reloading-th-test" <> if unboxed then "-unboxed" else "" - dir | unboxed = "THUnboxed" - | otherwise = "TH" - -thLinkingTest :: Bool -> TestTree -thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do - - let aPath = dir "THA.hs" - bPath = dir "THB.hs" - - aSource <- liftIO $ readFileUtf8 aPath -- th_a = [d|a :: ()|] - bSource <- liftIO $ readFileUtf8 bPath -- $th_a - - adoc <- createDoc aPath "haskell" aSource - bdoc <- createDoc bPath "haskell" bSource - - expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] - - let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] - changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource'] - - -- modify b too - let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing bSource'] - waitForProgressBegin - waitForAllProgressDone - - expectCurrentDiagnostics bdoc [(DsWarning, (4,thDollarIdx), "Top-level binding")] - - closeDoc adoc - closeDoc bdoc - where - name = "th-linking-test" <> if unboxed then "-unboxed" else "" - dir | unboxed = "THUnboxed" - | otherwise = "TH" - -completionTests :: TestTree -completionTests - = testGroup "completion" - [ - testGroup "non local" nonLocalCompletionTests - , testGroup "topLevel" topLevelCompletionTests - , testGroup "local" localCompletionTests - , testGroup "package" packageCompletionTests - , testGroup "project" projectCompletionTests - , testGroup "other" otherCompletionTests - , testGroup "doc" completionDocTests - ] - -completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree -completionTest name src pos expected = testSessionWait name $ do - docId <- createDoc "A.hs" "haskell" (T.unlines src) - _ <- waitForDiagnostics - compls <- getCompletions docId pos - let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] - let emptyToMaybe x = if T.null x then Nothing else Just x - liftIO $ sortOn (Lens.view Lens._1) (take (length expected) compls') @?= - sortOn (Lens.view Lens._1) - [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] - forM_ (zip compls expected) $ \(item, (_,_,_,expectedSig, expectedDocs, _)) -> do - CompletionItem{..} <- - if expectedSig || expectedDocs - then do - rsp <- request SCompletionItemResolve item - case rsp ^. L.result of - Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) - Right x -> pure x - else pure item - when expectedSig $ - liftIO $ assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) - when expectedDocs $ - liftIO $ assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) - - -topLevelCompletionTests :: [TestTree] -topLevelCompletionTests = [ - completionTest - "variable" - ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] - (Position 0 8) - [("xxx", CiFunction, "xxx", True, True, Nothing) - ], - completionTest - "constructor" - ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] - (Position 0 8) - [("xxx", CiFunction, "xxx", True, True, Nothing) - ], - completionTest - "class method" - ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"] - (Position 0 8) - [("xxx", CiFunction, "xxx", True, True, Nothing)], - completionTest - "type" - ["bar :: Xz", "zzz = ()", "-- | haddock", "data Xzz = XzzCon"] - (Position 0 9) - [("Xzz", CiStruct, "Xzz", False, True, Nothing)], - completionTest - "class" - ["bar :: Xz", "zzz = ()", "-- | haddock", "class Xzz a"] - (Position 0 9) - [("Xzz", CiInterface, "Xzz", False, True, Nothing)], - completionTest - "records" - ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ] - (Position 1 19) - [("_personName", CiFunction, "_personName", False, True, Nothing), - ("_personAge", CiFunction, "_personAge", False, True, Nothing)], - completionTest - "recordsConstructor" - ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ] - (Position 1 19) - [("XyRecord", CiConstructor, "XyRecord", False, True, Nothing), - ("XyRecord", CiSnippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)] - ] - -localCompletionTests :: [TestTree] -localCompletionTests = [ - completionTest - "argument" - ["bar (Just abcdef) abcdefg = abcd"] - (Position 0 32) - [("abcdef", CiFunction, "abcdef", True, False, Nothing), - ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) - ], - completionTest - "let" - ["bar = let (Just abcdef) = undefined" - ," abcdefg = let abcd = undefined in undefined" - ," in abcd" - ] - (Position 2 15) - [("abcdef", CiFunction, "abcdef", True, False, Nothing), - ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) - ], - completionTest - "where" - ["bar = abcd" - ," where (Just abcdef) = undefined" - ," abcdefg = let abcd = undefined in undefined" - ] - (Position 0 10) - [("abcdef", CiFunction, "abcdef", True, False, Nothing), - ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) - ], - completionTest - "do/1" - ["bar = do" - ," Just abcdef <- undefined" - ," abcd" - ," abcdefg <- undefined" - ," pure ()" - ] - (Position 2 6) - [("abcdef", CiFunction, "abcdef", True, False, Nothing) - ], - completionTest - "do/2" - ["bar abcde = do" - ," Just [(abcdef,_)] <- undefined" - ," abcdefg <- undefined" - ," let abcdefgh = undefined" - ," (Just [abcdefghi]) = undefined" - ," abcd" - ," where" - ," abcdefghij = undefined" - ] - (Position 5 8) - [("abcde", CiFunction, "abcde", True, False, Nothing) - ,("abcdefghij", CiFunction, "abcdefghij", True, False, Nothing) - ,("abcdef", CiFunction, "abcdef", True, False, Nothing) - ,("abcdefg", CiFunction, "abcdefg", True, False, Nothing) - ,("abcdefgh", CiFunction, "abcdefgh", True, False, Nothing) - ,("abcdefghi", CiFunction, "abcdefghi", True, False, Nothing) - ], - completionTest - "type family" - ["{-# LANGUAGE DataKinds, TypeFamilies #-}" - ,"type family Bar a" - ,"a :: Ba" - ] - (Position 2 7) - [("Bar", CiStruct, "Bar", True, False, Nothing) - ], - completionTest - "class method" - [ - "class Test a where" - , " abcd :: a -> ()" - , " abcde :: a -> Int" - , "instance Test Int where" - , " abcd = abc" - ] - (Position 4 14) - [("abcd", CiFunction, "abcd", True, False, Nothing) - ,("abcde", CiFunction, "abcde", True, False, Nothing) - ], - testSessionWait "incomplete entries" $ do - let src a = "data Data = " <> a - doc <- createDoc "A.hs" "haskell" $ src "AAA" - void $ waitForTypecheck doc - let editA rhs = - changeDoc doc [TextDocumentContentChangeEvent - { _range=Nothing - , _rangeLength=Nothing - , _text=src rhs}] - - editA "AAAA" - void $ waitForTypecheck doc - editA "AAAAA" - void $ waitForTypecheck doc - - compls <- getCompletions doc (Position 0 15) - liftIO $ filter ("AAA" `T.isPrefixOf`) (mapMaybe _insertText compls) @?= ["AAAAA"] - pure () - ] - -nonLocalCompletionTests :: [TestTree] -nonLocalCompletionTests = - [ brokenForWinGhc $ completionTest - "variable" - ["module A where", "f = hea"] - (Position 1 7) - [("head", CiFunction, "head", True, True, Nothing)], - completionTest - "constructor" - ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"] - (Position 2 8) - [ ("True", CiConstructor, "True", True, True, Nothing) - ], - brokenForWinGhc $ completionTest - "type" - ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"] - (Position 2 8) - [ ("Bool", CiStruct, "Bool", True, True, Nothing) - ], - completionTest - "qualified" - ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] - (Position 2 15) - [ ("head", CiFunction, "head", True, True, Nothing) - ], - completionTest - "duplicate import" - ["module A where", "import Data.List", "import Data.List", "f = permu"] - (Position 3 9) - [ ("permutations", CiFunction, "permutations", False, False, Nothing) - ], - completionTest - "dont show hidden items" - [ "{-# LANGUAGE NoImplicitPrelude #-}", - "module A where", - "import Control.Monad hiding (join)", - "f = joi" - ] - (Position 3 6) - [], - testGroup "ordering" - [completionTest "qualified has priority" - ["module A where" - ,"import qualified Data.ByteString as BS" - ,"f = BS.read" - ] - (Position 2 10) - [("readFile", CiFunction, "readFile", True, True, Nothing)] - ], - -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls - completionTest - "do not show pragma completions" - [ "{-# LANGUAGE ", - "{module A where}", - "main = return ()" - ] - (Position 0 13) - [] - ] - where - brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC810, GHC90, GHC92, GHC94]) "Windows has strange things in scope for some reason" - -otherCompletionTests :: [TestTree] -otherCompletionTests = [ - completionTest - "keyword" - ["module A where", "f = newty"] - (Position 1 9) - [("newtype", CiKeyword, "", False, False, Nothing)], - completionTest - "type context" - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "f = f", - "g :: Intege" - ] - -- At this point the module parses but does not typecheck. - -- This should be sufficient to detect that we are in a - -- type context and only show the completion to the type. - (Position 3 11) - [("Integer", CiStruct, "Integer", True, True, Nothing)], - - testSession "duplicate record fields" $ do - void $ - createDoc "B.hs" "haskell" $ - T.unlines - [ "{-# LANGUAGE DuplicateRecordFields #-}", - "module B where", - "newtype Foo = Foo { member :: () }", - "newtype Bar = Bar { member :: () }" - ] - docA <- - createDoc "A.hs" "haskell" $ - T.unlines - [ "module A where", - "import B", - "memb" - ] - _ <- waitForDiagnostics - compls <- getCompletions docA $ Position 2 4 - let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"] - liftIO $ take 2 compls' @?= ["member"], - - testSessionWait "maxCompletions" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "a = Prelude." - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 3 13) - liftIO $ length compls @?= maxCompletions def - ] - -packageCompletionTests :: [TestTree] -packageCompletionTests = - [ testSession' "fromList" $ \dir -> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}" - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "a = fromList" - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 2 12) - let compls' = - [T.drop 1 $ T.dropEnd 3 d - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} - <- compls - , _label == "fromList" - ] - liftIO $ take 3 (sort compls') @?= - map ("Defined in "<>) ( - [ "'Data.List.NonEmpty" - , "'GHC.Exts" - ] ++ if ghcVersion >= GHC94 then [ "'GHC.IsList" ] else []) - - , testSessionWait "Map" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "a :: Map" - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 2 7) - let compls' = - [T.drop 1 $ T.dropEnd 3 d - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} - <- compls - , _label == "Map" - ] - liftIO $ take 3 (sort compls') @?= - map ("Defined in "<>) - [ "'Data.Map" - , "'Data.Map.Lazy" - , "'Data.Map.Strict" - ] - , testSessionWait "no duplicates" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "import GHC.Exts(fromList)", - "a = fromList" - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 3 13) - let duplicate = - filter - (\case - CompletionItem - { _insertText = Just "fromList" - , _documentation = - Just (CompletionDocMarkup (MarkupContent MkMarkdown d)) - } -> - "GHC.Exts" `T.isInfixOf` d - _ -> False - ) compls - liftIO $ length duplicate @?= 1 - - , testSessionWait "non-local before global" $ do - -- non local completions are more specific - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS_GHC -Wunused-binds #-}", - "module A () where", - "import GHC.Exts(fromList)", - "a = fromList" - ] - _ <- waitForDiagnostics - compls <- getCompletions doc (Position 3 13) - let compls' = - [_insertText - | CompletionItem {_label, _insertText} <- compls - , _label == "fromList" - ] - liftIO $ take 3 compls' @?= - map Just ["fromList"] - ] - -projectCompletionTests :: [TestTree] -projectCompletionTests = - [ testSession' "from hiedb" $ \dir-> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" - _ <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A (anidentifier) where", - "anidentifier = ()" - ] - _ <- waitForDiagnostics - -- Note that B does not import A - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "b = anidenti" - ] - compls <- getCompletions doc (Position 1 10) - let compls' = - [T.drop 1 $ T.dropEnd 3 d - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} - <- compls - , _label == "anidentifier" - ] - liftIO $ compls' @?= ["Defined in 'A"], - testSession' "auto complete project imports" $ \dir-> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}" - _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines - [ "module ALocalModule (anidentifier) where", - "anidentifier = ()" - ] - _ <- waitForDiagnostics - -- Note that B does not import A - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "import ALocal" - ] - compls <- getCompletions doc (Position 1 13) - let item = head $ filter ((== "ALocalModule") . (^. Lens.label)) compls - liftIO $ do - item ^. Lens.label @?= "ALocalModule", - testSession' "auto complete functions from qualified imports without alias" $ \dir-> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" - _ <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A (anidentifier) where", - "anidentifier = ()" - ] - _ <- waitForDiagnostics - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "import qualified A", - "A." - ] - compls <- getCompletions doc (Position 2 2) - let item = head compls - liftIO $ do - item ^. L.label @?= "anidentifier", - testSession' "auto complete functions from qualified imports with alias" $ \dir-> do - liftIO $ writeFile (dir "hie.yaml") - "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" - _ <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A (anidentifier) where", - "anidentifier = ()" - ] - _ <- waitForDiagnostics - doc <- createDoc "B.hs" "haskell" $ T.unlines - [ "module B where", - "import qualified A as Alias", - "foo = Alias." - ] - compls <- getCompletions doc (Position 2 12) - let item = head compls - liftIO $ do - item ^. L.label @?= "anidentifier" - ] - -completionDocTests :: [TestTree] -completionDocTests = - [ testSession "local define" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = ()" - , "bar = fo" - ] - let expected = "*Defined at line 2, column 1 in this module*\n" - test doc (Position 2 8) "foo" Nothing [expected] - , testSession "local empty doc" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = ()" - , "bar = fo" - ] - test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"] - , testSession "local single line doc without '\\n'" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "-- |docdoc" - , "foo = ()" - , "bar = fo" - ] - test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\n\n\ndocdoc\n"] - , testSession "local multi line doc with '\\n'" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "-- | abcabc" - , "--" - , "foo = ()" - , "bar = fo" - ] - test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n\n\nabcabc\n"] - , testSession "local multi line doc without '\\n'" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "-- | abcabc" - , "--" - , "--def" - , "foo = ()" - , "bar = fo" - ] - test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n\n\nabcabc \n\ndef\n"] - , testSession "extern empty doc" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = od" - ] - let expected = "*Imported from 'Prelude'*\n" - test doc (Position 1 8) "odd" (Just $ T.length expected) [expected] - , brokenForMacGhc9 $ brokenForWinGhc9 $ testSession "extern single line doc without '\\n'" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = no" - ] - let expected = "*Imported from 'Prelude'*\n* * *\n\n\nBoolean \"not\"\n" - test doc (Position 1 8) "not" (Just $ T.length expected) [expected] - , brokenForMacGhc9 $ brokenForWinGhc9 $ testSession "extern mulit line doc" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = i" - ] - let expected = "*Imported from 'Prelude'*\n* * *\n\n\nIdentity function. \n```haskell\nid x = x\n```\n" - test doc (Position 1 7) "id" (Just $ T.length expected) [expected] - , testSession "extern defined doc" $ do - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "module A where" - , "foo = i" - ] - let expected = "*Imported from 'Prelude'*\n" - test doc (Position 1 7) "id" (Just $ T.length expected) [expected] - ] - where - brokenForGhc9 = knownBrokenFor (BrokenForGHC [GHC90, GHC92, GHC94]) "Completion doc doesn't support ghc9" - brokenForWinGhc9 = knownBrokenFor (BrokenSpecific Windows [GHC90, GHC92]) "Extern doc doesn't support Windows for ghc9.2" - -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903 - brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC90, GHC92, GHC94]) "Extern doc doesn't support MacOS for ghc9" - test doc pos label mn expected = do - _ <- waitForDiagnostics - compls <- getCompletions doc pos - rcompls <- forM compls $ \item -> do - rsp <- request SCompletionItemResolve item - case rsp ^. L.result of - Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) - Right x -> pure x - let compls' = [ - -- We ignore doc uris since it points to the local path which determined by specific machines - case mn of - Nothing -> txt - Just n -> T.take n txt - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown txt)), ..} <- rcompls - , _label == label - ] - liftIO $ compls' @?= expected - -highlightTests :: TestTree -highlightTests = testGroup "highlight" - [ testSessionWait "value" $ do - doc <- createDoc "A.hs" "haskell" source - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 3 2) - liftIO $ highlights @?= List - [ DocumentHighlight (R 2 0 2 3) (Just HkRead) - , DocumentHighlight (R 3 0 3 3) (Just HkWrite) - , DocumentHighlight (R 4 6 4 9) (Just HkRead) - , DocumentHighlight (R 5 22 5 25) (Just HkRead) - ] - , testSessionWait "type" $ do - doc <- createDoc "A.hs" "haskell" source - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 2 8) - liftIO $ highlights @?= List - [ DocumentHighlight (R 2 7 2 10) (Just HkRead) - , DocumentHighlight (R 3 11 3 14) (Just HkRead) - ] - , testSessionWait "local" $ do - doc <- createDoc "A.hs" "haskell" source - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 6 5) - liftIO $ highlights @?= List - [ DocumentHighlight (R 6 4 6 7) (Just HkWrite) - , DocumentHighlight (R 6 10 6 13) (Just HkRead) - , DocumentHighlight (R 7 12 7 15) (Just HkRead) - ] - , knownBrokenForGhcVersions [GHC90, GHC92, GHC94] "Ghc9 highlights the constructor and not just this field" $ - testSessionWait "record" $ do - doc <- createDoc "A.hs" "haskell" recsource - _ <- waitForDiagnostics - highlights <- getHighlights doc (Position 4 15) - liftIO $ highlights @?= List - -- Span is just the .. on 8.10, but Rec{..} before - [ if ghcVersion >= GHC810 - then DocumentHighlight (R 4 8 4 10) (Just HkWrite) - else DocumentHighlight (R 4 4 4 11) (Just HkWrite) - , DocumentHighlight (R 4 14 4 20) (Just HkRead) - ] - highlights <- getHighlights doc (Position 3 17) - liftIO $ highlights @?= List - [ DocumentHighlight (R 3 17 3 23) (Just HkWrite) - -- Span is just the .. on 8.10, but Rec{..} before - , if ghcVersion >= GHC810 - then DocumentHighlight (R 4 8 4 10) (Just HkRead) - else DocumentHighlight (R 4 4 4 11) (Just HkRead) - ] - ] - where - source = T.unlines - ["{-# OPTIONS_GHC -Wunused-binds #-}" - ,"module Highlight () where" - ,"foo :: Int" - ,"foo = 3 :: Int" - ,"bar = foo" - ," where baz = let x = foo in x" - ,"baz arg = arg + x" - ," where x = arg" - ] - recsource = T.unlines - ["{-# LANGUAGE RecordWildCards #-}" - ,"{-# OPTIONS_GHC -Wunused-binds #-}" - ,"module Highlight () where" - ,"data Rec = Rec { field1 :: Int, field2 :: Char }" - ,"foo Rec{..} = field2 + field1" - ] - -outlineTests :: TestTree -outlineTests = testGroup - "outline" - [ testSessionWait "type class" $ do - let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ moduleSymbol - "A" - (R 0 7 0 8) - [ classSymbol "A a" - (R 1 0 1 30) - [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)] - ] - ] - , testSessionWait "type class instance " $ do - let source = T.unlines ["class A a where", "instance A () where"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ classSymbol "A a" (R 0 0 0 15) [] - , docSymbol "A ()" SkInterface (R 1 0 1 19) - ] - , testSessionWait "type family" $ do - let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkFunction (R 1 0 1 13)] - , testSessionWait "type family instance " $ do - let source = T.unlines - [ "{-# language TypeFamilies #-}" - , "type family A a" - , "type instance A () = ()" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolD "A a" "type family" SkFunction (R 1 0 1 15) - , docSymbol "A ()" SkInterface (R 2 0 2 23) - ] - , testSessionWait "data family" $ do - let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkFunction (R 1 0 1 11)] - , testSessionWait "data family instance " $ do - let source = T.unlines - [ "{-# language TypeFamilies #-}" - , "data family A a" - , "data instance A () = A ()" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolD "A a" "data family" SkFunction (R 1 0 1 11) - , docSymbol "A ()" SkInterface (R 2 0 2 25) - ] - , testSessionWait "constant" $ do - let source = T.unlines ["a = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "a" SkFunction (R 0 0 0 6)] - , testSessionWait "pattern" $ do - let source = T.unlines ["Just foo = Just 21"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "Just foo" SkFunction (R 0 0 0 18)] - , testSessionWait "pattern with type signature" $ do - let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "a :: ()" SkFunction (R 1 0 1 12)] - , testSessionWait "function" $ do - let source = T.unlines ["a _x = ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 9)] - , testSessionWait "type synonym" $ do - let source = T.unlines ["type A = Bool"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)] - , testSessionWait "datatype" $ do - let source = T.unlines ["data A = C"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolWithChildren "A" - SkStruct - (R 0 0 0 10) - [docSymbol "C" SkConstructor (R 0 9 0 10)] - ] - , testSessionWait "record fields" $ do - let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13) - [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10) - [ docSymbol "x" SkField (R 1 2 1 3) - , docSymbol "y" SkField (R 2 4 2 5) - ] - ] - ] - , testSessionWait "import" $ do - let source = T.unlines ["import Data.Maybe ()"] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbolWithChildren "imports" - SkModule - (R 0 0 0 20) - [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 20) - ] - ] - , testSessionWait "multiple import" $ do - let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbolWithChildren "imports" - SkModule - (R 1 0 3 27) - [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 20) - , docSymbol "import Control.Exception" SkModule (R 3 0 3 27) - ] - ] - , testSessionWait "foreign import" $ do - let source = T.unlines - [ "{-# language ForeignFunctionInterface #-}" - , "foreign import ccall \"a\" a :: Int" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)] - , testSessionWait "foreign export" $ do - let source = T.unlines - [ "{-# language ForeignFunctionInterface #-}" - , "foreign export ccall odd :: Int -> Bool" - ] - docId <- createDoc "A.hs" "haskell" source - symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)] - ] - where - docSymbol name kind loc = - DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing - docSymbol' name kind loc selectionLoc = - DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing - docSymbolD name detail kind loc = - DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing - docSymbolWithChildren name kind loc cc = - DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just $ List cc) - docSymbolWithChildren' name kind loc selectionLoc cc = - DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just $ List cc) - moduleSymbol name loc cc = DocumentSymbol name - Nothing - SkFile - Nothing - Nothing - (R 0 0 maxBound 0) - loc - (Just $ List cc) - classSymbol name loc cc = DocumentSymbol name - (Just "class") - SkInterface - Nothing - Nothing - loc - loc - (Just $ List cc) - -pattern R :: UInt -> UInt -> UInt -> UInt -> Range -pattern R x y x' y' = Range (Position x y) (Position x' y') - -xfail :: TestTree -> String -> TestTree -xfail = flip expectFailBecause - -ignoreInWindowsBecause :: String -> TestTree -> TestTree -ignoreInWindowsBecause = ignoreFor (BrokenForOS Windows) - -ignoreInWindowsForGHC810 :: TestTree -> TestTree -ignoreInWindowsForGHC810 = - ignoreFor (BrokenSpecific Windows [GHC810]) "tests are unreliable in windows for ghc 8.10" - -ignoreForGHC92Plus :: String -> TestTree -> TestTree -ignoreForGHC92Plus = ignoreFor (BrokenForGHC [GHC92, GHC94]) - -knownBrokenForGhcVersions :: [GhcVersion] -> String -> TestTree -> TestTree -knownBrokenForGhcVersions ghcVers = knownBrokenFor (BrokenForGHC ghcVers) - -data BrokenOS = Linux | MacOS | Windows deriving (Show) - -data IssueSolution = Broken | Ignore deriving (Show) - -data BrokenTarget = - BrokenSpecific BrokenOS [GhcVersion] - -- ^Broken for `BrokenOS` with `GhcVersion` - | BrokenForOS BrokenOS - -- ^Broken for `BrokenOS` - | BrokenForGHC [GhcVersion] - -- ^Broken for `GhcVersion` - deriving (Show) - --- | Ignore test for specific os and ghc with reason. -ignoreFor :: BrokenTarget -> String -> TestTree -> TestTree -ignoreFor = knownIssueFor Ignore - --- | Known broken for specific os and ghc with reason. -knownBrokenFor :: BrokenTarget -> String -> TestTree -> TestTree -knownBrokenFor = knownIssueFor Broken - --- | Deal with `IssueSolution` for specific OS and GHC. -knownIssueFor :: IssueSolution -> BrokenTarget -> String -> TestTree -> TestTree -knownIssueFor solution = go . \case - BrokenSpecific bos vers -> isTargetOS bos && isTargetGhc vers - BrokenForOS bos -> isTargetOS bos - BrokenForGHC vers -> isTargetGhc vers - where - isTargetOS = \case - Windows -> isWindows - MacOS -> isMac - Linux -> not isWindows && not isMac - - isTargetGhc = elem ghcVersion - - go True = case solution of - Broken -> expectFailBecause - Ignore -> ignoreTestBecause - go False = \_ -> id - -data Expect - = ExpectRange Range -- Both gotoDef and hover should report this range - | ExpectLocation Location --- | ExpectDefRange Range -- Only gotoDef should report this range - | ExpectHoverRange Range -- Only hover should report this range - | ExpectHoverText [T.Text] -- the hover message must contain these snippets - | ExpectHoverTextRegex T.Text -- the hover message must match this pattern - | ExpectExternFail -- definition lookup in other file expected to fail - | ExpectNoDefinitions - | ExpectNoHover --- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples - deriving Eq - -mkR :: UInt -> UInt -> UInt -> UInt -> Expect -mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn - -mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect -mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn - -haddockTests :: TestTree -haddockTests - = testGroup "haddock" - [ testCase "Num" $ checkHaddock - (unlines - [ "However, '(+)' and '(*)' are" - , "customarily expected to define a ring and have the following properties:" - , "" - , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@" - , "[__Commutativity of (+)__]: @x + y@ = @y + x@" - , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@" - ] - ) - (unlines - [ "" - , "" - , "However, `(+)` and `(*)` are" - , "customarily expected to define a ring and have the following properties: " - , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`" - , "+ ****Commutativity of (+)****: `x + y` = `y + x`" - , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`" - ] - ) - , testCase "unsafePerformIO" $ checkHaddock - (unlines - [ "may require" - , "different precautions:" - , "" - , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" - , " that calls 'unsafePerformIO'. If the call is inlined," - , " the I\\/O may be performed more than once." - , "" - , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - (unlines - [ "" - , "" - , "may require" - , "different precautions: " - , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " - , " that calls `unsafePerformIO` . If the call is inlined," - , " the I/O may be performed more than once." - , "" - , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - , testCase "ordered list" $ checkHaddock - (unlines - [ "may require" - , "different precautions:" - , "" - , " 1. Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@" - , " that calls 'unsafePerformIO'. If the call is inlined," - , " the I\\/O may be performed more than once." - , "" - , " 2. Use the compiler flag @-fno-cse@ to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - (unlines - [ "" - , "" - , "may require" - , "different precautions: " - , "1. Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` " - , " that calls `unsafePerformIO` . If the call is inlined," - , " the I/O may be performed more than once." - , "" - , "2. Use the compiler flag `-fno-cse` to prevent common sub-expression" - , " elimination being performed on the module." - , "" - ] - ) - ] - where - checkHaddock s txt = spanDocToMarkdownForTest s @?= txt - -cradleTests :: TestTree -cradleTests = testGroup "cradle" - [testGroup "dependencies" [sessionDepsArePickedUp] - ,testGroup "ignore-fatal" [ignoreFatalWarning] - ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] - ,testGroup "multi" [simpleMultiTest, simpleMultiTest2, simpleMultiTest3, simpleMultiDefTest] - ,testGroup "sub-directory" [simpleSubDirectoryTest] - ] - -loadCradleOnlyonce :: TestTree -loadCradleOnlyonce = testGroup "load cradle only once" - [ testSession' "implicit" implicit - , testSession' "direct" direct - ] - where - direct dir = do - liftIO $ writeFileUTF8 (dir "hie.yaml") - "cradle: {direct: {arguments: []}}" - test dir - implicit dir = test dir - test _dir = do - doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo" - msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) - liftIO $ length msgs @?= 1 - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"] - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) - liftIO $ length msgs @?= 0 - _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar" - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) - liftIO $ length msgs @?= 0 - -retryFailedCradle :: TestTree -retryFailedCradle = testSession' "retry failed" $ \dir -> do - -- The false cradle always fails - let hieContents = "cradle: {bios: {shell: \"false\"}}" - hiePath = dir "hie.yaml" - liftIO $ writeFile hiePath hieContents - let aPath = dir "A.hs" - doc <- createDoc aPath "haskell" "main = return ()" - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc - liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess - - -- Fix the cradle and typecheck again - let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}" - liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri $ dir "hie.yaml") FcChanged ] - - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc - liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess - - -dependentFileTest :: TestTree -dependentFileTest = testGroup "addDependentFile" - [testGroup "file-changed" [testSession' "test" test] - ] - where - test dir = do - -- If the file contains B then no type error - -- otherwise type error - let depFilePath = dir "dep-file.txt" - liftIO $ writeFile depFilePath "A" - let fooContent = T.unlines - [ "{-# LANGUAGE TemplateHaskell #-}" - , "module Foo where" - , "import Language.Haskell.TH.Syntax" - , "foo :: Int" - , "foo = 1 + $(do" - , " qAddDependentFile \"dep-file.txt\"" - , " f <- qRunIO (readFile \"dep-file.txt\")" - , " if f == \"B\" then [| 1 |] else lift f)" - ] - let bazContent = T.unlines ["module Baz where", "import Foo ()"] - _ <- createDoc "Foo.hs" "haskell" fooContent - doc <- createDoc "Baz.hs" "haskell" bazContent - expectDiagnostics $ - if ghcVersion >= GHC90 - -- String vs [Char] causes this change in error message - then [("Foo.hs", [(DsError, if ghcVersion >= GHC92 then (4,11) else (4, 6), "Couldn't match type")])] - else [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])] - -- Now modify the dependent file - liftIO $ writeFile depFilePath "B" - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri "dep-file.txt") FcChanged ] - - -- Modifying Baz will now trigger Foo to be rebuilt as well - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 2 0) (Position 2 6)) - , _rangeLength = Nothing - , _text = "f = ()" - } - changeDoc doc [change] - expectDiagnostics [("Foo.hs", [])] - - -cradleLoadedMessage :: Session FromServerMessage -cradleLoadedMessage = satisfy $ \case - FromServerMess (SCustomMethod m) (NotMess _) -> m == cradleLoadedMethod - _ -> False - -cradleLoadedMethod :: T.Text -cradleLoadedMethod = "ghcide/cradle/loaded" - -ignoreFatalWarning :: TestTree -ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do - let srcPath = dir "IgnoreFatal.hs" - src <- liftIO $ readFileUtf8 srcPath - _ <- createDoc srcPath "haskell" src - expectNoMoreDiagnostics 5 - -simpleSubDirectoryTest :: TestTree -simpleSubDirectoryTest = - testCase "simple-subdirectory" $ runWithExtraFiles "cabal-exe" $ \dir -> do - let mainPath = dir "a/src/Main.hs" - mainSource <- liftIO $ readFileUtf8 mainPath - _mdoc <- createDoc mainPath "haskell" mainSource - expectDiagnosticsWithTags - [("a/src/Main.hs", [(DsWarning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded - ] - expectNoMoreDiagnostics 0.5 - -simpleMultiTest :: TestTree -simpleMultiTest = testCase "simple-multi-test" $ withLongTimeout $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - adoc <- openDoc aPath "haskell" - bdoc <- openDoc bPath "haskell" - WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" adoc - liftIO $ assertBool "A should typecheck" ideResultSuccess - 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 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - --- Like simpleMultiTest but open the files in the other order -simpleMultiTest2 :: TestTree -simpleMultiTest2 = testCase "simple-multi-test2" $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - bdoc <- openDoc bPath "haskell" - WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc - TextDocumentIdentifier auri <- openDoc aPath "haskell" - skipManyTill anyMessage $ isReferenceReady aPath - locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL auri 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - --- Now with 3 components -simpleMultiTest3 :: TestTree -simpleMultiTest3 = - testCase "simple-multi-test3" $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - cPath = dir "c/C.hs" - bdoc <- openDoc bPath "haskell" - WaitForIdeRuleResult {} <- waitForAction "TypeCheck" bdoc - TextDocumentIdentifier auri <- openDoc aPath "haskell" - skipManyTill anyMessage $ isReferenceReady aPath - cdoc <- openDoc cPath "haskell" - WaitForIdeRuleResult {} <- waitForAction "TypeCheck" cdoc - locs <- getDefinitions cdoc (Position 2 7) - let fooL = mkL auri 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - --- Like simpleMultiTest but open the files in component 'a' in a separate session -simpleMultiDefTest :: TestTree -simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do - let aPath = dir "a/A.hs" - bPath = dir "b/B.hs" - adoc <- liftIO $ runInDir dir $ do - aSource <- liftIO $ readFileUtf8 aPath - adoc <- createDoc aPath "haskell" aSource - skipManyTill anyMessage $ isReferenceReady aPath - closeDoc adoc - pure adoc - bSource <- liftIO $ readFileUtf8 bPath - bdoc <- createDoc bPath "haskell" bSource - locs <- getDefinitions bdoc (Position 2 7) - let fooL = mkL (adoc ^. L.uri) 2 0 2 3 - checkDefs locs (pure [fooL]) - expectNoMoreDiagnostics 0.5 - -ifaceTests :: TestTree -ifaceTests = testGroup "Interface loading tests" - [ -- https://github.com/haskell/ghcide/pull/645/ - ifaceErrorTest - , ifaceErrorTest2 - , ifaceErrorTest3 - , ifaceTHTest - ] - -bootTests :: TestTree -bootTests = testGroup "boot" - [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do - let cPath = dir "C.hs" - cSource <- liftIO $ readFileUtf8 cPath - -- Dirty the cache - liftIO $ runInDir dir $ do - cDoc <- createDoc cPath "haskell" cSource - -- We send a hover request then wait for either the hover response or - -- `ghcide/reference/ready` notification. - -- Once we receive one of the above, we wait for the other that we - -- haven't received yet. - -- If we don't wait for the `ready` notification it is possible - -- that the `getDefinitions` request/response in the outer ghcide - -- session will find no definitions. - let hoverParams = HoverParams cDoc (Position 4 3) Nothing - hoverRequestId <- sendRequest STextDocumentHover hoverParams - let parseReadyMessage = isReferenceReady cPath - let parseHoverResponse = responseForId STextDocumentHover hoverRequestId - hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage)) - _ <- skipManyTill anyMessage $ - case hoverResponseOrReadyMessage of - Left _ -> void parseReadyMessage - Right _ -> void parseHoverResponse - closeDoc cDoc - cdoc <- createDoc cPath "haskell" cSource - locs <- getDefinitions cdoc (Position 7 4) - let floc = mkR 9 0 9 1 - checkDefs locs (pure [floc]) - , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do - _ <- openDoc (dir "A.hs") "haskell" - expectNoMoreDiagnostics 2 - ] - --- | test that TH reevaluates across interfaces -ifaceTHTest :: TestTree -ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do - let aPath = dir "THA.hs" - bPath = dir "THB.hs" - cPath = dir "THC.hs" - - aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: () - _bSource <- liftIO $ readFileUtf8 bPath -- a :: () - cSource <- liftIO $ readFileUtf8 cPath -- c = a :: () - - cdoc <- createDoc cPath "haskell" cSource - - -- Change [TH]a from () to Bool - liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"]) - - -- Check that the change propagates to C - changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing cSource] - expectDiagnostics - [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) - ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] - closeDoc cdoc - -ifaceErrorTest :: TestTree -ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \dir -> do - configureCheckProject True - let bPath = dir "B.hs" - pPath = dir "P.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - - bdoc <- createDoc bPath "haskell" bSource - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So what we know P has been loaded - - -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] - -- save so that we can that the error propagates to A - sendNotification STextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing) - - - -- Check that the error propagates to A - expectDiagnostics - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])] - - -- Check that we wrote the interfaces for B when we saved - hidir <- getInterfaceFilesDir bdoc - hi_exists <- liftIO $ doesFileExist $ hidir "B.hi" - liftIO $ assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists - - pdoc <- openDoc pPath "haskell" - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")]) - ] - changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ] - -- Now in P we have - -- bar = x :: Int - -- foo = y :: Bool - -- HOWEVER, in A... - -- x = y :: Int - -- This is clearly inconsistent, and the expected outcome a bit surprising: - -- - The diagnostic for A has already been received. Ghcide does not repeat diagnostics - -- - P is being typechecked with the last successful artifacts for A. - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")]) - ,("P.hs", [(DsWarning,(6,0), "Top-level binding")]) - ] - expectNoMoreDiagnostics 2 - -ifaceErrorTest2 :: TestTree -ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir "B.hs" - pPath = dir "P.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - - bdoc <- createDoc bPath "haskell" bSource - pdoc <- createDoc pPath "haskell" pSource - expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded - - -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] - - -- Add a new definition to P - changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ] - -- Now in P we have - -- bar = x :: Int - -- foo = y :: Bool - -- HOWEVER, in A... - -- x = y :: Int - expectDiagnostics - -- As in the other test, P is being typechecked with the last successful artifacts for A - -- (ot thanks to -fdeferred-type-errors) - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ,("P.hs", [(DsWarning, (4, 0), "Top-level binding")]) - ,("P.hs", [(DsWarning, (6, 0), "Top-level binding")]) - ] - - expectNoMoreDiagnostics 2 - -ifaceErrorTest3 :: TestTree -ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir "B.hs" - pPath = dir "P.hs" - - bSource <- liftIO $ readFileUtf8 bPath -- y :: Int - pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int - - bdoc <- createDoc bPath "haskell" bSource - - -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] - - -- P should not typecheck, as there are no last valid artifacts for A - _pdoc <- createDoc pPath "haskell" pSource - - -- In this example the interface file for A should not exist (modulo the cache folder) - -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors - expectDiagnostics - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ,("P.hs", [(DsWarning,(4,0), "Top-level binding")]) - ] - expectNoMoreDiagnostics 2 - -sessionDepsArePickedUp :: TestTree -sessionDepsArePickedUp = testSession' - "session-deps-are-picked-up" - $ \dir -> do - liftIO $ - writeFileUTF8 - (dir "hie.yaml") - "cradle: {direct: {arguments: []}}" - -- Open without OverloadedStrings and expect an error. - doc <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics $ - if ghcVersion >= GHC90 - -- String vs [Char] causes this change in error message - then [("Foo.hs", [(DsError, (3, 6), "Couldn't match type")])] - else [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])] - -- Update hie.yaml to enable OverloadedStrings. - liftIO $ - writeFileUTF8 - (dir "hie.yaml") - "cradle: {direct: {arguments: [-XOverloadedStrings]}}" - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri $ dir "hie.yaml") FcChanged ] - -- Send change event. - let change = - TextDocumentContentChangeEvent - { _range = Just (Range (Position 4 0) (Position 4 0)), - _rangeLength = Nothing, - _text = "\n" - } - changeDoc doc [change] - -- Now no errors. - expectDiagnostics [("Foo.hs", [])] - where - fooContent = - T.unlines - [ "module Foo where", - "import Data.Text", - "foo :: Text", - "foo = \"hello\"" - ] - --- A test to ensure that the command line ghcide workflow stays working -nonLspCommandLine :: TestTree -nonLspCommandLine = testGroup "ghcide command line" - [ testCase "works" $ withTempDir $ \dir -> do - ghcide <- locateGhcideExecutable - copyTestDataFiles dir "multi" - let cmd = (proc ghcide ["a/A.hs"]){cwd = Just dir} - - setEnv "HOME" "/homeless-shelter" False - - (ec, _, _) <- readCreateProcessWithExitCode cmd "" - - ec @?= ExitSuccess - ] - --- | checks if we use InitializeParams.rootUri for loading session -rootUriTests :: TestTree -rootUriTests = testCase "use rootUri" . runTest "dirA" "dirB" $ \dir -> do - let bPath = dir "dirB/Foo.hs" - liftIO $ copyTestDataFiles dir "rootUri" - bSource <- liftIO $ readFileUtf8 bPath - _ <- createDoc "Foo.hs" "haskell" bSource - expectNoMoreDiagnostics 0.5 - where - -- similar to run' except we can configure where to start ghcide and session - runTest :: FilePath -> FilePath -> (FilePath -> Session ()) -> IO () - runTest dir1 dir2 s = withTempDir $ \dir -> runInDir' dir dir1 dir2 [] (s dir) - --- | Test if ghcide asynchronously handles Commands and user Requests -asyncTests :: TestTree -asyncTests = testGroup "async" - [ - testSession "command" $ do - -- Execute a command that will block forever - let req = ExecuteCommandParams Nothing blockCommandId Nothing - void $ sendRequest SWorkspaceExecuteCommand req - -- Load a file and check for code actions. Will only work if the command is run asynchronously - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS -Wmissing-signatures #-}" - , "foo = id" - ] - void waitForDiagnostics - codeLenses <- getCodeLenses doc - liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? - [ "foo :: a -> a" ] - , testSession "request" $ do - -- Execute a custom request that will block for 1000 seconds - void $ sendRequest (SCustomMethod "test") $ toJSON $ BlockSeconds 1000 - -- Load a file and check for code actions. Will only work if the request is run asynchronously - doc <- createDoc "A.hs" "haskell" $ T.unlines - [ "{-# OPTIONS -Wmissing-signatures #-}" - , "foo = id" - ] - void waitForDiagnostics - codeLenses <- getCodeLenses doc - liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? - [ "foo :: a -> a" ] - ] - - -clientSettingsTest :: TestTree -clientSettingsTest = testGroup "client settings handling" - [ testSession "ghcide restarts shake session on config changes" $ do - void $ skipManyTill anyMessage $ message SClientRegisterCapability - void $ createDoc "A.hs" "haskell" "module A where" - waitForProgressDone - sendNotification SWorkspaceDidChangeConfiguration - (DidChangeConfigurationParams (toJSON (mempty :: A.Object))) - skipManyTill anyMessage restartingBuildSession - - ] - where - restartingBuildSession :: Session () - restartingBuildSession = do - FromServerMess SWindowLogMessage NotificationMessage{_params = LogMessageParams{..}} <- loggingNotification - guard $ "Restarting build session" `T.isInfixOf` _message - -referenceTests :: TestTree -referenceTests = testGroup "references" - [ testGroup "can get references to FOIs" - [ referenceTest "can get references to symbols" - ("References.hs", 4, 7) - YesIncludeDeclaration - [ ("References.hs", 4, 6) - , ("References.hs", 6, 0) - , ("References.hs", 6, 14) - , ("References.hs", 9, 7) - , ("References.hs", 10, 11) - ] - - , referenceTest "can get references to data constructor" - ("References.hs", 13, 2) - YesIncludeDeclaration - [ ("References.hs", 13, 2) - , ("References.hs", 16, 14) - , ("References.hs", 19, 21) - ] - - , referenceTest "getting references works in the other module" - ("OtherModule.hs", 6, 0) - YesIncludeDeclaration - [ ("OtherModule.hs", 6, 0) - , ("OtherModule.hs", 8, 16) - ] - - , referenceTest "getting references works in the Main module" - ("Main.hs", 9, 0) - YesIncludeDeclaration - [ ("Main.hs", 9, 0) - , ("Main.hs", 10, 4) - ] - - , referenceTest "getting references to main works" - ("Main.hs", 5, 0) - YesIncludeDeclaration - [ ("Main.hs", 4, 0) - , ("Main.hs", 5, 0) - ] - - , referenceTest "can get type references" - ("Main.hs", 9, 9) - YesIncludeDeclaration - [ ("Main.hs", 9, 0) - , ("Main.hs", 9, 9) - , ("Main.hs", 10, 0) - ] - - , expectFailBecause "references provider does not respect includeDeclaration parameter" $ - referenceTest "works when we ask to exclude declarations" - ("References.hs", 4, 7) - NoExcludeDeclaration - [ ("References.hs", 6, 0) - , ("References.hs", 6, 14) - , ("References.hs", 9, 7) - , ("References.hs", 10, 11) - ] - - , referenceTest "INCORRECTLY returns declarations when we ask to exclude them" - ("References.hs", 4, 7) - NoExcludeDeclaration - [ ("References.hs", 4, 6) - , ("References.hs", 6, 0) - , ("References.hs", 6, 14) - , ("References.hs", 9, 7) - , ("References.hs", 10, 11) - ] - ] - - , testGroup "can get references to non FOIs" - [ referenceTest "can get references to symbol defined in a module we import" - ("References.hs", 22, 4) - YesIncludeDeclaration - [ ("References.hs", 22, 4) - , ("OtherModule.hs", 0, 20) - , ("OtherModule.hs", 4, 0) - ] - - , referenceTest "can get references in modules that import us to symbols we define" - ("OtherModule.hs", 4, 0) - YesIncludeDeclaration - [ ("References.hs", 22, 4) - , ("OtherModule.hs", 0, 20) - , ("OtherModule.hs", 4, 0) - ] - - , referenceTest "can get references to symbol defined in a module we import transitively" - ("References.hs", 24, 4) - YesIncludeDeclaration - [ ("References.hs", 24, 4) - , ("OtherModule.hs", 0, 48) - , ("OtherOtherModule.hs", 2, 0) - ] - - , referenceTest "can get references in modules that import us transitively to symbols we define" - ("OtherOtherModule.hs", 2, 0) - YesIncludeDeclaration - [ ("References.hs", 24, 4) - , ("OtherModule.hs", 0, 48) - , ("OtherOtherModule.hs", 2, 0) - ] - - , referenceTest "can get type references to other modules" - ("Main.hs", 12, 10) - YesIncludeDeclaration - [ ("Main.hs", 12, 7) - , ("Main.hs", 13, 0) - , ("References.hs", 12, 5) - , ("References.hs", 16, 0) - ] - ] - ] - --- | When we ask for all references to symbol "foo", should the declaration "foo --- = 2" be among the references returned? -data IncludeDeclaration = - YesIncludeDeclaration - | NoExcludeDeclaration - -getReferences' :: SymbolLocation -> IncludeDeclaration -> Session (List Location) -getReferences' (file, l, c) includeDeclaration = do - doc <- openDoc file "haskell" - getReferences doc (Position l c) $ toBool includeDeclaration - where toBool YesIncludeDeclaration = True - toBool NoExcludeDeclaration = False - -referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree -referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "references" name $ \dir -> do - -- needed to build whole project indexing - configureCheckProject True - let docs = map (dir ) $ delete thisDoc $ nubOrd docs' - -- Initial Index - docid <- openDoc thisDoc "haskell" - let - loop :: [FilePath] -> Session () - loop [] = pure () - loop docs = do - doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) - loop (delete doc docs) - loop docs - f dir - closeDoc docid - --- | Given a location, lookup the symbol and all references to it. Make sure --- they are the ones we expect. -referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree -referenceTest name loc includeDeclaration expected = - referenceTestSession name (fst3 loc) docs $ \dir -> do - List actual <- getReferences' loc includeDeclaration - liftIO $ actual `expectSameLocations` map (first3 (dir )) expected - where - docs = map fst3 expected - -type SymbolLocation = (FilePath, UInt, UInt) - -expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion -expectSameLocations actual expected = do - let actual' = - Set.map (\location -> (location ^. L.uri - , location ^. L.range . L.start . L.line . to fromIntegral - , location ^. L.range . L.start . L.character . to fromIntegral)) - $ Set.fromList actual - expected' <- Set.fromList <$> - (forM expected $ \(file, l, c) -> do - fp <- canonicalizePath file - return (filePathToUri fp, l, c)) - actual' @?= expected' - ----------------------------------------------------------------------- --- Utils ----------------------------------------------------------------------- - -testSession :: String -> Session () -> TestTree -testSession name = testCase name . run - -testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree -testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix - -testSession' :: String -> (FilePath -> Session ()) -> TestTree -testSession' name = testCase name . run' - -testSessionWait :: HasCallStack => String -> Session () -> TestTree -testSessionWait name = testSession name . - -- Check that any diagnostics produced were already consumed by the test case. - -- - -- If in future we add test cases where we don't care about checking the diagnostics, - -- this could move elsewhere. - -- - -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear. - ( >> expectNoMoreDiagnostics 0.5) - -mkRange :: UInt -> UInt -> UInt -> UInt -> Range -mkRange a b c d = Range (Position a b) (Position c d) - -run :: Session a -> IO a -run s = run' (const s) - -runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a -runWithExtraFiles prefix s = withTempDir $ \dir -> do - copyTestDataFiles dir prefix - runInDir dir (s dir) - -copyTestDataFiles :: FilePath -> FilePath -> IO () -copyTestDataFiles dir prefix = do - -- Copy all the test data files to the temporary workspace - testDataFiles <- getDirectoryFilesIO ("test/data" prefix) ["//*"] - for_ testDataFiles $ \f -> do - createDirectoryIfMissing True $ dir takeDirectory f - copyFile ("test/data" prefix f) (dir f) - -run' :: (FilePath -> Session a) -> IO a -run' s = withTempDir $ \dir -> runInDir dir (s dir) - -runInDir :: FilePath -> Session a -> IO a -runInDir dir = runInDir' dir "." "." [] - -withLongTimeout :: IO a -> IO a -withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") - --- | Takes a directory as well as relative paths to where we should launch the executable as well as the session root. -runInDir' :: FilePath -> FilePath -> FilePath -> [String] -> Session a -> IO a -runInDir' = runInDir'' lspTestCaps - -runInDir'' - :: ClientCapabilities - -> FilePath - -> FilePath - -> FilePath - -> [String] - -> Session b - -> IO b -runInDir'' lspCaps dir startExeIn startSessionIn extraOptions s = do - - ghcideExe <- locateGhcideExecutable - let startDir = dir startExeIn - let projDir = dir startSessionIn - - createDirectoryIfMissing True startDir - createDirectoryIfMissing True projDir - -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56 - -- since the package import test creates "Data/List.hs", which otherwise has no physical home - createDirectoryIfMissing True $ projDir ++ "/Data" - - shakeProfiling <- getEnv "SHAKE_PROFILING" - let cmd = unwords $ - [ghcideExe, "--lsp", "--test", "--verify-core-file", "--verbose", "-j2", "--cwd", startDir - ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling] - ] ++ extraOptions - -- HIE calls getXgdDirectory which assumes that HOME is set. - -- Only sets HOME if it wasn't already set. - setEnv "HOME" "/homeless-shelter" False - conf <- getConfigFromEnv - runSessionWithConfig conf cmd lspCaps projDir $ do - configureCheckProject False - s - - -getConfigFromEnv :: IO SessionConfig -getConfigFromEnv = do - logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR" - timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT" - return defaultConfig - { messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride - , logColor - } - where - checkEnv :: String -> IO (Maybe Bool) - checkEnv s = fmap convertVal <$> getEnv s - convertVal "0" = False - convertVal _ = True - -lspTestCaps :: ClientCapabilities -lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } - -lspTestCapsNoFileWatches :: ClientCapabilities -lspTestCapsNoFileWatches = lspTestCaps & workspace . Lens._Just . didChangeWatchedFiles .~ Nothing - -openTestDataDoc :: FilePath -> Session TextDocumentIdentifier -openTestDataDoc path = do - source <- liftIO $ readFileUtf8 $ "test/data" path - createDoc path "haskell" source - -unitTests :: Recorder (WithPriority Log) -> Logger -> TestTree -unitTests recorder logger = do - testGroup "Unit" - [ testCase "empty file path does NOT work with the empty String literal" $ - uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "." - , testCase "empty file path works using toNormalizedFilePath'" $ - uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just "" - , testCase "empty path URI" $ do - Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri) - uriScheme @?= "file:" - uriPath @?= "" - , testCase "from empty path URI" $ do - let uri = Uri "file://" - uriToFilePath' uri @?= Just "" - , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do - let diag = ("", Diagnostics.ShowDiag, Diagnostic - { _range = Range - { _start = Position{_line = 0, _character = 1} - , _end = Position{_line = 2, _character = 3} - } - , _severity = Nothing - , _code = Nothing - , _source = Nothing - , _message = "" - , _relatedInformation = Nothing - , _tags = Nothing - }) - let shown = T.unpack (Diagnostics.showDiagnostics [diag]) - let expected = "1:2-3:4" - assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $ - expected `isInfixOf` shown - , testCase "notification handlers run in priority order" $ do - orderRef <- newIORef [] - let plugins = pluginDescToIdePlugins $ - [ (priorityPluginDescriptor i) - { pluginNotificationHandlers = mconcat - [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \_ _ _ _ -> - liftIO $ atomicModifyIORef_ orderRef (i:) - ] - } - | i <- [1..20] - ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder) - priorityPluginDescriptor i = (defaultPluginDescriptor $ fromString $ show i){pluginPriority = i} - - testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger plugins) $ do - _ <- createDoc "A.hs" "haskell" "module A where" - waitForProgressDone - actualOrder <- liftIO $ reverse <$> readIORef orderRef - - -- Handlers are run in priority descending order - liftIO $ actualOrder @?= [20, 19 .. 1] - , ignoreTestBecause "The test fails sometimes showing 10000us" $ - testCase "timestamps have millisecond resolution" $ do - resolution_us <- findResolution_us 1 - let msg = printf "Timestamps do not have millisecond resolution: %dus" resolution_us - assertBool msg (resolution_us <= 1000) - , Progress.tests - , FuzzySearch.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 - performGC - writeFile f "" - threadDelay delay_us - writeFile f' "" - t <- getModTime f - t' <- getModTime f' - if t /= t' then return delay_us else findResolution_us (delay_us * 10) - - -testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () -testIde recorder arguments session = do - config <- getConfigFromEnv - cwd <- getCurrentDirectory - (hInRead, hInWrite) <- createPipe - (hOutRead, hOutWrite) <- createPipe - let projDir = "." - let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments - { IDE.argsHandleIn = pure hInRead - , IDE.argsHandleOut = pure hOutWrite - } - - flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> - runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session - -positionMappingTests :: Recorder (WithPriority Log) -> TestTree -positionMappingTests recorder = - testGroup "position mapping" - [ testGroup "toCurrent" - [ testCase "before" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 0) @?= PositionExact (Position 0 0) - , testCase "after, same line, same length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 3) @?= PositionExact (Position 0 3) - , testCase "after, same line, increased length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 0 3) @?= PositionExact (Position 0 4) - , testCase "after, same line, decreased length" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "a" - (Position 0 3) @?= PositionExact (Position 0 2) - , testCase "after, next line, no newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 1 3) @?= PositionExact (Position 1 3) - , testCase "after, next line, newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\ndef" - (Position 1 0) @?= PositionExact (Position 2 0) - , testCase "after, same line, newline" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd" - (Position 0 4) @?= PositionExact (Position 1 2) - , testCase "after, same line, newline + newline at end" $ - toCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd\n" - (Position 0 4) @?= PositionExact (Position 2 1) - , testCase "after, same line, newline + newline at end" $ - toCurrent - (Range (Position 0 1) (Position 0 1)) - "abc" - (Position 0 1) @?= PositionExact (Position 0 4) - ] - , testGroup "fromCurrent" - [ testCase "before" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 0) @?= PositionExact (Position 0 0) - , testCase "after, same line, same length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "ab" - (Position 0 3) @?= PositionExact (Position 0 3) - , testCase "after, same line, increased length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 0 4) @?= PositionExact (Position 0 3) - , testCase "after, same line, decreased length" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "a" - (Position 0 2) @?= PositionExact (Position 0 3) - , testCase "after, next line, no newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc" - (Position 1 3) @?= PositionExact (Position 1 3) - , testCase "after, next line, newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\ndef" - (Position 2 0) @?= PositionExact (Position 1 0) - , testCase "after, same line, newline" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd" - (Position 1 2) @?= PositionExact (Position 0 4) - , testCase "after, same line, newline + newline at end" $ - fromCurrent - (Range (Position 0 1) (Position 0 3)) - "abc\nd\n" - (Position 2 1) @?= PositionExact (Position 0 4) - , testCase "after, same line, newline + newline at end" $ - fromCurrent - (Range (Position 0 1) (Position 0 1)) - "abc" - (Position 0 4) @?= PositionExact (Position 0 1) - ] - , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties" - [ testProperty "fromCurrent r t <=< toCurrent r t" $ do - -- Note that it is important to use suchThatMap on all values at once - -- instead of only using it on the position. Otherwise you can get - -- into situations where there is no position that can be mapped back - -- for the edit which will result in QuickCheck looping forever. - let gen = do - rope <- genRope - range <- genRange rope - PrintableText replacement <- arbitrary - oldPos <- genPosition rope - pure (range, replacement, oldPos) - forAll - (suchThatMap gen - (\(range, replacement, oldPos) -> positionResultToMaybe $ (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $ - \(range, replacement, oldPos, newPos) -> - fromCurrent range replacement newPos === PositionExact oldPos - , testProperty "toCurrent r t <=< fromCurrent r t" $ do - let gen = do - rope <- genRope - range <- genRange rope - PrintableText replacement <- arbitrary - let newRope = runIdentity $ applyChange mempty rope - (TextDocumentContentChangeEvent (Just range) Nothing replacement) - newPos <- genPosition newRope - pure (range, replacement, newPos) - forAll - (suchThatMap gen - (\(range, replacement, newPos) -> positionResultToMaybe $ (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $ - \(range, replacement, newPos, oldPos) -> - toCurrent range replacement oldPos === PositionExact newPos - ] - ] - -newtype PrintableText = PrintableText { getPrintableText :: T.Text } - deriving Show - -instance Arbitrary PrintableText where - arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary - - -genRope :: Gen Rope -genRope = Rope.fromText . getPrintableText <$> arbitrary - -genPosition :: Rope -> Gen Position -genPosition r = do - let rows :: Int = fromIntegral $ Rope.lengthInLines r - row <- choose (0, max 0 $ rows - 1) `suchThat` inBounds @UInt - let columns = T.length (nthLine (fromIntegral row) r) - column <- choose (0, max 0 $ columns - 1) `suchThat` inBounds @UInt - pure $ Position (fromIntegral row) (fromIntegral column) - -genRange :: Rope -> Gen Range -genRange r = do - let rows :: Int = fromIntegral $ Rope.lengthInLines r - startPos@(Position startLine startColumn) <- genPosition r - let maxLineDiff = max 0 $ rows - 1 - fromIntegral startLine - endLine <- choose (fromIntegral startLine, fromIntegral startLine + maxLineDiff) `suchThat` inBounds @UInt - let columns = T.length (nthLine (fromIntegral endLine) r) - endColumn <- - if fromIntegral startLine == endLine - then choose (fromIntegral startColumn, columns) - else choose (0, max 0 $ columns - 1) - `suchThat` inBounds @UInt - pure $ Range startPos (Position (fromIntegral endLine) (fromIntegral endColumn)) - -inBounds :: forall b a . (Integral a, Integral b, Bounded b) => a -> Bool -inBounds a = let i = toInteger a in i <= toInteger (maxBound @b) && i >= toInteger (minBound @b) - --- | Get the ith line of a rope, starting from 0. Trailing newline not included. -nthLine :: Int -> Rope -> T.Text -nthLine i r - | Rope.null r = "" - | otherwise = Rope.lines r !! i - -getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions] -getWatchedFilesSubscriptionsUntil m = do - msgs <- manyTill (Just <$> message SClientRegisterCapability <|> Nothing <$ anyMessage) (message m) - return - [ args - | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs - , SomeRegistration (Registration _id SWorkspaceDidChangeWatchedFiles args) <- regs - ] - --- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path --- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or --- @/var@ -withTempDir :: (FilePath -> IO a) -> IO a -withTempDir f = System.IO.Extra.withTempDir $ \dir -> do - dir' <- canonicalizePath dir - f dir' - - --- | Before ghc9, lists of Char is displayed as [Char], but with ghc9 and up, it's displayed as String -listOfChar :: T.Text -listOfChar | ghcVersion >= GHC90 = "String" - | otherwise = "[Char]" - --- | Ghc 9 doesn't include the $-sign in TH warnings like earlier versions did -thDollarIdx :: UInt -thDollarIdx | ghcVersion >= GHC90 = 1 - | otherwise = 0 diff --git a/test/exe/Progress.hs b/test/exe/Progress.hs deleted file mode 100644 --- a/test/exe/Progress.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE PackageImports #-} -module Progress (tests) where - -import Control.Concurrent.STM -import Data.Foldable (for_) -import qualified Data.HashMap.Strict as Map -import Development.IDE (NormalizedFilePath) -import Development.IDE.Core.ProgressReporting -import qualified "list-t" ListT -import qualified StmContainers.Map as STM -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = testGroup "Progress" - [ reportProgressTests - ] - -data InProgressModel = InProgressModel { - done, todo :: Int, - current :: Map.HashMap NormalizedFilePath Int -} - -reportProgressTests :: TestTree -reportProgressTests = testGroup "recordProgress" - [ test "addNew" addNew - , test "increase" increase - , test "decrease" decrease - , test "done" done - ] - where - p0 = pure $ InProgressModel 0 0 mempty - addNew = recordProgressModel "A" succ p0 - increase = recordProgressModel "A" succ addNew - decrease = recordProgressModel "A" succ increase - done = recordProgressModel "A" pred decrease - recordProgressModel key change state = - model state $ \st -> recordProgress st key change - model stateModelIO k = do - state <- fromModel =<< stateModelIO - k state - toModel state - test name p = testCase name $ do - InProgressModel{..} <- p - (done, todo) @?= (length (filter (==0) (Map.elems current)), Map.size current) - -fromModel :: InProgressModel -> IO InProgressState -fromModel InProgressModel{..} = do - doneVar <- newTVarIO done - todoVar <- newTVarIO todo - currentVar <- STM.newIO - atomically $ for_ (Map.toList current) $ \(k,v) -> STM.insert v k currentVar - return InProgressState{..} - -toModel :: InProgressState -> IO InProgressModel -toModel InProgressState{..} = atomically $ do - done <- readTVar doneVar - todo <- readTVar todoVar - current <- Map.fromList <$> ListT.toList (STM.listT currentVar) - return InProgressModel{..} diff --git a/test/preprocessor/Main.hs b/test/preprocessor/Main.hs deleted file mode 100644 --- a/test/preprocessor/Main.hs +++ /dev/null @@ -1,10 +0,0 @@ - -module Main(main) where - -import System.Environment - -main :: IO () -main = do - _:input:output:_ <- getArgs - let f = map (\x -> if x == 'x' then 'y' else x) - writeFile output . f =<< readFile input diff --git a/test/src/Development/IDE/Test.hs b/test/src/Development/IDE/Test.hs deleted file mode 100644 --- a/test/src/Development/IDE/Test.hs +++ /dev/null @@ -1,260 +0,0 @@ --- Copyright (c) 2019 The DAML Authors. All rights reserved. --- SPDX-License-Identifier: Apache-2.0 - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} - -module Development.IDE.Test - ( Cursor - , cursorPosition - , requireDiagnostic - , diagnostic - , expectDiagnostics - , expectDiagnosticsWithTags - , expectNoMoreDiagnostics - , expectMessages - , expectCurrentDiagnostics - , checkDiagnosticsForDoc - , canonicalizeUri - , standardizeQuotes - , flushMessages - , waitForAction - , getInterfaceFilesDir - , garbageCollectDirtyKeys - , getFilesOfInterest - , waitForTypecheck - , waitForBuildQueue - , getStoredKeys - , waitForCustomMessage - , waitForGC - , configureCheckProject - , isReferenceReady - , referenceReady) where - -import Control.Applicative.Combinators -import Control.Lens hiding (List) -import Control.Monad -import Control.Monad.IO.Class -import Data.Aeson (toJSON) -import qualified Data.Aeson as A -import Data.Bifunctor (second) -import Data.Default -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, - ideResultSuccess) -import Development.IDE.Test.Diagnostic -import Ide.Plugin.Config (CheckParents, checkProject) -import Language.LSP.Test hiding (message) -import qualified Language.LSP.Test as LspTest -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import Language.LSP.Types.Lens as Lsp -import System.Directory (canonicalizePath) -import System.FilePath (equalFilePath) -import System.Time.Extra -import Test.Tasty.HUnit - -requireDiagnosticM - :: (Foldable f, Show (f Diagnostic), HasCallStack) - => f Diagnostic - -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) - -> Assertion -requireDiagnosticM actuals expected = case requireDiagnostic actuals expected of - Nothing -> pure () - Just err -> assertFailure err - --- |wait for @timeout@ seconds and report an assertion failure --- if any diagnostic messages arrive in that period -expectNoMoreDiagnostics :: HasCallStack => Seconds -> Session () -expectNoMoreDiagnostics timeout = - expectMessages STextDocumentPublishDiagnostics timeout $ \diagsNot -> do - let fileUri = diagsNot ^. params . uri - actual = diagsNot ^. params . diagnostics - unless (actual == List []) $ liftIO $ - assertFailure $ - "Got unexpected diagnostics for " <> show fileUri - <> " got " - <> show actual - -expectMessages :: SMethod m -> Seconds -> (ServerMessage m -> Session ()) -> Session () -expectMessages m timeout handle = do - -- Give any further diagnostic messages time to arrive. - liftIO $ sleep timeout - -- Send a dummy message to provoke a response from the server. - -- This guarantees that we have at least one message to - -- process, so message won't block or timeout. - let cm = SCustomMethod "test" - i <- sendRequest cm $ A.toJSON GetShakeSessionQueueCount - go cm i - where - go cm i = handleMessages - where - handleMessages = (LspTest.message m >>= handle) <|> (void $ responseForId cm i) <|> ignoreOthers - ignoreOthers = void anyMessage >> handleMessages - -flushMessages :: Session () -flushMessages = do - let cm = SCustomMethod "non-existent-method" - i <- sendRequest cm A.Null - void (responseForId cm i) <|> ignoreOthers cm i - where - ignoreOthers cm i = skipManyTill anyMessage (responseForId cm i) >> flushMessages - --- | It is not possible to use 'expectDiagnostics []' to assert the absence of diagnostics, --- only that existing diagnostics have been cleared. --- --- Rather than trying to assert the absence of diagnostics, introduce an --- expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic. -expectDiagnostics :: HasCallStack => [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session () -expectDiagnostics - = expectDiagnosticsWithTags - . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) - -unwrapDiagnostic :: NotificationMessage TextDocumentPublishDiagnostics -> (Uri, List Diagnostic) -unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics) - -expectDiagnosticsWithTags :: HasCallStack => [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () -expectDiagnosticsWithTags expected = do - let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri - next = unwrapDiagnostic <$> skipManyTill anyMessage diagnostic - expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) f expected - expectDiagnosticsWithTags' next expected' - -expectDiagnosticsWithTags' :: - (HasCallStack, MonadIO m) => - m (Uri, List Diagnostic) -> - Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] -> - m () -expectDiagnosticsWithTags' next m | null m = do - (_,actual) <- next - case actual of - List [] -> - return () - _ -> - liftIO $ assertFailure $ "Got unexpected diagnostics:" <> show actual - -expectDiagnosticsWithTags' next expected = go expected - where - go m - | Map.null m = pure () - | otherwise = do - (fileUri, actual) <- next - canonUri <- liftIO $ toNormalizedUri <$> canonicalizeUri fileUri - case Map.lookup canonUri m of - Nothing -> do - liftIO $ - assertFailure $ - "Got diagnostics for " <> show fileUri - <> " but only expected diagnostics for " - <> show (Map.keys m) - <> " got " - <> show actual - Just expected -> do - liftIO $ mapM_ (requireDiagnosticM actual) expected - liftIO $ - unless (length expected == length actual) $ - assertFailure $ - "Incorrect number of diagnostics for " <> show fileUri - <> ", expected " - <> show expected - <> " but got " - <> show actual - go $ Map.delete canonUri m - -expectCurrentDiagnostics :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session () -expectCurrentDiagnostics doc expected = do - diags <- getCurrentDiagnostics doc - checkDiagnosticsForDoc doc expected diags - -checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session () -checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do - let expected' = Map.fromList [(nuri, map (\(ds, c, t) -> (ds, c, t, Nothing)) expected)] - nuri = toNormalizedUri _uri - expectDiagnosticsWithTags' (return (_uri, List obtained)) expected' - -canonicalizeUri :: Uri -> IO Uri -canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri)) - -diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics) -diagnostic = LspTest.message STextDocumentPublishDiagnostics - -tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) -tryCallTestPlugin cmd = do - let cm = SCustomMethod "test" - waitId <- sendRequest cm (A.toJSON cmd) - ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId - return $ case _result of - Left e -> Left e - Right json -> case A.fromJSON json of - A.Success a -> Right a - A.Error e -> error e - -callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b -callTestPlugin cmd = do - res <- tryCallTestPlugin cmd - case res of - Left (ResponseError t err _) -> error $ show t <> ": " <> T.unpack err - Right a -> pure a - - -waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResult -waitForAction key TextDocumentIdentifier{_uri} = - callTestPlugin (WaitForIdeRule key _uri) - -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 - -configureCheckProject :: Bool -> Session () -configureCheckProject overrideCheckProject = - sendNotification SWorkspaceDidChangeConfiguration - (DidChangeConfigurationParams $ toJSON - def{checkProject = overrideCheckProject}) - --- | Pattern match a message from ghcide indicating that a file has been indexed -isReferenceReady :: FilePath -> Session () -isReferenceReady p = void $ referenceReady (equalFilePath p) - -referenceReady :: (FilePath -> Bool) -> Session FilePath -referenceReady pred = satisfyMaybe $ \case - FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params}) - | A.Success fp <- A.fromJSON _params - , pred fp - -> Just fp - _ -> Nothing - diff --git a/test/src/Development/IDE/Test/Diagnostic.hs b/test/src/Development/IDE/Test/Diagnostic.hs deleted file mode 100644 --- a/test/src/Development/IDE/Test/Diagnostic.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Development.IDE.Test.Diagnostic where - -import Control.Lens ((^.)) -import qualified Data.Text as T -import GHC.Stack (HasCallStack) -import Language.LSP.Types -import Language.LSP.Types.Lens as Lsp - --- | (0-based line number, 0-based column number) -type Cursor = (UInt, UInt) - -cursorPosition :: Cursor -> Position -cursorPosition (line, col) = Position line col - -type ErrorMsg = String - -requireDiagnostic - :: (Foldable f, Show (f Diagnostic), HasCallStack) - => f Diagnostic - -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) - -> Maybe ErrorMsg -requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) - | any match actuals = Nothing - | otherwise = Just $ - "Could not find " <> show expected <> - " in " <> show actuals - where - match :: Diagnostic -> Bool - match d = - Just severity == _severity d - && cursorPosition cursor == d ^. range . start - && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf` - standardizeQuotes (T.toLower $ d ^. message) - && hasTag expectedTag (d ^. tags) - - hasTag :: Maybe DiagnosticTag -> Maybe (List DiagnosticTag) -> Bool - hasTag Nothing _ = True - hasTag (Just _) Nothing = False - hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags - -standardizeQuotes :: T.Text -> T.Text -standardizeQuotes msg = let - repl '‘' = '\'' - repl '’' = '\'' - repl '`' = '\'' - repl c = c - in T.map repl msg