git.iko.soy/ghcide
on master help sign in
swap
5a754e1175 ahead, 0 behind
.azure/linux-stack.ymlnew file+63
since splitsnapshots
unifiedsplit
@@ -0,0 +1,63 @@
1+jobs:
2+- job: ghcide_stack_linux
3+ timeoutInMinutes: 60
4+ pool:
5+ vmImage: 'ubuntu-latest'
6+ strategy:
7+ matrix:
8+ stack_810:
9+ STACK_YAML: "stack810.yaml"
10+ stack_88:
11+ STACK_YAML: "stack88.yaml"
12+ stack_86:
13+ STACK_YAML: "stack.yaml"
14+ stack_84:
15+ STACK_YAML: "stack84.yaml"
16+ stack_ghc_lib_88:
17+ STACK_YAML: "stack-ghc-lib.yaml"
18+ steps:
19+ - checkout: self
20+ - task: Cache@2
21+ inputs:
22+ key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/$(STACK_YAML) | $(Build.SourcesDirectory)/ghcide.cabal
23+ path: .azure-cache
24+ cacheHitVar: CACHE_RESTORED
25+ displayName: "Cache stack artifacts"
26+ - bash: |
27+ mkdir -p ~/.stack
28+ tar xzf .azure-cache/stack-root.tar.gz -C $HOME
29+ displayName: "Unpack cache"
30+ condition: eq(variables.CACHE_RESTORED, 'true')
31+ - bash: |
32+ ./fmt.sh
33+ displayName: "HLint via ./fmt.sh"
34+ - bash: |
35+ sudo add-apt-repository ppa:hvr/ghc
36+ sudo apt-get update
37+ sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev cabal-install-3.2
38+ if ! which stack >/dev/null 2>&1; then
39+ curl -sSL https://get.haskellstack.org/ | sh
40+ fi
41+ displayName: 'Install Stack'
42+ - bash: stack setup --stack-yaml=$STACK_YAML
43+ displayName: 'stack setup'
44+ - bash: stack build --only-dependencies --stack-yaml=$STACK_YAML
45+ displayName: 'stack build --only-dependencies'
46+ - bash: |
47+ export PATH=/opt/cabal/bin:$PATH
48+ stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML || stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML|| stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML
49+ # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.
50+ displayName: 'stack test --ghc-options=-Werror'
51+ - bash: |
52+ mkdir -p .azure-cache
53+ tar czf .azure-cache/stack-root.tar.gz -C $HOME .stack
54+ displayName: "Pack cache"
55+ - bash: |
56+ set -euo pipefail
57+ MESSAGE=$(git log --pretty=format:%s -n1)
58+ curl -XPOST \
59+ -i \
60+ -H 'Content-type: application/json' \
61+ --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \
62+ $(Slack.URL)
63+ condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))
.azure/windows-stack.ymlnew file+68
@@ -0,0 +1,68 @@
1+jobs:
2+- job: ghcide_stack_windows
3+ timeoutInMinutes: 60
4+ pool:
5+ vmImage: 'windows-2019'
6+ strategy:
7+ matrix:
8+ stack_810:
9+ STACK_YAML: "stack810.yaml"
10+ stack_88:
11+ STACK_YAML: "stack88.yaml"
12+ stack_86:
13+ STACK_YAML: "stack.yaml"
14+ stack_84:
15+ STACK_YAML: "stack84.yaml"
16+ stack_ghc_lib_88:
17+ STACK_YAML: "stack-ghc-lib.yaml"
18+ variables:
19+ STACK_ROOT: "C:\\sr"
20+ steps:
21+ - checkout: self
22+ - task: Cache@2
23+ inputs:
24+ key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/$(STACK_YAML) | $(Build.SourcesDirectory)/ghcide.cabal
25+ path: .azure-cache
26+ cacheHitVar: CACHE_RESTORED
27+ displayName: "Cache stack artifacts"
28+ - bash: |
29+ mkdir -p $STACK_ROOT
30+ tar -vxzf .azure-cache/stack-root.tar.gz -C /c
31+ mkdir -p .stack-work
32+ tar -vxzf .azure-cache/stack-work.tar.gz
33+ displayName: "Unpack cache"
34+ condition: eq(variables.CACHE_RESTORED, 'true')
35+ - bash: |
36+ ./fmt.sh
37+ displayName: "HLint via ./fmt.sh"
38+ - bash: |
39+ curl -sSkL http://www.stackage.org/stack/windows-x86_64 -o /usr/bin/stack.zip
40+ unzip -o /usr/bin/stack.zip -d /usr/bin/
41+ mkdir -p "$STACK_ROOT"
42+ displayName: 'Install Stack'
43+ - bash: stack setup --stack-yaml $STACK_YAML
44+ displayName: 'stack setup'
45+ - bash: |
46+ # Installing happy and alex standalone to avoid error "strip.exe: unable to rename ../*.exe; reason: File exists"
47+ stack install happy --stack-yaml $STACK_YAML
48+ stack install alex --stack-yaml $STACK_YAML
49+ stack install cabal-install --stack-yaml $STACK_YAML
50+ stack build --only-dependencies --stack-yaml $STACK_YAML
51+ displayName: 'stack build --only-dependencies'
52+ - bash: stack test --no-run-tests --ghc-options=-Werror --stack-yaml $STACK_YAML
53+ displayName: 'stack test --ghc-options=-Werror'
54+ # TODO: run test suite when failing tests are fixed or marked as broken. See https://github.com/digital-asset/ghcide/issues/474
55+ - bash: |
56+ mkdir -p .azure-cache
57+ tar -vczf .azure-cache/stack-root.tar.gz $(cygpath $STACK_ROOT)
58+ tar -vczf .azure-cache/stack-work.tar.gz .stack-work
59+ displayName: "Pack cache"
60+ - bash: |
61+ set -euo pipefail
62+ MESSAGE=$(git log --pretty=format:%s -n1)
63+ curl -XPOST \
64+ -i \
65+ -H 'Content-type: application/json' \
66+ --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \
67+ $(Slack.URL)
68+ condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))
.editorconfignew file+11
@@ -0,0 +1,11 @@
1+; This file is for unifying the coding style for different editors and IDEs.
2+; More information at https://EditorConfig.org
3+
4+root = true
5+
6+[*]
7+end_of_line = LF
8+indent_style = space
9+indent_size = 4
10+trim_trailing_whitespace = true
11+insert_final_newline = true
.ghcideleted−24
@@ -1,24 +0,0 @@
1−:set -Wunused-binds -Wunused-imports -Worphans -Wunused-matches -Wincomplete-patterns
2−
3−:set -XBangPatterns
4−:set -XDeriveFunctor
5−:set -XDeriveGeneric
6−:set -XGeneralizedNewtypeDeriving
7−:set -XLambdaCase
8−:set -XNamedFieldPuns
9−:set -XOverloadedStrings
10−:set -XRecordWildCards
11−:set -XScopedTypeVariables
12−:set -XStandaloneDeriving
13−:set -XTupleSections
14−:set -XTypeApplications
15−:set -XViewPatterns
16−
17−:set -package=ghc
18−:set -hide-package=ghc-lib-parser
19−:set -DGHC_STABLE
20−:set -Iinclude
21−:set -isrc
22−:set -iexe
23−
24−:load Main
.gitignore+4
@@ -4,3 +4,7 @@ dist-newstyle/
4cabal.project.local
4cabal.project.local
5*~
5*~
6*.lock
6*.lock
7+/.tasty-rerun-log
8+.vscode
9+/.hlint-*
10+bench/example
.hlint.yaml+12−2
@@ -73,16 +73,23 @@
73 - {name: ViewPatterns, within: []}
73 - {name: ViewPatterns, within: []}
74
74
75 # Shady extensions
75 # Shady extensions
76− - {name: ImplicitParams, within: []}
77 - name: CPP
76 - name: CPP
78 within:
77 within:
78+ - Development.IDE.Compat
79 - Development.IDE.Core.FileStore
79 - Development.IDE.Core.FileStore
80 - Development.IDE.Core.Compile
80 - Development.IDE.Core.Compile
81+ - Development.IDE.Core.Rules
81 - Development.IDE.GHC.Compat
82 - Development.IDE.GHC.Compat
83+ - Development.IDE.GHC.Orphans
82 - Development.IDE.GHC.Util
84 - Development.IDE.GHC.Util
83 - Development.IDE.Import.FindImports
85 - Development.IDE.Import.FindImports
84− - Development.IDE.LSP.CodeAction
86+ - Development.IDE.LSP.Outline
85 - Development.IDE.Spans.Calculate
87 - Development.IDE.Spans.Calculate
88+ - Development.IDE.Spans.Documentation
89+ - Development.IDE.Spans.Common
90+ - Development.IDE.Plugin.CodeAction
91+ - Development.IDE.Plugin.Completions
92+ - Development.IDE.Plugin.Completions.Logic
86 - Main
93 - Main
87
94
88- flags:
95- flags:
@@ -94,9 +101,12 @@
94# - {name: Control.Arrow, within: []} # Certain modules are banned entirely
101# - {name: Control.Arrow, within: []} # Certain modules are banned entirely
95#
102#
96- functions:
103- functions:
104+ # Things that are unsafe in Haskell base library
97 - {name: unsafeInterleaveIO, within: []}
105 - {name: unsafeInterleaveIO, within: []}
98 - {name: unsafeDupablePerformIO, within: []}
106 - {name: unsafeDupablePerformIO, within: []}
99 - {name: unsafeCoerce, within: []}
107 - {name: unsafeCoerce, within: []}
108+ # Things that are a bit dangerous in the GHC API
109+ - {name: nameModule, within: []}
100
110
101# Add custom hints for this project
111# Add custom hints for this project
102#
112#
CHANGELOG.md+57
@@ -1,5 +1,62 @@
1### unreleased
1### unreleased
2
2
3+### 0.2.0 (2020-06-02)
4+
5+* Multi-component support (thanks @mpickering)
6+* Support for GHC 8.10 (thanks @sheaf and @chshersh)
7+* Fix some TH issues (thanks @mpickering)
8+* Automatically pick up changes to cradle dependencies (e.g. cabal
9+ files) (thanks @jinwoo)
10+* Track dependencies when using `qAddDependentFile` (thanks @mpickering)
11+* Add record fields to document symbols outline (thanks @bubba)
12+* Fix some space leaks (thanks @mpickering)
13+* Strip redundant path information from diagnostics (thanks @tek)
14+* Fix import suggestions for operators (thanks @eddiemundo)
15+* Significant reductions in memory usage by using interfaces and `.hie` files (thanks
16+ @pepeiborra)
17+* Minor improvements to completions
18+* More comprehensive suggestions for missing imports (thanks @pepeiborra)
19+* Group imports in document outline (thanks @fendor)
20+* Upgrade to haskell-lsp-0.22 (thanks @bubba)
21+* Upgrade to hie-bios 0.5 (thanks @fendor)
22+
23+### 0.1.0 (2020-02-04)
24+
25+* Code action for inserting new definitions (see #309).
26+* Better default GC settings (see #329 and #333).
27+* Various performance improvements (see #322 and #384).
28+* Improvements to hover information (see #317 and #338).
29+* Support GHC 8.8.2 (see #355).
30+* Include keywords in completions (see #351).
31+* Fix some issues with aborted requests (see #353).
32+* Use hie-bios 0.4.0 (see #382).
33+* Avoid stuck progress reporting (see #400).
34+* Only show progress notifications after 0.1s (see #392).
35+* Progress reporting is now in terms of the number of files rather
36+ than the number of shake rules (see #379).
37+
38+### 0.0.6 (2020-01-10)
39+
40+* Fix type in hover information for do-notation and list
41+ comprehensions (see #243).
42+* Fix hover and goto-definition for multi-clause definitions (see #252).
43+* Upgrade to `hie-bios-0.3` (see #257)
44+* Upgrade to `haskell-lsp-0.19` (see #254)
45+* Code lenses for missing signatures are displayed even if the warning
46+ has not been enabled. The warning itself will not be shown if it is
47+ not enabled. (see #232)
48+* Define `__GHCIDE__` when running CPP to allow for `ghcide`-specific
49+ workarounds. (see #264)
50+* Fix some filepath normalization issues. (see #266)
51+* Fix build with `shake-0.18.4` (see #272)
52+* Fix hover for type constructors and type classes. (see #267)
53+* Support custom preprocessors (see #282)
54+* Add support for code completions (see #227)
55+* Code action for removing redundant symbols from imports (see #290)
56+* Support document symbol requests (see #293)
57+* Show CPP errors as diagnostics (see #296)
58+* Code action for adding suggested imports (see #295)
59+
3### 0.0.5 (2019-12-12)
60### 0.0.5 (2019-12-12)
4
61
5* Support for GHC plugins (see #192)
62* Support for GHC plugins (see #192)
README.md+87−6
@@ -25,13 +25,40 @@ There are more details about our approach [in this blog post](https://4ta.uk/p/s
25| Display type and source module of values | hover |
25| Display type and source module of values | hover |
26| Remove redundant imports, replace suggested typos for values and module imports, fill type holes, insert missing type signatures, add suggested ghc extensions | codeAction (quickfix) |
26| Remove redundant imports, replace suggested typos for values and module imports, fill type holes, insert missing type signatures, add suggested ghc extensions | codeAction (quickfix) |
27
27
28+
29+## Limitations to Multi-Component support
30+
31+`ghcide` supports loading multiple components into the same session so that
32+features such as go-to definition work across components. However, there are
33+some limitations to this.
34+
35+1. You will get much better results currently manually specifying the hie.yaml file.
36+Until tools like cabal and stack provide the right interface to support multi-component
37+projects, it is always advised to specify explicitly how your project partitions.
38+2. Cross-component features only work if you have loaded at least one file
39+from each component.
40+3. There is a known issue where if you have three components, such that A depends on B which depends on C
41+then if you load A and C into the session but not B then under certain situations you
42+can get strange errors about a type coming from two different places. See [this repo](https://github.com/fendor/ghcide-bad-interface-files) for
43+a simple reproduction of the bug.
44+
28## Using it
45## Using it
29
46
30### Install `ghcide`
47### Install `ghcide`
31
48
32#### With Nix
49#### With Nix
33
50
51+Note that you need to compile `ghcide` with the same `ghc` as the project you are working on.
52+
53+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
54+ ```
55+ nix-env -iA haskellPackages.ghcide
56+ ```
57+ or e.g. including `pkgs.haskellPackages.ghcide` in your projects `shell.nix`.
58+ Depending on your `nixpkgs` channel that might not be the newest `ghcide`, though.
59+
34−[See ghcide-nix repository](https://github.com/hercules-ci/ghcide-nix)
60+2. If your `ghc` does not match nixpkgs you should try the [ghcide-nix repository](https://github.com/cachix/ghcide-nix)
61+ which provides a `ghcide` via the `haskell.nix` infrastructure.
35
62
36#### With Cabal or Stack
63#### With Cabal or Stack
37
64
@@ -64,11 +91,39 @@ The `ghcide` executable mostly relies on [`hie-bios`](https://github.com/mpicker
64
91
65If 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.
92If 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.
66
93
94+### Optimal project setup
95+
96+`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.6, 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.
97+
67### Using with VS Code
98### Using with VS Code
68
99
69You can install the VSCode extension from the [VSCode
100You can install the VSCode extension from the [VSCode
70marketplace](https://marketplace.visualstudio.com/items?itemName=DigitalAssetHoldingsLLC.ghcide).
101marketplace](https://marketplace.visualstudio.com/items?itemName=DigitalAssetHoldingsLLC.ghcide).
71
102
103+### Using with Atom
104+
105+You can follow the [instructions](https://github.com/moodmosaic/ide-haskell-ghcide#readme) to install with `apm`.
106+
107+### Using with Sublime Text
108+
109+* Install [LSP](https://packagecontrol.io/packages/LSP)
110+* Press Ctrl+Shift+P or Cmd+Shift+P in Sublime Text and search for *Preferences: LSP Settings*, then paste these settings
111+```
112+{
113+ "clients":
114+ {
115+ "ghcide":
116+ {
117+ "enabled" : true,
118+ "languageId": "haskell",
119+ "command" : ["ghcide", "--lsp"],
120+ "scopes" : ["source.haskell"],
121+ "syntaxes" : ["Packages/Haskell/Haskell.sublime-syntax"]
122+ }
123+ }
124+}
125+```
126+
72### Using with Emacs
127### Using with Emacs
73
128
74If 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).
129If 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).
@@ -179,7 +234,11 @@ Add this to your coc-settings.json (which you can edit with :CocConfig):
179```
234```
180
235
181Here's a nice article on setting up neovim and coc: [Vim and Haskell in
236Here's a nice article on setting up neovim and coc: [Vim and Haskell in
182−2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/)
237+2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/) (this is actually for haskell-ide, not ghcide)
238+
239+Here is a Docker container that pins down the build and configuration for
240+Neovim and ghcide on a minimal Debian 10 base system:
241+[docker-ghcide-neovim](https://github.com/carlohamalainen/docker-ghcide-neovim/).
183
242
184### SpaceVim
243### SpaceVim
185
244
@@ -200,10 +259,8 @@ Add this to your coc-settings.json (which you can edit with :CocConfig):
200{
259{
201 "languageserver": {
260 "languageserver": {
202 "haskell": {
261 "haskell": {
203− "command": "stack",
262+ "command": "ghcide",
204 "args": [
263 "args": [
205− "exec",
206− "ghcide",
207 "--lsp"
264 "--lsp"
208 ],
265 ],
209 "rootPatterns": [
266 "rootPatterns": [
@@ -226,10 +283,32 @@ Add this to your coc-settings.json (which you can edit with :CocConfig):
226This example above describes a setup in which `ghcide` is installed
283This example above describes a setup in which `ghcide` is installed
227using `stack install ghcide` within a project.
284using `stack install ghcide` within a project.
228
285
286+### Using with Kakoune
287+
288+Install [kak-lsp](https://github.com/ul/kak-lsp).
289+
290+Change `kak-lsp.toml` to include this:
291+
292+```toml
293+[language.haskell]
294+filetypes = ["haskell"]
295+roots = ["Setup.hs", "stack.yaml", "*.cabal", "cabal.project", "hie.yaml"]
296+command = "ghcide"
297+args = ["--lsp"]
298+```
299+
229## Hacking on ghcide
300## Hacking on ghcide
230
301
231To build and work on `ghcide` itself, you can use Stack or cabal, e.g.,
302To build and work on `ghcide` itself, you can use Stack or cabal, e.g.,
232running `stack test` will execute the test suite.
303running `stack test` will execute the test suite.
304+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`.
305+
306+If you are chasing down test failures, you can use the tasty-rerun feature by running tests as
307+
308+ stack --stack-yaml=stack84.yaml test --test-arguments "--rerun"
309+
310+This writes a log file called `.tasty-rerun-log` of the failures, and only runs those.
311+See the [tasty-rerun](https://hackage.haskell.org/package/tasty-rerun-1.1.17/docs/Test-Tasty-Ingredients-Rerun.html) documentation for other options.
233
312
234### Building the extension
313### Building the extension
235
314
@@ -246,8 +325,10 @@ Now opening a `.hs` file should work with `ghcide`.
246
325
247## History and relationship to other Haskell IDE's
326## History and relationship to other Haskell IDE's
248
327
328+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).
329+
249The 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/digital-asset/ghcide/graphs/contributors), in addition to continued investment by Digital Asset. All contributions require a [Contributor License Agreement](https://cla.digitalasset.com/digital-asset/ghcide) that states you license the code under the [Apache License](LICENSE).
330The 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/digital-asset/ghcide/graphs/contributors), in addition to continued investment by Digital Asset. All contributions require a [Contributor License Agreement](https://cla.digitalasset.com/digital-asset/ghcide) that states you license the code under the [Apache License](LICENSE).
250
331
251−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 has 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. While `ghcide` is not a part of `haskell-ide-engine`, we feel it _could_ form the core of a future version - but such decisions are up to the `haskell-ide-engine` contributors.
332+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.
252
333
253The 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/digital-asset/ghcide/).
334The 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/digital-asset/ghcide/).
azure-pipelines.yml+3−184
@@ -4,6 +4,7 @@ trigger:
4 branches:
4 branches:
5 include:
5 include:
6 - master
6 - master
7+ - azure*
7
8
8# Enable PR triggers that target the master branch
9# Enable PR triggers that target the master branch
9pr:
10pr:
@@ -13,187 +14,5 @@ pr:
13 - master
14 - master
14
15
15jobs:
16jobs:
16− - job: ghcide_stack_86
17+ - template: ./.azure/linux-stack.yml
17− timeoutInMinutes: 60
18+ - template: ./.azure/windows-stack.yml
18− pool:
19− vmImage: 'ubuntu-latest'
20− steps:
21− - checkout: self
22− - task: CacheBeta@0
23− inputs:
24− key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/stack.yaml | $(Build.SourcesDirectory)/ghcide.cabal
25− path: .azure-cache
26− cacheHitVar: CACHE_RESTORED
27− displayName: "Cache stack artifacts"
28− - bash: |
29− mkdir -p ~/.stack
30− tar xzf .azure-cache/stack-root.tar.gz -C $HOME
31− displayName: "Unpack cache"
32− condition: eq(variables.CACHE_RESTORED, 'true')
33− - bash: |
34− ./fmt.sh
35− displayName: "HLint via ./fmt.sh"
36− - bash: |
37− sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev
38− if ! which stack >/dev/null 2>&1; then
39− curl -sSL https://get.haskellstack.org/ | sh
40− fi
41− displayName: 'Install Stack'
42− - bash: stack setup
43− displayName: 'stack setup'
44− - bash: stack build --only-dependencies
45− displayName: 'stack build --only-dependencies'
46− - bash: stack test --ghc-options=-Werror || stack test --ghc-options=-Werror || stack test --ghc-options=-Werror
47− # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.
48− displayName: 'stack test --ghc-options=-Werror'
49− - bash: |
50− mkdir -p .azure-cache
51− tar czf .azure-cache/stack-root.tar.gz -C $HOME .stack
52− displayName: "Pack cache"
53− - bash: |
54− set -euo pipefail
55− MESSAGE=$(git log --pretty=format:%s -n1)
56− curl -XPOST \
57− -i \
58− -H 'Content-type: application/json' \
59− --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \
60− $(Slack.URL)
61− condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))
62− - job: ghcide_stack_84
63− timeoutInMinutes: 60
64− pool:
65− vmImage: 'ubuntu-latest'
66− steps:
67− - checkout: self
68− - task: CacheBeta@0
69− inputs:
70− key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/stack84.yaml | $(Build.SourcesDirectory)/ghcide.cabal
71− path: .azure-cache
72− cacheHitVar: CACHE_RESTORED
73− displayName: "Cache stack artifacts"
74− - bash: |
75− mkdir -p ~/.stack
76− tar xzf .azure-cache/stack-root.tar.gz -C $HOME
77− displayName: "Unpack cache"
78− condition: eq(variables.CACHE_RESTORED, 'true')
79− - bash: |
80− ./fmt.sh
81− displayName: "HLint via ./fmt.sh"
82− - bash: |
83− sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev
84− if ! which stack >/dev/null 2>&1; then
85− curl -sSL https://get.haskellstack.org/ | sh
86− fi
87− displayName: 'Install Stack'
88− - bash: stack setup --stack-yaml=stack84.yaml
89− displayName: 'stack setup --stack-yaml=stack84.yaml'
90− - bash: stack build --only-dependencies --stack-yaml=stack84.yaml
91− displayName: 'stack build --only-dependencies --stack-yaml=stack84.yaml'
92− - bash: stack test --stack-yaml=stack84.yaml --ghc-options=-Werror || stack test --stack-yaml=stack84.yaml --ghc-options=-Werror || stack test --stack-yaml=stack84.yaml --ghc-options=-Werror
93− # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.
94− displayName: 'stack test --stack-yaml=stack84.yaml --ghc-options=-Werror'
95− - bash: |
96− mkdir -p .azure-cache
97− tar czf .azure-cache/stack-root.tar.gz -C $HOME .stack
98− displayName: "Pack cache"
99− - bash: |
100− set -euo pipefail
101− MESSAGE=$(git log --pretty=format:%s -n1)
102− curl -XPOST \
103− -i \
104− -H 'Content-type: application/json' \
105− --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \
106− $(Slack.URL)
107− condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))
108− - job: ghcide_stack_88
109− timeoutInMinutes: 60
110− pool:
111− vmImage: 'ubuntu-latest'
112− steps:
113− - checkout: self
114− - task: CacheBeta@0
115− inputs:
116− key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/stack88.yaml | $(Build.SourcesDirectory)/ghcide.cabal
117− path: .azure-cache
118− cacheHitVar: CACHE_RESTORED
119− displayName: "Cache stack artifacts"
120− - bash: |
121− mkdir -p ~/.stack
122− tar xzf .azure-cache/stack-root.tar.gz -C $HOME
123− displayName: "Unpack cache"
124− condition: eq(variables.CACHE_RESTORED, 'true')
125− - bash: |
126− ./fmt.sh
127− displayName: "HLint via ./fmt.sh"
128− - bash: |
129− sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev
130− if ! which stack >/dev/null 2>&1; then
131− curl -sSL https://get.haskellstack.org/ | sh
132− fi
133− displayName: 'Install Stack'
134− - bash: stack setup --stack-yaml=stack88.yaml
135− displayName: 'stack setup --stack-yaml=stack88.yaml'
136− - bash: stack build --only-dependencies --stack-yaml=stack88.yaml
137− displayName: 'stack build --only-dependencies --stack-yaml=stack88.yaml'
138− - bash: stack test --stack-yaml=stack88.yaml --ghc-options=-Werror || stack test --stack-yaml=stack88.yaml --ghc-options=-Werror || stack test --stack-yaml=stack88.yaml --ghc-options=-Werror
139− # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.
140− displayName: 'stack test --stack-yaml=stack88.yaml --ghc-options=-Werror'
141− - bash: |
142− mkdir -p .azure-cache
143− tar czf .azure-cache/stack-root.tar.gz -C $HOME .stack
144− displayName: "Pack cache"
145− - bash: |
146− set -euo pipefail
147− MESSAGE=$(git log --pretty=format:%s -n1)
148− curl -XPOST \
149− -i \
150− -H 'Content-type: application/json' \
151− --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \
152− $(Slack.URL)
153− condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))
154− - job: ghcide_stack_ghc_lib_88
155− timeoutInMinutes: 60
156− pool:
157− vmImage: 'ubuntu-latest'
158− steps:
159− - checkout: self
160− - task: CacheBeta@0
161− inputs:
162− key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/stack-ghc-lib.yaml | $(Build.SourcesDirectory)/ghcide.cabal
163− path: .azure-cache
164− cacheHitVar: CACHE_RESTORED
165− displayName: "Cache stack artifacts"
166− - bash: |
167− mkdir -p ~/.stack
168− tar xzf .azure-cache/stack-root.tar.gz -C $HOME
169− displayName: "Unpack cache"
170− condition: eq(variables.CACHE_RESTORED, 'true')
171− - bash: |
172− ./fmt.sh
173− displayName: "HLint via ./fmt.sh"
174− - bash: |
175− sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev
176− if ! which stack >/dev/null 2>&1; then
177− curl -sSL https://get.haskellstack.org/ | sh
178− fi
179− displayName: 'Install Stack'
180− - bash: stack setup --stack-yaml=stack-ghc-lib.yaml
181− displayName: 'stack setup --stack-yaml=stack-ghc-lib.yaml'
182− - bash: stack build --only-dependencies --stack-yaml=stack-ghc-lib.yaml
183− displayName: 'stack build --only-dependencies --stack-yaml=stack-ghc-lib.yaml'
184− - bash: stack test --stack-yaml=stack-ghc-lib.yaml --ghc-options=-Werror || stack test --stack-yaml=stack-ghc-lib.yaml --ghc-options=-Werror || stack test --stack-yaml=stack-ghc-lib.yaml --ghc-options=-Werror
185− # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.
186− displayName: 'stack test --stack-yaml=stack-ghc-lib.yaml --ghc-options=-Werror'
187− - bash: |
188− mkdir -p .azure-cache
189− tar czf .azure-cache/stack-root.tar.gz -C $HOME .stack
190− displayName: "Pack cache"
191− - bash: |
192− set -euo pipefail
193− MESSAGE=$(git log --pretty=format:%s -n1)
194− curl -XPOST \
195− -i \
196− -H 'Content-type: application/json' \
197− --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \
198− $(Slack.URL)
199− condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))
bench/Main.hsnew file+287
@@ -0,0 +1,287 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE ExistentialQuantification #-}
3+{-# LANGUAGE ImplicitParams #-}
4+
5+{- An automated benchmark built around the simple experiment described in:
6+
7+ > https://neilmitchell.blogspot.com/2020/05/fixing-space-leaks-in-ghcide.html
8+
9+ As an example project, it unpacks Cabal-3.2.0.0 in the local filesystem and
10+ loads the module 'Distribution.Simple'. The rationale for this choice is:
11+
12+ - It's convenient to download with `cabal unpack Cabal-3.2.0.0`
13+ - It has very few dependencies, and all are already needed to build ghcide
14+ - Distribution.Simple has 235 transitive module dependencies, so non trivial
15+
16+ The experiments are sequences of lsp commands scripted using lsp-test.
17+ A more refined approach would be to record and replay real IDE interactions,
18+ once the replay functionality is available in lsp-test.
19+ A more declarative approach would be to reuse ide-debug-driver:
20+
21+ > https://github.com/digital-asset/daml/blob/master/compiler/damlc/ide-debug-driver/README.md
22+
23+ The result of an experiment is a total duration in seconds after a preset
24+ number of iterations. There is ample room for improvement:
25+ - Statistical analysis to detect outliers and auto infer the number of iterations needed
26+ - GC stats analysis (currently -S is printed as part of the experiment)
27+ - Analyisis of performance over the commit history of the project
28+
29+ How to run:
30+ 1. `cabal bench`
31+ 2. `cabal exec <absolute-path-to-ghcide-bench> -- ghcide-bench-options`
32+
33+ Note that the package database influences the response times of certain actions,
34+ e.g. code actions, and therefore the two methods above do not necessarily
35+ produce the same results.
36+
37+ -}
38+
39+import Control.Applicative.Combinators
40+import Control.Concurrent
41+import Control.Exception.Safe
42+import Control.Monad.Extra
43+import Control.Monad.IO.Class
44+import Data.Aeson
45+import Data.List
46+import Data.Maybe
47+import Data.Version
48+import Language.Haskell.LSP.Test
49+import Language.Haskell.LSP.Types
50+import Language.Haskell.LSP.Types.Capabilities
51+import Numeric.Natural
52+import Options.Applicative
53+import System.Directory
54+import System.FilePath ((</>))
55+import System.Process
56+import System.Time.Extra
57+
58+-- Points to a string in the target file,
59+-- convenient for hygienic edits
60+hygienicP :: Position
61+hygienicP = Position 854 23
62+
63+-- Points to the middle of an identifier,
64+-- convenient for requesting goto-def, hover and completions
65+identifierP :: Position
66+identifierP = Position 853 12
67+
68+main :: IO ()
69+main = do
70+ config <- execParser $ info configP fullDesc
71+ let ?config = config
72+
73+ output "starting test"
74+
75+ cleanUp <- setup
76+
77+ runBenchmarks
78+ [ ---------------------------------------------------------------------------------------
79+ bench "hover" 10 $ \doc ->
80+ isJust <$> getHover doc identifierP,
81+ ---------------------------------------------------------------------------------------
82+ bench "getDefinition" 10 $ \doc ->
83+ not . null <$> getDefinitions doc identifierP,
84+ ---------------------------------------------------------------------------------------
85+ bench "documentSymbols" 100 $
86+ fmap (either (not . null) (not . null)) . getDocumentSymbols,
87+ ---------------------------------------------------------------------------------------
88+ bench "documentSymbols after edit" 100 $ \doc -> do
89+ let change =
90+ TextDocumentContentChangeEvent
91+ { _range = Just (Range hygienicP hygienicP),
92+ _rangeLength = Nothing,
93+ _text = " "
94+ }
95+ changeDoc doc [change]
96+ either (not . null) (not . null) <$> getDocumentSymbols doc,
97+ ---------------------------------------------------------------------------------------
98+ bench "completions after edit" 10 $ \doc -> do
99+ let change =
100+ TextDocumentContentChangeEvent
101+ { _range = Just (Range hygienicP hygienicP),
102+ _rangeLength = Nothing,
103+ _text = " "
104+ }
105+ changeDoc doc [change]
106+ not . null <$> getCompletions doc identifierP,
107+ ---------------------------------------------------------------------------------------
108+ benchWithSetup
109+ "code actions"
110+ 10
111+ ( \doc -> do
112+ let p = identifierP
113+ let change =
114+ TextDocumentContentChangeEvent
115+ { _range = Just (Range p p),
116+ _rangeLength = Nothing,
117+ _text = "a"
118+ }
119+ changeDoc doc [change]
120+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
121+ return p
122+ )
123+ ( \p doc -> do
124+ not . null <$> getCodeActions doc (Range p p)
125+ ),
126+ ---------------------------------------------------------------------------------------
127+ bench "code actions after edit" 10 $ \doc -> do
128+ let p = identifierP
129+ let change =
130+ TextDocumentContentChangeEvent
131+ { _range = Just (Range p p),
132+ _rangeLength = Nothing,
133+ _text = "a"
134+ }
135+ changeDoc doc [change]
136+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
137+ not . null <$> getCodeActions doc (Range p p)
138+ ]
139+ `finally` cleanUp
140+
141+---------------------------------------------------------------------------------------------
142+
143+examplePackageName :: String
144+examplePackageName = "Cabal"
145+
146+examplePackageVersion :: Version
147+examplePackageVersion = makeVersion [3, 2, 0, 0]
148+
149+examplePackage :: String
150+examplePackage = examplePackageName <> "-" <> showVersion examplePackageVersion
151+
152+exampleModulePath :: FilePath
153+exampleModulePath = "Distribution" </> "Simple.hs"
154+
155+examplesPath :: FilePath
156+examplesPath = "bench/example"
157+
158+data Config = Config
159+ { verbose :: !Bool,
160+ -- For some reason, the Shake profile files are truncated and won't load
161+ shakeProfiling :: !(Maybe FilePath),
162+ outputCSV :: !Bool
163+ }
164+
165+type HasConfig = (?config :: Config)
166+
167+configP :: Parser Config
168+configP = Config
169+ <$> (not <$> switch (long "quiet"))
170+ <*> optional (strOption (long "shake-profiling" <> metavar "PATH"))
171+ <*> switch (long "csv")
172+
173+output :: (MonadIO m, HasConfig) => String -> m ()
174+output = if verbose ?config then liftIO . putStrLn else (\_ -> pure ())
175+
176+---------------------------------------------------------------------------------------
177+
178+type Experiment = TextDocumentIdentifier -> Session Bool
179+
180+data Bench = forall setup.
181+ Bench
182+ { name :: !String,
183+ samples :: !Natural,
184+ benchSetup :: TextDocumentIdentifier -> Session setup,
185+ experiment :: setup -> Experiment
186+ }
187+
188+bench :: String -> Natural -> Experiment -> Bench
189+bench name samples userExperiment = Bench {..}
190+ where
191+ experiment () = userExperiment
192+ benchSetup _ = return ()
193+
194+benchWithSetup ::
195+ String ->
196+ Natural ->
197+ (TextDocumentIdentifier -> Session p) ->
198+ (p -> Experiment) ->
199+ Bench
200+benchWithSetup = Bench
201+
202+runBenchmarks :: HasConfig => [Bench] -> IO ()
203+runBenchmarks benchmarks = do
204+ results <- forM benchmarks $ \b -> (b,) <$> runBench b
205+
206+ forM_ results $ \(Bench {name, samples}, duration) ->
207+ output $
208+ "TOTAL "
209+ <> name
210+ <> " = "
211+ <> showDuration duration
212+ <> " ("
213+ <> show samples
214+ <> " repetitions)"
215+
216+ when (outputCSV ?config) $ do
217+ putStrLn $ intercalate ", " $ map name benchmarks
218+ putStrLn $ intercalate ", " $ map (showDuration . snd) results
219+
220+runBench :: HasConfig => Bench -> IO Seconds
221+runBench Bench {..} = handleAny (\e -> print e >> return (-1))
222+ $ runSessionWithConfig conf cmd lspTestCaps dir
223+ $ do
224+ doc <- openDoc exampleModulePath "haskell"
225+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
226+
227+ liftIO $ output $ "Running " <> name <> " benchmark"
228+ userState <- benchSetup doc
229+ let loop 0 = return True
230+ loop n = do
231+ (t, res) <- duration $ experiment userState doc
232+ if not res
233+ then return False
234+ else do
235+ output (showDuration t)
236+ loop (n -1)
237+
238+ (t, res) <- duration $ loop samples
239+
240+ exitServer
241+ -- sleeep to give ghcide a chance to print the RTS stats
242+ liftIO $ threadDelay 50000
243+
244+ return $ if res then t else -1
245+ where
246+ cmd =
247+ unwords $
248+ [ "ghcide",
249+ "--lsp",
250+ "--cwd",
251+ dir,
252+ "+RTS",
253+ "-S",
254+ "-RTS"
255+ ]
256+ ++ concat
257+ [ ["--shake-profiling", path]
258+ | Just path <- [shakeProfiling ?config]
259+ ]
260+ dir = "bench/example/" <> examplePackage
261+ lspTestCaps =
262+ fullCaps {_window = Just $ WindowClientCapabilities $ Just True}
263+ conf =
264+ defaultConfig
265+ { logStdErr = verbose ?config,
266+ logMessages = False,
267+ logColor = False
268+ }
269+
270+setup :: HasConfig => IO (IO ())
271+setup = do
272+ alreadyExists <- doesDirectoryExist examplesPath
273+ when alreadyExists $ removeDirectoryRecursive examplesPath
274+ callCommand $ "cabal get -v0 " <> examplePackage <> " -d " <> examplesPath
275+ writeFile
276+ (examplesPath </> examplePackage </> "hie.yaml")
277+ ("cradle: {cabal: {component: " <> show examplePackageName <> "}}")
278+
279+ whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True
280+
281+ return $ removeDirectoryRecursive examplesPath
282+
283+-- | Asks the server to shutdown and exit politely
284+exitServer :: Session ()
285+exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams
286+
287+--------------------------------------------------------------------------------------------
docs/Setup.md+38−1
@@ -54,8 +54,21 @@ with the following content:
54cradle: {cabal: {component: "mylibrary"}}
54cradle: {cabal: {component: "mylibrary"}}
55```
55```
56
56
57+If you are using stack, find the list of names you can use:
58+
59+ $ stack ide targets
60+ mypackage:lib
61+ mypackage:exe:mypackage-exe
62+ mypackage:test:mypackage-test
63+
64+and create a `hie.yaml` file as follows:
65+
66+ {stack: {component: "mypackage:lib"}}
67+
57## ghc: readCreateProcess: does not exist
68## ghc: readCreateProcess: does not exist
58
69
70+On Linux: try `stack exec ghcide`` instead of `ghcide` directly.
71+
59I was getting this in Windows: `ghcide.exe: ghc: readCreateProcess: does not exist (No such file or directory)`
72I was getting this in Windows: `ghcide.exe: ghc: readCreateProcess: does not exist (No such file or directory)`
60
73
61And we figured a hack around for this:
74And we figured a hack around for this:
@@ -69,7 +82,21 @@ Since I use stack. Required if you don't have a `ghc` on your path.
69
82
70## Could not find module ...
83## Could not find module ...
71
84
72−Try adding an explicit hie.yaml file and see if that helps.
85+Try adding an explicit `hie.yaml` file and see if that helps.
86+
87+## Ambiguous main module
88+
89+```console
90+$ stack exec ghcide
91+
92+...
93+
94+ghcide: CradleError (ExitFailure 1) ["Failed to parse result of calling stack","","* * * * * * * *","The main module to load is ambiguous. Candidates are: ","1. Package `mypackage' component mypackage:exe:mypackage-exe with main-is file: /home/user/mypackage/app/Main.hs","2. Package `mypackage' component mypackage:exe:otherbin-exe with main-is file: /home/user/mypackage/app/otherbin.hs","You can specify which one to pick by: "," * Specifying targets to stack ghci e.g. stack ghci mypackage:exe:mypackage-exe"," * Specifying what the main is e.g. stack ghci --main-is mypackage:exe:mypackage-exe"," * Choosing from the candidate above [1..2]","* * * * * * * *","","<stdin>: hGetLine: end of file"]
95+```
96+
97+Add a `hie.yaml` file to specify the module, e.g.
98+
99+ cradle: {stack: {component: "mypackage:exe:mypackage-exe"}}
73
100
74## Works in `ghcide` but not my editor
101## Works in `ghcide` but not my editor
75
102
@@ -106,3 +133,13 @@ find ~/.emacs.d -name '*.elc' -exec rm {} \;
106## Docker stack builds
133## Docker stack builds
107
134
108You're likely to see `ghcide: (ExitFailure 1,"","")`. Because ghcide can't get at the ghc installed inside Docker, your best bet is to `stack exec ghcide` and make sure `ghcide` is installed within the container. Full details at [issue 221](https://github.com/digital-asset/ghcide/issues/221).
135You're likely to see `ghcide: (ExitFailure 1,"","")`. Because ghcide can't get at the ghc installed inside Docker, your best bet is to `stack exec ghcide` and make sure `ghcide` is installed within the container. Full details at [issue 221](https://github.com/digital-asset/ghcide/issues/221).
136+
137+## stty error on Windows + Stack
138+
139+If you get an error like:
140+
141+```
142+ghcide.exe: CradleError (ExitFailure 1) ["Failed to parse result of calling stack","'stty' is not recognized as an internal or external command,","operable program or batch file."
143+```
144+
145+Then the workaround from https://github.com/haskell/haskell-ide-engine/issues/1428#issuecomment-547530794 might help.
exe/Arguments.hs+6
@@ -11,6 +11,9 @@ data Arguments = Arguments
11 ,argsCwd :: Maybe FilePath
11 ,argsCwd :: Maybe FilePath
12 ,argFiles :: [FilePath]
12 ,argFiles :: [FilePath]
13 ,argsVersion :: Bool
13 ,argsVersion :: Bool
14+ ,argsShakeProfiling :: Maybe FilePath
15+ ,argsTesting :: Bool
16+ ,argsThreads :: Int
14 }
17 }
15
18
16getArguments :: IO Arguments
19getArguments :: IO Arguments
@@ -27,3 +30,6 @@ arguments = Arguments
27 <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")
30 <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")
28 <*> many (argument str (metavar "FILES/DIRS..."))
31 <*> many (argument str (metavar "FILES/DIRS..."))
29 <*> switch (long "version" <> help "Show ghcide and GHC versions")
32 <*> switch (long "version" <> help "Show ghcide and GHC versions")
33+ <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")
34+ <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")
35+ <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault)
exe/Main.hs+566−81
@@ -2,18 +2,32 @@
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
3{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above
4{-# LANGUAGE CPP #-} -- To get precise GHC version
4{-# LANGUAGE CPP #-} -- To get precise GHC version
5+{-# LANGUAGE TemplateHaskell #-}
6+{-# LANGUAGE TypeFamilies #-}
5
7
6module Main(main) where
8module Main(main) where
7
9
10+import Linker (initDynLinker)
11+import Data.IORef
12+import NameCache
13+import Packages
14+import Module
8import Arguments
15import Arguments
9−import Data.Maybe
16+import Control.Concurrent.Async
10−import Data.List.Extra
11−import System.FilePath
12import Control.Concurrent.Extra
17import Control.Concurrent.Extra
13import Control.Exception
18import Control.Exception
14import Control.Monad.Extra
19import Control.Monad.Extra
20+import Control.Monad.IO.Class
15import Data.Default
21import Data.Default
16−import System.Time.Extra
22+import Data.Either
23+import Data.Function
24+import Data.List.Extra
25+import Data.Maybe
26+import qualified Data.Text as T
27+import qualified Data.Text.IO as T
28+import Data.Time.Clock (UTCTime)
29+import Data.Version
30+import Development.IDE.Core.Debouncer
17import Development.IDE.Core.FileStore
31import Development.IDE.Core.FileStore
18import Development.IDE.Core.OfInterest
32import Development.IDE.Core.OfInterest
19import Development.IDE.Core.Service
33import Development.IDE.Core.Service
@@ -26,34 +40,53 @@ import Development.IDE.Types.Diagnostics
26import Development.IDE.Types.Options
40import Development.IDE.Types.Options
27import Development.IDE.Types.Logger
41import Development.IDE.Types.Logger
28import Development.IDE.GHC.Util
42import Development.IDE.GHC.Util
29−import qualified Data.Text as T
43+import Development.IDE.Plugin
44+import Development.IDE.Plugin.Completions as Completions
45+import Development.IDE.Plugin.CodeAction as CodeAction
30−import qualified Data.Text.IO as T
46+import qualified Language.Haskell.LSP.Core as LSP
31import Language.Haskell.LSP.Messages
47import Language.Haskell.LSP.Messages
32−import Language.Haskell.LSP.Types (LspId(IdInt))
48+import Language.Haskell.LSP.Types
33−import Linker
34−import Data.Version
49+import Data.Aeson (ToJSON(toJSON))
35import Development.IDE.LSP.LanguageServer
50import Development.IDE.LSP.LanguageServer
36−import System.Directory.Extra as IO
51+import qualified System.Directory.Extra as IO
37import System.Environment
52import System.Environment
38import System.IO
53import System.IO
39import System.Exit
54import System.Exit
55+import System.FilePath
56+import System.Directory
57+import System.Time.Extra
58+import HIE.Bios.Environment (addCmdOpts, makeDynFlagsAbsolute)
40import Paths_ghcide
59import Paths_ghcide
41−import Development.Shake hiding (Env)
60+import Development.GitRev
61+import Development.Shake (Action, action)
42−import qualified Data.Set as Set
62+import qualified Data.HashSet as HashSet
63+import qualified Data.HashMap.Strict as HM
43import qualified Data.Map.Strict as Map
64import qualified Data.Map.Strict as Map
44−
65+import qualified Crypto.Hash.SHA1 as H
66+import qualified Data.ByteString.Char8 as B
67+import Data.ByteString.Base16 (encode)
68+import DynFlags (gopt_set, gopt_unset, updOptLevel, PackageFlag(..), PackageArg(..))
69+import GhcMonad
70+import HscTypes (HscEnv(..), ic_dflags)
45import GHC hiding (def)
71import GHC hiding (def)
46−import qualified GHC.Paths
72+import GHC.Check ( VersionCheck(..), makeGhcVersionChecker )
73+import Data.Either.Extra
47
74
48−import HIE.Bios
75+import HIE.Bios.Cradle
76+import HIE.Bios.Types
49
77
50−-- Set the GHC libdir to the nix libdir if it's present.
78+import Utils
51−getLibdir :: IO FilePath
52−getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
53
79
54−ghcideVersion :: String
80+ghcideVersion :: IO String
81+ghcideVersion = do
82+ path <- getExecutablePath
83+ let gitHashSection = case $(gitHash) of
84+ x | x == "UNKNOWN" -> ""
85+ x -> " (GIT hash: " <> x <> ")"
55−ghcideVersion = "ghcide version: " <> showVersion version
86+ return $ "ghcide version: " <> showVersion version
56− <> " (GHC: " <> VERSION_ghc <> ")"
87+ <> " (GHC: " <> VERSION_ghc
88+ <> ") (PATH: " <> path <> ")"
89+ <> gitHashSection
57
90
58main :: IO ()
91main :: IO ()
59main = do
92main = do
@@ -61,72 +94,76 @@ main = do
61 -- then the language server will not work
94 -- then the language server will not work
62 Arguments{..} <- getArguments
95 Arguments{..} <- getArguments
63
96
64− if argsVersion then putStrLn ghcideVersion >> exitSuccess
97+ if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess
65− else hPutStrLn stderr {- see WARNING above -} ghcideVersion
98+ else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion
66
99
67 -- lock to avoid overlapping output on stdout
100 -- lock to avoid overlapping output on stdout
68 lock <- newLock
101 lock <- newLock
69 let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
102 let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
70 T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
103 T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
71
104
72− whenJust argsCwd setCurrentDirectory
105+ whenJust argsCwd IO.setCurrentDirectory
73
106
74− dir <- getCurrentDirectory
107+ dir <- IO.getCurrentDirectory
108+ command <- makeLspCommandId "typesignature.add"
109+
110+ let plugins = Completions.plugin <> CodeAction.plugin
111+ onInitialConfiguration = const $ Right ()
112+ onConfigurationChange = const $ Right ()
113+ options = def { LSP.executeCommandCommands = Just [command]
114+ , LSP.completionTriggerCharacters = Just "."
115+ }
75
116
76 if argLSP then do
117 if argLSP then do
77 t <- offsetTime
118 t <- offsetTime
78 hPutStrLn stderr "Starting LSP server..."
119 hPutStrLn stderr "Starting LSP server..."
79− hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcidie WITHOUT the --lsp option!"
120+ hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
80− runLanguageServer def def $ \getLspId event vfs caps -> do
121+ runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do
81 t <- t
122 t <- t
82 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
123 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
83− -- very important we only call loadSession once, and it's fast, so just do it before starting
84− session <- loadSession dir
85− let options = (defaultIdeOptions $ return session)
124+ let options = (defaultIdeOptions $ loadSessionShake dir)
86− { optReportProgress = clientSupportsProgress caps }
125+ { optReportProgress = clientSupportsProgress caps
126+ , optShakeProfiling = argsShakeProfiling
127+ , optTesting = argsTesting
128+ , optThreads = argsThreads
129+ }
130+ debouncer <- newAsyncDebouncer
131+ initialise caps (mainRule >> pluginRules plugins >> action kick)
87− initialise (mainRule >> action kick) getLspId event (logger minBound) options vfs
132+ getLspId event (logger minBound) debouncer options vfs
88 else do
133 else do
134+ -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
135+ hSetEncoding stdout utf8
136+ hSetEncoding stderr utf8
137+
89 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
138 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
90 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
139 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
91
140
92− putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir
141+ putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir
93− files <- nubOrd <$> expandFiles (argFiles ++ ["." | null argFiles])
142+ files <- expandFiles (argFiles ++ ["." | null argFiles])
143+ -- LSP works with absolute file paths, so try and behave similarly
144+ files <- nubOrd <$> mapM IO.canonicalizePath files
94 putStrLn $ "Found " ++ show (length files) ++ " files"
145 putStrLn $ "Found " ++ show (length files) ++ " files"
95
146
96− putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"
147+ putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup"
97 cradles <- mapM findCradle files
148 cradles <- mapM findCradle files
98 let ucradles = nubOrd cradles
149 let ucradles = nubOrd cradles
99 let n = length ucradles
150 let n = length ucradles
100 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
151 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
101− sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do
102− let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x
103− putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg
104− cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x
105− when (isNothing x) $ print cradle
106− putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"
107− cradleToSession cradle
108−
109− putStrLn "\nStep 5/6: Initializing the IDE"
152+ putStrLn "\nStep 3/4: Initializing the IDE"
110 vfs <- makeVFSHandle
153 vfs <- makeVFSHandle
111− let cradlesToSessions = Map.fromList $ zip ucradles sessions
154+ debouncer <- newAsyncDebouncer
112− let filesToCradles = Map.fromList $ zip files cradles
113− let grab file = fromMaybe (head sessions) $ do
114− cradle <- Map.lookup file filesToCradles
115− Map.lookup cradle cradlesToSessions
116− ide <- initialise mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) (defaultIdeOptions $ return $ return . grab) vfs
155+ ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs
117−
156+
118− putStrLn "\nStep 6/6: Type checking the files"
157+ putStrLn "\nStep 4/4: Type checking the files"
119− setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files
158+ setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
120− results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files
159+ results <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath' files)
121 let (worked, failed) = partition fst $ zip (map isJust results) files
160 let (worked, failed) = partition fst $ zip (map isJust results) files
122 when (failed /= []) $
161 when (failed /= []) $
123 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
162 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
124
163
125 let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
164 let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
126 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
165 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
127−
166+ return ()
128− unless (null failed) exitFailure
129−
130
167
131expandFiles :: [FilePath] -> IO [FilePath]
168expandFiles :: [FilePath] -> IO [FilePath]
132expandFiles = concatMapM $ \x -> do
169expandFiles = concatMapM $ \x -> do
@@ -135,7 +172,7 @@ expandFiles = concatMapM $ \x -> do
135 let recurse "." = True
172 let recurse "." = True
136 recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
173 recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
137 recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
174 recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
138− files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> listFilesInside (return . recurse) x
175+ files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x
139 when (null files) $
176 when (null files) $
140 fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
177 fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
141 return files
178 return files
@@ -144,42 +181,414 @@ expandFiles = concatMapM $ \x -> do
144kick :: Action ()
181kick :: Action ()
145kick = do
182kick = do
146 files <- getFilesOfInterest
183 files <- getFilesOfInterest
147− void $ uses TypeCheck $ Set.toList files
184+ void $ uses TypeCheck $ HashSet.toList files
148
185
149-- | Print an LSP event.
186-- | Print an LSP event.
150showEvent :: Lock -> FromServerMessage -> IO ()
187showEvent :: Lock -> FromServerMessage -> IO ()
151showEvent _ (EventFileDiagnostics _ []) = return ()
188showEvent _ (EventFileDiagnostics _ []) = return ()
152−showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
189+showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =
153− withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,) diags
190+ withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
154showEvent lock e = withLock lock $ print e
191showEvent lock e = withLock lock $ print e
155
192
156
193
157−cradleToSession :: Cradle -> IO HscEnvEq
194+-- | Run the specific cradle on a specific FilePath via hie-bios.
158−cradleToSession cradle = do
195+cradleToSessionOpts :: Cradle a -> FilePath -> IO (Either [CradleError] ComponentOptions)
159− opts <- either throwIO return =<< getCompilerOptions "" cradle
196+cradleToSessionOpts cradle file = do
197+ let showLine s = putStrLn ("> " ++ s)
198+ cradleRes <- runCradle (cradleOptsProg cradle) showLine file
199+ case cradleRes of
200+ CradleSuccess r -> pure (Right r)
201+ CradleFail err -> return (Left [err])
202+ -- For the None cradle perhaps we still want to report an Info
203+ -- message about the fact that the file is being ignored.
204+ CradleNone -> return (Left [])
205+
206+emptyHscEnv :: IO HscEnv
207+emptyHscEnv = do
160 libdir <- getLibdir
208 libdir <- getLibdir
161− env <- runGhc (Just libdir) $ do
209+ env <- runGhc (Just libdir) getSession
162− _targets <- initSession opts
163− getSession
164 initDynLinker env
210 initDynLinker env
165− newHscEnvEq env
211+ pure env
212+
213+-- | Convert a target to a list of potential absolute paths.
214+-- A TargetModule can be anywhere listed by the supplied include
215+-- directories
216+-- A target file is a relative path but with a specific prefix so just need
217+-- to canonicalise it.
218+targetToFile :: [FilePath] -> TargetId -> IO [NormalizedFilePath]
219+targetToFile is (TargetModule mod) = do
220+ let fps = [i </> moduleNameSlashes mod -<.> ext | ext <- exts, i <- is ]
221+ exts = ["hs", "hs-boot", "lhs"]
222+ mapM (fmap toNormalizedFilePath' . canonicalizePath) fps
223+targetToFile _ (TargetFile f _) = do
224+ f' <- canonicalizePath f
225+ return [toNormalizedFilePath' f']
226+
227+setNameCache :: IORef NameCache -> HscEnv -> HscEnv
228+setNameCache nc hsc = hsc { hsc_NC = nc }
229+
230+loadSessionShake :: FilePath -> Action (FilePath -> Action (IdeResult HscEnvEq))
231+loadSessionShake fp = do
232+ se <- getShakeExtras
233+ IdeOptions{optTesting} <- getIdeOptions
234+ res <- liftIO $ loadSession optTesting se fp
235+ return (fmap liftIO res)
236+
237+-- | This is the key function which implements multi-component support. All
238+-- components mapping to the same hie.yaml file are mapped to the same
239+-- HscEnv which is updated as new components are discovered.
240+loadSession :: Bool -> ShakeExtras -> FilePath -> IO (FilePath -> IO (IdeResult HscEnvEq))
241+loadSession optTesting ShakeExtras{logger, eventer} dir = do
242+ -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
243+ hscEnvs <- newVar Map.empty :: IO (Var HieMap)
244+ -- Mapping from a Filepath to HscEnv
245+ fileToFlags <- newVar Map.empty :: IO (Var FlagsMap)
246+
247+ -- This caches the mapping from Mod.hs -> hie.yaml
248+ cradleLoc <- memoIO $ \v -> do
249+ res <- findCradle v
250+ -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
251+ -- try and normalise that
252+ -- e.g. see https://github.com/digital-asset/ghcide/issues/126
253+ res' <- traverse IO.makeAbsolute res
254+ return $ normalise <$> res'
255+
256+ -- Create a new HscEnv from a hieYaml root and a set of options
257+ -- If the hieYaml file already has an HscEnv, the new component is
258+ -- combined with the components in the old HscEnv into a new HscEnv
259+ -- which contains the union.
260+ let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions)
261+ -> IO (HscEnv, ComponentInfo, [ComponentInfo])
262+ packageSetup (hieYaml, cfp, opts) = do
263+ -- Parse DynFlags for the newly discovered component
264+ hscEnv <- emptyHscEnv
265+ (df, targets) <- evalGhcEnv hscEnv $
266+ setOptions opts (hsc_dflags hscEnv)
267+ dep_info <- getDependencyInfo (componentDependencies opts ++ maybeToList hieYaml)
268+ -- Now lookup to see whether we are combining with an existing HscEnv
269+ -- or making a new one. The lookup returns the HscEnv and a list of
270+ -- information about other components loaded into the HscEnv
271+ -- (unitId, DynFlag, Targets)
272+ modifyVar hscEnvs $ \m -> do
273+ -- Just deps if there's already an HscEnv
274+ -- Nothing is it's the first time we are making an HscEnv
275+ let oldDeps = Map.lookup hieYaml m
276+ let -- Add the raw information about this component to the list
277+ -- We will modify the unitId and DynFlags used for
278+ -- compilation but these are the true source of
279+ -- information.
280+ new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info
281+ : maybe [] snd oldDeps
282+ -- Get all the unit-ids for things in this component
283+ inplace = map rawComponentUnitId new_deps
284+
285+ new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do
286+ -- Remove all inplace dependencies from package flags for
287+ -- components in this HscEnv
288+ let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags
289+ let prefix = show rawComponentUnitId
290+ -- See Note [Avoiding bad interface files]
291+ processed_df <- setCacheDir logger prefix (sort $ map show uids) opts df2
292+ -- The final component information, mostly the same but the DynFlags don't
293+ -- contain any packages which are also loaded
294+ -- into the same component.
295+ pure $ ComponentInfo rawComponentUnitId
296+ processed_df
297+ uids
298+ rawComponentTargets
299+ rawComponentFP
300+ rawComponentCOptions
301+ rawComponentDependencyInfo
302+ -- Make a new HscEnv, we have to recompile everything from
303+ -- scratch again (for now)
304+ -- It's important to keep the same NameCache though for reasons
305+ -- that I do not fully understand
306+ logInfo logger (T.pack ("Making new HscEnv" ++ show inplace))
307+ hscEnv <- case oldDeps of
308+ Nothing -> emptyHscEnv
309+ Just (old_hsc, _) -> setNameCache (hsc_NC old_hsc) <$> emptyHscEnv
310+ newHscEnv <-
311+ -- Add the options for the current component to the HscEnv
312+ evalGhcEnv hscEnv $ do
313+ _ <- setSessionDynFlags df
314+ getSession
315+ -- Modify the map so the hieYaml now maps to the newly created
316+ -- HscEnv
317+ -- Returns
318+ -- . the new HscEnv so it can be used to modify the
319+ -- FilePath -> HscEnv map (fileToFlags)
320+ -- . The information for the new component which caused this cache miss
321+ -- . The modified information (without -inplace flags) for
322+ -- existing packages
323+ pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps'))
324+
325+ let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> IO (IdeResult HscEnvEq)
326+ session (hieYaml, cfp, opts) = do
327+ (hscEnv, new, old_deps) <- packageSetup (hieYaml, cfp, opts)
328+ -- Make a map from unit-id to DynFlags, this is used when trying to
329+ -- resolve imports. (especially PackageImports)
330+ let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps)
331+
332+ -- For each component, now make a new HscEnvEq which contains the
333+ -- HscEnv for the hie.yaml file but the DynFlags for that component
334+
335+ -- New HscEnv for the component in question, returns the new HscEnvEq and
336+ -- a mapping from FilePath to the newly created HscEnvEq.
337+ let new_cache = newComponentCache logger hscEnv uids
338+ (cs, res) <- new_cache new
339+ -- Modified cache targets for everything else in the hie.yaml file
340+ -- which now uses the same EPS and so on
341+ cached_targets <- concatMapM (fmap fst . new_cache) old_deps
342+ modifyVar_ fileToFlags $ \var -> do
343+ pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var
344+
345+ return (fst res)
346+
347+ let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq)
348+ consultCradle hieYaml cfp = do
349+ when optTesting $ eventer $ notifyCradleLoaded cfp
350+ logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp)
351+ cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml
352+ eopts <- cradleToSessionOpts cradle cfp
353+ logDebug logger $ T.pack ("Session loading result: " <> show eopts)
354+ case eopts of
355+ -- The cradle gave us some options so get to work turning them
356+ -- into and HscEnv.
357+ Right opts -> do
358+ session (hieYaml, toNormalizedFilePath' cfp, opts)
359+ -- Failure case, either a cradle error or the none cradle
360+ Left err -> do
361+ dep_info <- getDependencyInfo (maybeToList hieYaml)
362+ let ncfp = toNormalizedFilePath' cfp
363+ let res = (map (renderCradleError ncfp) err, Nothing)
364+ modifyVar_ fileToFlags $ \var -> do
365+ pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var
366+ return res
367+
368+ -- This caches the mapping from hie.yaml + Mod.hs -> [String]
369+ let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq)
370+ sessionOpts (hieYaml, file) = do
371+ v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags
372+ cfp <- canonicalizePath file
373+ case HM.lookup (toNormalizedFilePath' cfp) v of
374+ Just (opts, old_di) -> do
375+ deps_ok <- checkDependencyInfo old_di
376+ if not deps_ok
377+ then do
378+ -- If the dependencies are out of date then clear both caches and start
379+ -- again.
380+ modifyVar_ fileToFlags (const (return Map.empty))
381+ -- Keep the same name cache
382+ modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml )
383+ consultCradle hieYaml cfp
384+ else return opts
385+ Nothing -> consultCradle hieYaml cfp
166
386
387+ dummyAs <- async $ return (error "Uninitialised")
388+ runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq)))
389+ -- The main function which gets options for a file. We only want one of these running
390+ -- at a time. Therefore the IORef contains the currently running cradle, if we try
391+ -- to get some more options then we wait for the currently running action to finish
392+ -- before attempting to do so.
393+ let getOptions :: FilePath -> IO (IdeResult HscEnvEq)
394+ getOptions file = do
395+ hieYaml <- cradleLoc file
396+ sessionOpts (hieYaml, file)
397+ return $ \file -> do
398+ join $ mask_ $ modifyVar runningCradle $ \as -> do
399+ -- If the cradle is not finished, then wait for it to finish.
400+ void $ wait as
401+ as <- async $ getOptions file
402+ return (as, wait as)
167
403
168−loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq)
169−loadSession dir = do
170− cradleLoc <- memoIO $ \v -> do
171− res <- findCradle v
172− -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
173− -- try and normalise that
174− -- e.g. see https://github.com/digital-asset/ghcide/issues/126
175− res' <- traverse makeAbsolute res
176− return $ normalise <$> res'
177− session <- memoIO $ \file -> do
178− c <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file
179− cradleToSession c
180− return $ \file -> liftIO $ session =<< cradleLoc file
181
404
182
405
406+-- | Create a mapping from FilePaths to HscEnvEqs
407+newComponentCache
408+ :: Logger
409+ -> HscEnv
410+ -> [(InstalledUnitId, DynFlags)]
411+ -> ComponentInfo
412+ -> IO ([(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))], (IdeResult HscEnvEq, DependencyInfo))
413+newComponentCache logger hsc_env uids ci = do
414+ let df = componentDynFlags ci
415+ let hscEnv' = hsc_env { hsc_dflags = df
416+ , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } }
417+
418+ versionMismatch <- checkGhcVersion
419+ henv <- case versionMismatch of
420+ Just mismatch -> return mismatch
421+ Nothing -> newHscEnvEq hscEnv' uids
422+ let res = (([], Just henv), componentDependencyInfo ci)
423+ logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res))
424+
425+ let is = importPaths df
426+ ctargets <- concatMapM (targetToFile is . targetId) (componentTargets ci)
427+ -- A special target for the file which caused this wonderful
428+ -- component to be created. In case the cradle doesn't list all the targets for
429+ -- the component, in which case things will be horribly broken anyway.
430+ -- Otherwise, we will immediately attempt to reload this module which
431+ -- causes an infinite loop and high CPU usage.
432+ let special_target = (componentFP ci, res)
433+ let xs = map (,res) ctargets
434+ return (special_target:xs, res)
435+
436+{- Note [Avoiding bad interface files]
437+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
438+Originally, we set the cache directory for the various components once
439+on the first occurrence of the component.
440+This works fine if these components have no references to each other,
441+but you have components that depend on each other, the interface files are
442+updated for each component.
443+After restarting the session and only opening the component that depended
444+on the other, suddenly the interface files of this component are stale.
445+However, from the point of view of `ghcide`, they do not look stale,
446+thus, not regenerated and the IDE shows weird errors such as:
447+```
448+typecheckIface
449+Declaration for Rep_ClientRunFlags
450+Axiom branches Rep_ClientRunFlags:
451+ Failed to load interface for ‘Distribution.Simple.Flag’
452+ Use -v to see a list of the files searched for.
453+```
454+and
455+```
456+expectJust checkFamInstConsistency
457+CallStack (from HasCallStack):
458+ error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes
459+ expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst
460+```
461+
462+To mitigate this, we set the cache directory for each component dependent
463+on the components of the current `HscEnv`, additionally to the component options
464+of the respective components.
465+Assume two components, c1, c2, where c2 depends on c1, and the options of the
466+respective components are co1, co2.
467+If we want to load component c2, followed by c1, we set the cache directory for
468+each component in this way:
469+
470+ * Load component c2
471+ * (Cache Directory State)
472+ - name of c2 + co2
473+ * Load component c1
474+ * (Cache Directory State)
475+ - name of c2 + name of c1 + co2
476+ - name of c2 + name of c1 + co1
477+
478+Overall, we created three cache directories. If we opened c1 first, then we
479+create a fourth cache directory.
480+This makes sure that interface files are always correctly updated.
481+
482+Since this causes a lot of recompilation, we only update the cache-directory,
483+if the dependencies of a component have really changed.
484+E.g. when you load two executables, they can not depend on each other. They
485+should be filtered out, such that we dont have to re-compile everything.
486+-}
487+
488+-- | Set the cache-directory based on the ComponentOptions and a list of
489+-- internal packages.
490+-- For the exact reason, see Note [Avoiding bad interface files].
491+setCacheDir :: MonadIO m => Logger -> String -> [String] -> ComponentOptions -> DynFlags -> m DynFlags
492+setCacheDir logger prefix hscComponents comps dflags = do
493+ cacheDir <- liftIO $ getCacheDir prefix (hscComponents ++ componentOptions comps)
494+ liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack cacheDir
495+ pure $ dflags
496+ & setHiDir cacheDir
497+ & setDefaultHieDir cacheDir
498+
499+
500+renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic
501+renderCradleError nfp (CradleError _ec t) =
502+ ideErrorText nfp (T.unlines (map T.pack t))
503+
504+-- See Note [Multi Cradle Dependency Info]
505+type DependencyInfo = Map.Map FilePath (Maybe UTCTime)
506+type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo])
507+type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))
508+
509+-- This is pristine information about a component
510+data RawComponentInfo = RawComponentInfo
511+ { rawComponentUnitId :: InstalledUnitId
512+ -- | Unprocessed DynFlags. Contains inplace packages such as libraries.
513+ -- We do not want to use them unprocessed.
514+ , rawComponentDynFlags :: DynFlags
515+ -- | All targets of this components.
516+ , rawComponentTargets :: [Target]
517+ -- | Filepath which caused the creation of this component
518+ , rawComponentFP :: NormalizedFilePath
519+ -- | Component Options used to load the component.
520+ , rawComponentCOptions :: ComponentOptions
521+ -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file
522+ -- to last modification time. See Note [Multi Cradle Dependency Info].
523+ , rawComponentDependencyInfo :: DependencyInfo
524+ }
525+
526+-- This is processed information about the component, in particular the dynflags will be modified.
527+data ComponentInfo = ComponentInfo
528+ { componentUnitId :: InstalledUnitId
529+ -- | Processed DynFlags. Does not contain inplace packages such as local
530+ -- libraries. Can be used to actually load this Component.
531+ , componentDynFlags :: DynFlags
532+ -- | Internal units, such as local libraries, that this component
533+ -- is loaded with. These have been extracted from the original
534+ -- ComponentOptions.
535+ , componentInternalUnits :: [InstalledUnitId]
536+ -- | All targets of this components.
537+ , componentTargets :: [Target]
538+ -- | Filepath which caused the creation of this component
539+ , componentFP :: NormalizedFilePath
540+ -- | Component Options used to load the component.
541+ , componentCOptions :: ComponentOptions
542+ -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file
543+ -- to last modification time. See Note [Multi Cradle Dependency Info]
544+ , componentDependencyInfo :: DependencyInfo
545+ }
546+
547+-- | Check if any dependency has been modified lately.
548+checkDependencyInfo :: DependencyInfo -> IO Bool
549+checkDependencyInfo old_di = do
550+ di <- getDependencyInfo (Map.keys old_di)
551+ return (di == old_di)
552+
553+-- Note [Multi Cradle Dependency Info]
554+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
555+-- Why do we implement our own file modification tracking here?
556+-- The primary reason is that the custom caching logic is quite complicated and going into shake
557+-- adds even more complexity and more indirection. I did try for about 5 hours to work out how to
558+-- use shake rules rather than IO but eventually gave up.
559+
560+-- | Computes a mapping from a filepath to its latest modification date.
561+-- See Note [Multi Cradle Dependency Info] why we do this ourselves instead
562+-- of letting shake take care of it.
563+getDependencyInfo :: [FilePath] -> IO DependencyInfo
564+getDependencyInfo fs = Map.fromList <$> mapM do_one fs
565+
566+ where
567+ tryIO :: IO a -> IO (Either IOException a)
568+ tryIO = try
569+
570+ do_one :: FilePath -> IO (FilePath, Maybe UTCTime)
571+ do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp)
572+
573+-- | This function removes all the -package flags which refer to packages we
574+-- are going to deal with ourselves. For example, if a executable depends
575+-- on a library component, then this function will remove the library flag
576+-- from the package flags for the executable
577+--
578+-- There are several places in GHC (for example the call to hptInstances in
579+-- tcRnImports) which assume that all modules in the HPT have the same unit
580+-- ID. Therefore we create a fake one and give them all the same unit id.
581+removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId])
582+removeInplacePackages us df = (df { packageFlags = ps
583+ , thisInstalledUnitId = fake_uid }, uids)
584+ where
585+ (uids, ps) = partitionEithers (map go (packageFlags df))
586+ fake_uid = toInstalledUnitId (stringToUnitId "fake_uid")
587+ go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us
588+ then Left (toInstalledUnitId u)
589+ else Right p
590+ go p = Right p
591+
183-- | Memoize an IO function, with the characteristics:
592-- | Memoize an IO function, with the characteristics:
184--
593--
185-- * If multiple people ask for a result simultaneously, make sure you only compute it once.
594-- * If multiple people ask for a result simultaneously, make sure you only compute it once.
@@ -196,3 +605,79 @@ memoIO op = do
196 res <- onceFork $ op k
605 res <- onceFork $ op k
197 return (Map.insert k res mp, res)
606 return (Map.insert k res mp, res)
198 Just res -> return (mp, res)
607 Just res -> return (mp, res)
608+
609+setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [Target])
610+setOptions (ComponentOptions theOpts compRoot _) dflags = do
611+ (dflags', targets) <- addCmdOpts theOpts dflags
612+ let dflags'' =
613+ -- disabled, generated directly by ghcide instead
614+ flip gopt_unset Opt_WriteInterface $
615+ -- disabled, generated directly by ghcide instead
616+ -- also, it can confuse the interface stale check
617+ dontWriteHieFiles $
618+ setIgnoreInterfacePragmas $
619+ setLinkerOptions $
620+ disableOptimisation $
621+ makeDynFlagsAbsolute compRoot dflags'
622+ -- initPackages parses the -package flags and
623+ -- sets up the visibility for each component.
624+ (final_df, _) <- liftIO $ initPackages dflags''
625+ return (final_df, targets)
626+
627+
628+-- we don't want to generate object code so we compile to bytecode
629+-- (HscInterpreted) which implies LinkInMemory
630+-- HscInterpreted
631+setLinkerOptions :: DynFlags -> DynFlags
632+setLinkerOptions df = df {
633+ ghcLink = LinkInMemory
634+ , hscTarget = HscNothing
635+ , ghcMode = CompManager
636+ }
637+
638+setIgnoreInterfacePragmas :: DynFlags -> DynFlags
639+setIgnoreInterfacePragmas df =
640+ gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges
641+
642+disableOptimisation :: DynFlags -> DynFlags
643+disableOptimisation df = updOptLevel 0 df
644+
645+setHiDir :: FilePath -> DynFlags -> DynFlags
646+setHiDir f d =
647+ -- override user settings to avoid conflicts leading to recompilation
648+ d { hiDir = Just f}
649+
650+getCacheDir :: String -> [String] -> IO FilePath
651+getCacheDir prefix opts = IO.getXdgDirectory IO.XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)
652+ where
653+ -- Create a unique folder per set of different GHC options, assuming that each different set of
654+ -- GHC options will create incompatible interface files.
655+ opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts)
656+
657+-- | Sub directory for the cache path
658+cacheDir :: String
659+cacheDir = "ghcide"
660+
661+notifyCradleLoaded :: FilePath -> FromServerMessage
662+notifyCradleLoaded fp =
663+ NotCustomServer $
664+ NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $
665+ toJSON fp
666+
667+cradleLoadedMethod :: T.Text
668+cradleLoadedMethod = "ghcide/cradle/loaded"
669+
670+ghcVersionChecker :: IO VersionCheck
671+ghcVersionChecker = $$(makeGhcVersionChecker (pure <$> getLibdir))
672+
673+checkGhcVersion :: IO (Maybe HscEnvEq)
674+checkGhcVersion = do
675+ res <- ghcVersionChecker
676+ case res of
677+ Failure err -> do
678+ putStrLn $ "Error while checking GHC version: " ++ show err
679+ return Nothing
680+ Mismatch {..} ->
681+ return $ Just GhcVersionMismatch {..}
682+ _ ->
683+ return Nothing
exe/Utils.hsnew file+9
@@ -0,0 +1,9 @@
1+module Utils (getLibdir) where
2+
3+import qualified GHC.Paths
4+import System.Environment
5+import Data.Maybe
6+
7+-- Set the GHC libdir to the nix libdir if it's present.
8+getLibdir :: IO FilePath
9+getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
fmt.sh+1−1
@@ -1,3 +1,3 @@
1#!/usr/bin/env bash
1#!/usr/bin/env bash
2set -eou pipefail
2set -eou pipefail
3−curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s .
3+curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s . --with-group=extra
ghcide.cabal+156−19
@@ -2,12 +2,12 @@ cabal-version: 1.20
2build-type: Simple
2build-type: Simple
3category: Development
3category: Development
4name: ghcide
4name: ghcide
5−version: 0.0.5
5+version: 0.2.0
6license: Apache-2.0
6license: Apache-2.0
7license-file: LICENSE
7license-file: LICENSE
8author: Digital Asset
8author: Digital Asset
9maintainer: Digital Asset
9maintainer: Digital Asset
10−copyright: Digital Asset 2018-2019
10+copyright: Digital Asset 2018-2020
11synopsis: The core of an IDE
11synopsis: The core of an IDE
12description:
12description:
13 A library for building Haskell IDE's on top of the GHC API.
13 A library for building Haskell IDE's on top of the GHC API.
@@ -15,7 +15,13 @@ homepage: https://github.com/digital-asset/ghcide#readme
15bug-reports: https://github.com/digital-asset/ghcide/issues
15bug-reports: https://github.com/digital-asset/ghcide/issues
16tested-with: GHC==8.6.5
16tested-with: GHC==8.6.5
17extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md
17extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md
18− test/data/GotoHover.hs
18+ test/data/hover/*.hs
19+ test/data/multi/cabal.project
20+ test/data/multi/hie.yaml
21+ test/data/multi/a/a.cabal
22+ test/data/multi/a/*.hs
23+ test/data/multi/b/b.cabal
24+ test/data/multi/b/*.hs
19
25
20source-repository head
26source-repository head
21 type: git
27 type: git
@@ -30,6 +36,7 @@ library
30 default-language: Haskell2010
36 default-language: Haskell2010
31 build-depends:
37 build-depends:
32 aeson,
38 aeson,
39+ array,
33 async,
40 async,
34 base == 4.*,
41 base == 4.*,
35 binary,
42 binary,
@@ -39,25 +46,28 @@ library
39 deepseq,
46 deepseq,
40 directory,
47 directory,
41 extra,
48 extra,
49+ fuzzy,
42 filepath,
50 filepath,
51+ haddock-library >= 1.8,
43 hashable,
52 hashable,
44− haskell-lsp-types >= 0.18,
53+ haskell-lsp-types == 0.22.*,
45− haskell-lsp >= 0.18,
54+ haskell-lsp == 0.22.*,
46 mtl,
55 mtl,
47 network-uri,
56 network-uri,
48 prettyprinter-ansi-terminal,
57 prettyprinter-ansi-terminal,
49 prettyprinter-ansi-terminal,
58 prettyprinter-ansi-terminal,
50 prettyprinter,
59 prettyprinter,
60+ regex-tdfa >= 1.3.1.0,
51 rope-utf16-splay,
61 rope-utf16-splay,
52 safe-exceptions,
62 safe-exceptions,
53− shake >= 0.17.5,
63+ shake >= 0.18.4,
54 sorted-list,
64 sorted-list,
55 stm,
65 stm,
56 syb,
66 syb,
57 text,
67 text,
58 time,
68 time,
59 transformers,
69 transformers,
60− unordered-containers,
70+ unordered-containers >= 0.2.10.0,
61 utf8-string,
71 utf8-string,
62 hslogger
72 hslogger
63 if flag(ghc-lib)
73 if flag(ghc-lib)
@@ -70,7 +80,10 @@ library
70 ghc-boot-th,
80 ghc-boot-th,
71 ghc-boot,
81 ghc-boot,
72 ghc >= 8.4
82 ghc >= 8.4
73− if !os(windows)
83+ if os(windows)
84+ build-depends:
85+ Win32
86+ else
74 build-depends:
87 build-depends:
75 unix
88 unix
76 c-sources:
89 c-sources:
@@ -96,72 +109,133 @@ library
96 include-dirs:
109 include-dirs:
97 include
110 include
98 exposed-modules:
111 exposed-modules:
112+ Development.IDE.Compat
113+ Development.IDE.Core.Debouncer
99 Development.IDE.Core.FileStore
114 Development.IDE.Core.FileStore
115+ Development.IDE.Core.IdeConfiguration
100 Development.IDE.Core.OfInterest
116 Development.IDE.Core.OfInterest
101 Development.IDE.Core.PositionMapping
117 Development.IDE.Core.PositionMapping
102 Development.IDE.Core.Rules
118 Development.IDE.Core.Rules
103 Development.IDE.Core.RuleTypes
119 Development.IDE.Core.RuleTypes
104 Development.IDE.Core.Service
120 Development.IDE.Core.Service
105 Development.IDE.Core.Shake
121 Development.IDE.Core.Shake
122+ Development.IDE.GHC.Error
106 Development.IDE.GHC.Util
123 Development.IDE.GHC.Util
107 Development.IDE.Import.DependencyInformation
124 Development.IDE.Import.DependencyInformation
125+ Development.IDE.LSP.HoverDefinition
108 Development.IDE.LSP.LanguageServer
126 Development.IDE.LSP.LanguageServer
127+ Development.IDE.LSP.Outline
109 Development.IDE.LSP.Protocol
128 Development.IDE.LSP.Protocol
110 Development.IDE.LSP.Server
129 Development.IDE.LSP.Server
130+ Development.IDE.Spans.Common
111 Development.IDE.Types.Diagnostics
131 Development.IDE.Types.Diagnostics
112 Development.IDE.Types.Location
132 Development.IDE.Types.Location
113 Development.IDE.Types.Logger
133 Development.IDE.Types.Logger
114 Development.IDE.Types.Options
134 Development.IDE.Types.Options
135+ Development.IDE.Plugin
136+ Development.IDE.Plugin.Completions
137+ Development.IDE.Plugin.CodeAction
115 other-modules:
138 other-modules:
116− Development.IDE.Core.Debouncer
117 Development.IDE.Core.Compile
139 Development.IDE.Core.Compile
118 Development.IDE.Core.Preprocessor
140 Development.IDE.Core.Preprocessor
141+ Development.IDE.Core.FileExists
119 Development.IDE.GHC.Compat
142 Development.IDE.GHC.Compat
120 Development.IDE.GHC.CPP
143 Development.IDE.GHC.CPP
121− Development.IDE.GHC.Error
122 Development.IDE.GHC.Orphans
144 Development.IDE.GHC.Orphans
123 Development.IDE.GHC.Warnings
145 Development.IDE.GHC.Warnings
146+ Development.IDE.GHC.WithDynFlags
124 Development.IDE.Import.FindImports
147 Development.IDE.Import.FindImports
125− Development.IDE.LSP.CodeAction
126− Development.IDE.LSP.Definition
127− Development.IDE.LSP.Hover
128 Development.IDE.LSP.Notifications
148 Development.IDE.LSP.Notifications
129 Development.IDE.Spans.AtPoint
149 Development.IDE.Spans.AtPoint
130 Development.IDE.Spans.Calculate
150 Development.IDE.Spans.Calculate
131 Development.IDE.Spans.Documentation
151 Development.IDE.Spans.Documentation
132 Development.IDE.Spans.Type
152 Development.IDE.Spans.Type
153+ Development.IDE.Plugin.CodeAction.PositionIndexed
154+ Development.IDE.Plugin.CodeAction.Rules
155+ Development.IDE.Plugin.CodeAction.RuleTypes
156+ Development.IDE.Plugin.Completions.Logic
157+ Development.IDE.Plugin.Completions.Types
158+ if (impl(ghc > 8.7) && impl(ghc < 8.10)) || flag(ghc-lib)
159+ hs-source-dirs: src-ghc88
160+ other-modules:
161+ Development.IDE.GHC.HieAst
162+ if (impl(ghc > 8.9))
163+ hs-source-dirs: src-ghc810
164+ other-modules:
165+ Development.IDE.GHC.HieAst
133 ghc-options: -Wall -Wno-name-shadowing
166 ghc-options: -Wall -Wno-name-shadowing
134
167
168+executable ghcide-test-preprocessor
169+ default-language: Haskell2010
170+ hs-source-dirs: test/preprocessor
171+ ghc-options: -Wall -Wno-name-shadowing
172+ main-is: Main.hs
173+ build-depends:
174+ base == 4.*
175+
135executable ghcide
176executable ghcide
136 if flag(ghc-lib)
177 if flag(ghc-lib)
137 buildable: False
178 buildable: False
138 default-language: Haskell2010
179 default-language: Haskell2010
139 hs-source-dirs: exe
180 hs-source-dirs: exe
181+ ghc-options:
182+ -threaded
183+ -Wall
140− ghc-options: -threaded -Wall -Wno-name-shadowing
184+ -Wno-name-shadowing
185+ -- allow user RTS overrides
186+ -rtsopts
187+ -- disable idle GC
188+ -- disable parallel GC
189+ -- increase nursery size
190+ "-with-rtsopts=-I0 -qg -A128M"
141 main-is: Main.hs
191 main-is: Main.hs
142 build-depends:
192 build-depends:
193+ time,
194+ async,
143 hslogger,
195 hslogger,
196+ aeson,
144 base == 4.*,
197 base == 4.*,
198+ binary,
199+ base16-bytestring >=0.1.1 && <0.2,
200+ bytestring,
145 containers,
201 containers,
202+ cryptohash-sha1 >=0.11.100 && <0.12,
146 data-default,
203 data-default,
204+ deepseq,
147 directory,
205 directory,
148 extra,
206 extra,
149 filepath,
207 filepath,
208+ ghc-check >= 0.3.0.1 && < 0.4,
150 ghc-paths,
209 ghc-paths,
151 ghc,
210 ghc,
211+ gitrev,
212+ hashable,
152 haskell-lsp,
213 haskell-lsp,
214+ haskell-lsp-types,
153− hie-bios >= 0.2 && < 0.3,
215+ hie-bios >= 0.5.0 && < 0.6,
154 ghcide,
216 ghcide,
155 optparse-applicative,
217 optparse-applicative,
156 shake,
218 shake,
157− text
219+ text,
220+ unordered-containers
158 other-modules:
221 other-modules:
222+ Utils
159 Arguments
223 Arguments
160 Paths_ghcide
224 Paths_ghcide
161
225
162 default-extensions:
226 default-extensions:
227+ BangPatterns
228+ DeriveFunctor
229+ DeriveGeneric
230+ GeneralizedNewtypeDeriving
231+ LambdaCase
232+ NamedFieldPuns
233+ OverloadedStrings
163 RecordWildCards
234 RecordWildCards
235+ ScopedTypeVariables
236+ StandaloneDeriving
164 TupleSections
237 TupleSections
238+ TypeApplications
165 ViewPatterns
239 ViewPatterns
166
240
167test-suite ghcide-tests
241test-suite ghcide-tests
@@ -170,8 +244,10 @@ test-suite ghcide-tests
170 type: exitcode-stdio-1.0
244 type: exitcode-stdio-1.0
171 default-language: Haskell2010
245 default-language: Haskell2010
172 build-tool-depends:
246 build-tool-depends:
173− ghcide:ghcide
247+ ghcide:ghcide,
248+ ghcide:ghcide-test-preprocessor
174 build-depends:
249 build-depends:
250+ aeson,
175 base,
251 base,
176 bytestring,
252 bytestring,
177 containers,
253 containers,
@@ -188,13 +264,22 @@ test-suite ghcide-tests
188 --------------------------------------------------------------
264 --------------------------------------------------------------
189 ghcide,
265 ghcide,
190 ghc-typelits-knownnat,
266 ghc-typelits-knownnat,
267+ haddock-library,
268+ haskell-lsp,
191 haskell-lsp-types,
269 haskell-lsp-types,
270+ network-uri,
192 lens,
271 lens,
193− lsp-test >= 0.8,
272+ lsp-test >= 0.11.0.1 && < 0.12,
194 parser-combinators,
273 parser-combinators,
274+ QuickCheck,
275+ quickcheck-instances,
276+ rope-utf16-splay,
277+ shake,
195 tasty,
278 tasty,
196− tasty-hunit,
197 tasty-expected-failure,
279 tasty-expected-failure,
280+ tasty-hunit,
281+ tasty-quickcheck,
282+ tasty-rerun,
198 text
283 text
199 hs-source-dirs: test/cabal test/exe test/src
284 hs-source-dirs: test/cabal test/exe test/src
200 include-dirs: include
285 include-dirs: include
@@ -204,4 +289,56 @@ test-suite ghcide-tests
204 Development.IDE.Test
289 Development.IDE.Test
205 Development.IDE.Test.Runfiles
290 Development.IDE.Test.Runfiles
206 default-extensions:
291 default-extensions:
292+ BangPatterns
293+ DeriveFunctor
294+ DeriveGeneric
295+ GeneralizedNewtypeDeriving
296+ LambdaCase
297+ NamedFieldPuns
298+ OverloadedStrings
299+ RecordWildCards
300+ ScopedTypeVariables
301+ StandaloneDeriving
302+ TupleSections
303+ TypeApplications
304+ ViewPatterns
305+
306+benchmark ghcide-bench
307+ type: exitcode-stdio-1.0
308+ default-language: Haskell2010
309+ build-tool-depends:
310+ ghcide:ghcide,
311+ ghcide:ghcide-test-preprocessor
312+ build-depends:
313+ aeson,
314+ base,
315+ bytestring,
316+ containers,
317+ directory,
318+ extra,
319+ filepath,
320+ ghcide,
321+ lsp-test < 0.12,
322+ optparse-applicative,
323+ parser-combinators,
324+ process,
325+ safe-exceptions
326+ hs-source-dirs: bench
327+ include-dirs: include
328+ ghc-options: -threaded -Wall -Wno-name-shadowing
329+ main-is: Main.hs
330+ other-modules:
331+ default-extensions:
332+ BangPatterns
333+ DeriveFunctor
334+ DeriveGeneric
335+ GeneralizedNewtypeDeriving
336+ LambdaCase
337+ NamedFieldPuns
207 OverloadedStrings
338 OverloadedStrings
339+ RecordWildCards
340+ ScopedTypeVariables
341+ StandaloneDeriving
342+ TupleSections
343+ TypeApplications
344+ ViewPatterns
hie.yaml+12−1
@@ -1 +1,12 @@
1−cradle: {stack}
1+cradle:
2+ cabal:
3+ - path: "./src"
4+ component: "ghcide:lib:ghcide"
5+ - path: "./exe"
6+ component: "ghcide:exe:ghcide"
7+ - path: "./test"
8+ component: "ghcide:test:ghcide-tests"
9+ - path: "./bench"
10+ component: "ghcide:benchmark:ghcide-bench"
11+ - path: "./test/preprocessor"
12+ component: "ghcide:exe:ghcide-test-preprocessor"
src-ghc810/Development/IDE/GHC/HieAst.hsnew file+1928
@@ -0,0 +1,1928 @@
1+
2+
3+{-
4+Forked from GHC v8.10.1 to work around the readFile side effect in mkHiefile
5+
6+Main functions for .hie file generation
7+-}
8+{- HLINT ignore -}
9+{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE FlexibleInstances #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+{-# LANGUAGE FlexibleContexts #-}
13+{-# LANGUAGE TypeSynonymInstances #-}
14+{-# LANGUAGE ScopedTypeVariables #-}
15+{-# LANGUAGE TypeFamilies #-}
16+{-# LANGUAGE TypeApplications #-}
17+{-# LANGUAGE AllowAmbiguousTypes #-}
18+{-# LANGUAGE ViewPatterns #-}
19+{-# LANGUAGE DeriveDataTypeable #-}
20+module Development.IDE.GHC.HieAst ( mkHieFile ) where
21+
22+import GhcPrelude
23+
24+import Avail ( Avails )
25+import Bag ( Bag, bagToList )
26+import BasicTypes
27+import BooleanFormula
28+import Class ( FunDep )
29+import CoreUtils ( exprType )
30+import ConLike ( conLikeName )
31+import Desugar ( deSugarExpr )
32+import FieldLabel
33+import GHC.Hs
34+import HscTypes
35+import Module ( ModuleName, ml_hs_file )
36+import MonadUtils ( concatMapM, liftIO )
37+import Name ( Name, nameSrcSpan, setNameLoc )
38+import NameEnv ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )
39+import SrcLoc
40+import TcHsSyn ( hsLitType, hsPatType )
41+import Type ( mkVisFunTys, Type )
42+import TysWiredIn ( mkListTy, mkSumTy )
43+import Var ( Id, Var, setVarName, varName, varType )
44+import TcRnTypes
45+import MkIface ( mkIfaceExports )
46+import Panic
47+
48+import HieTypes
49+import HieUtils
50+
51+import qualified Data.Array as A
52+import qualified Data.ByteString as BS
53+import qualified Data.Map as M
54+import qualified Data.Set as S
55+import Data.Data ( Data, Typeable )
56+import Data.List ( foldl1' )
57+import Data.Maybe ( listToMaybe )
58+import Control.Monad.Trans.Reader
59+import Control.Monad.Trans.Class ( lift )
60+
61+{- Note [Updating HieAst for changes in the GHC AST]
62+
63+When updating the code in this file for changes in the GHC AST, you
64+need to pay attention to the following things:
65+
66+1) Symbols (Names/Vars/Modules) in the following categories:
67+
68+ a) Symbols that appear in the source file that directly correspond to
69+ something the user typed
70+ b) Symbols that don't appear in the source, but should be in some sense
71+ "visible" to a user, particularly via IDE tooling or the like. This
72+ includes things like the names introduced by RecordWildcards (We record
73+ all the names introduced by a (..) in HIE files), and will include implicit
74+ parameters and evidence variables after one of my pending MRs lands.
75+
76+2) Subtrees that may contain such symbols, or correspond to a SrcSpan in
77+ the file. This includes all `Located` things
78+
79+For 1), you need to call `toHie` for one of the following instances
80+
81+instance ToHie (Context (Located Name)) where ...
82+instance ToHie (Context (Located Var)) where ...
83+instance ToHie (IEContext (Located ModuleName)) where ...
84+
85+`Context` is a data type that looks like:
86+
87+data Context a = C ContextInfo a -- Used for names and bindings
88+
89+`ContextInfo` is defined in `HieTypes`, and looks like
90+
91+data ContextInfo
92+ = Use -- ^ regular variable
93+ | MatchBind
94+ | IEThing IEType -- ^ import/export
95+ | TyDecl
96+ -- | Value binding
97+ | ValBind
98+ BindType -- ^ whether or not the binding is in an instance
99+ Scope -- ^ scope over which the value is bound
100+ (Maybe Span) -- ^ span of entire binding
101+ ...
102+
103+It is used to annotate symbols in the .hie files with some extra information on
104+the context in which they occur and should be fairly self explanatory. You need
105+to select one that looks appropriate for the symbol usage. In very rare cases,
106+you might need to extend this sum type if none of the cases seem appropriate.
107+
108+So, given a `Located Name` that is just being "used", and not defined at a
109+particular location, you would do the following:
110+
111+ toHie $ C Use located_name
112+
113+If you select one that corresponds to a binding site, you will need to
114+provide a `Scope` and a `Span` for your binding. Both of these are basically
115+`SrcSpans`.
116+
117+The `SrcSpan` in the `Scope` is supposed to span over the part of the source
118+where the symbol can be legally allowed to occur. For more details on how to
119+calculate this, see Note [Capturing Scopes and other non local information]
120+in HieAst.
121+
122+The binding `Span` is supposed to be the span of the entire binding for
123+the name.
124+
125+For a function definition `foo`:
126+
127+foo x = x + y
128+ where y = x^2
129+
130+The binding `Span` is the span of the entire function definition from `foo x`
131+to `x^2`. For a class definition, this is the span of the entire class, and
132+so on. If this isn't well defined for your bit of syntax (like a variable
133+bound by a lambda), then you can just supply a `Nothing`
134+
135+There is a test that checks that all symbols in the resulting HIE file
136+occur inside their stated `Scope`. This can be turned on by passing the
137+-fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the
138+.hie file.
139+
140+You may also want to provide a test in testsuite/test/hiefile that includes
141+a file containing your new construction, and tests that the calculated scope
142+is valid (by using -fvalidate-ide-info)
143+
144+For subtrees in the AST that may contain symbols, the procedure is fairly
145+straightforward. If you are extending the GHC AST, you will need to provide a
146+`ToHie` instance for any new types you may have introduced in the AST.
147+
148+Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)):
149+
150+ toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
151+ HsVar _ (L _ var) ->
152+ [ toHie $ C Use (L mspan var)
153+ -- Patch up var location since typechecker removes it
154+ ]
155+ HsConLikeOut _ con ->
156+ [ toHie $ C Use $ L mspan $ conLikeName con
157+ ]
158+ ...
159+ HsApp _ a b ->
160+ [ toHie a
161+ , toHie b
162+ ]
163+
164+If your subtree is `Located` or has a `SrcSpan` available, the output list
165+should contain a HieAst `Node` corresponding to the subtree. You can use
166+either `makeNode` or `getTypeNode` for this purpose, depending on whether it
167+makes sense to assign a `Type` to the subtree. After this, you just need
168+to concatenate the result of calling `toHie` on all subexpressions and
169+appropriately annotated symbols contained in the subtree.
170+
171+The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed
172+to work for both the renamed and typechecked source. `getTypeNode` is from
173+the `HasType` class defined in this file, and it has different instances
174+for `GhcTc` and `GhcRn` that allow it to access the type of the expression
175+when given a typechecked AST:
176+
177+class Data a => HasType a where
178+ getTypeNode :: a -> HieM [HieAST Type]
179+instance HasType (LHsExpr GhcTc) where
180+ getTypeNode e@(L spn e') = ... -- Actually get the type for this expression
181+instance HasType (LHsExpr GhcRn) where
182+ getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type
183+
184+If your subtree doesn't have a span available, you can omit the `makeNode`
185+call and just recurse directly in to the subexpressions.
186+
187+-}
188+
189+-- These synonyms match those defined in main/GHC.hs
190+type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn]
191+ , Maybe [(LIE GhcRn, Avails)]
192+ , Maybe LHsDocString )
193+type TypecheckedSource = LHsBinds GhcTc
194+
195+
196+{- Note [Name Remapping]
197+The Typechecker introduces new names for mono names in AbsBinds.
198+We don't care about the distinction between mono and poly bindings,
199+so we replace all occurrences of the mono name with the poly name.
200+-}
201+newtype HieState = HieState
202+ { name_remapping :: NameEnv Id
203+ }
204+
205+initState :: HieState
206+initState = HieState emptyNameEnv
207+
208+class ModifyState a where -- See Note [Name Remapping]
209+ addSubstitution :: a -> a -> HieState -> HieState
210+
211+instance ModifyState Name where
212+ addSubstitution _ _ hs = hs
213+
214+instance ModifyState Id where
215+ addSubstitution mono poly hs =
216+ hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly}
217+
218+modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState
219+modifyState = foldr go id
220+ where
221+ go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f
222+ go _ f = f
223+
224+type HieM = ReaderT HieState Hsc
225+
226+-- | Construct an 'HieFile' from the outputs of the typechecker.
227+mkHieFile :: ModSummary
228+ -> TcGblEnv
229+ -> RenamedSource
230+ -> BS.ByteString -> Hsc HieFile
231+mkHieFile ms ts rs src = do
232+ let tc_binds = tcg_binds ts
233+ (asts', arr) <- getCompressedAsts tc_binds rs
234+ let Just src_file = ml_hs_file $ ms_location ms
235+ return $ HieFile
236+ { hie_hs_file = src_file
237+ , hie_module = ms_mod ms
238+ , hie_types = arr
239+ , hie_asts = asts'
240+ -- mkIfaceExports sorts the AvailInfos for stability
241+ , hie_exports = mkIfaceExports (tcg_exports ts)
242+ , hie_hs_src = src
243+ }
244+
245+getCompressedAsts :: TypecheckedSource -> RenamedSource
246+ -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
247+getCompressedAsts ts rs = do
248+ asts <- enrichHie ts rs
249+ return $ compressTypes asts
250+
251+enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)
252+enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do
253+ tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts
254+ rasts <- processGrp hsGrp
255+ imps <- toHie $ filter (not . ideclImplicit . unLoc) imports
256+ exps <- toHie $ fmap (map $ IEC Export . fst) exports
257+ let spanFile children = case children of
258+ [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)
259+ _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)
260+ (realSrcSpanEnd $ nodeSpan $ last children)
261+
262+ modulify xs =
263+ Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs
264+
265+ asts = HieASTs
266+ $ resolveTyVarScopes
267+ $ M.map (modulify . mergeSortAsts)
268+ $ M.fromListWith (++)
269+ $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
270+
271+ flat_asts = concat
272+ [ tasts
273+ , rasts
274+ , imps
275+ , exps
276+ ]
277+ return asts
278+ where
279+ processGrp grp = concatM
280+ [ toHie $ fmap (RS ModuleScope ) hs_valds grp
281+ , toHie $ hs_splcds grp
282+ , toHie $ hs_tyclds grp
283+ , toHie $ hs_derivds grp
284+ , toHie $ hs_fixds grp
285+ , toHie $ hs_defds grp
286+ , toHie $ hs_fords grp
287+ , toHie $ hs_warnds grp
288+ , toHie $ hs_annds grp
289+ , toHie $ hs_ruleds grp
290+ ]
291+
292+getRealSpan :: SrcSpan -> Maybe Span
293+getRealSpan (RealSrcSpan sp) = Just sp
294+getRealSpan _ = Nothing
295+
296+grhss_span :: GRHSs p body -> SrcSpan
297+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)
298+grhss_span (XGRHSs _) = panic "XGRHS has no span"
299+
300+bindingsOnly :: [Context Name] -> [HieAST a]
301+bindingsOnly [] = []
302+bindingsOnly (C c n : xs) = case nameSrcSpan n of
303+ RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs
304+ where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
305+ info = mempty{identInfo = S.singleton c}
306+ _ -> bindingsOnly xs
307+
308+concatM :: Monad m => [m [a]] -> m [a]
309+concatM xs = concat <$> sequence xs
310+
311+{- Note [Capturing Scopes and other non local information]
312+toHie is a local tranformation, but scopes of bindings cannot be known locally,
313+hence we have to push the relevant info down into the binding nodes.
314+We use the following types (*Context and *Scoped) to wrap things and
315+carry the required info
316+(Maybe Span) always carries the span of the entire binding, including rhs
317+-}
318+data Context a = C ContextInfo a -- Used for names and bindings
319+
320+data RContext a = RC RecFieldContext a
321+data RFContext a = RFC RecFieldContext (Maybe Span) a
322+-- ^ context for record fields
323+
324+data IEContext a = IEC IEType a
325+-- ^ context for imports/exports
326+
327+data BindContext a = BC BindType Scope a
328+-- ^ context for imports/exports
329+
330+data PatSynFieldContext a = PSC (Maybe Span) a
331+-- ^ context for pattern synonym fields.
332+
333+data SigContext a = SC SigInfo a
334+-- ^ context for type signatures
335+
336+data SigInfo = SI SigType (Maybe Span)
337+
338+data SigType = BindSig | ClassSig | InstSig
339+
340+data RScoped a = RS Scope a
341+-- ^ Scope spans over everything to the right of a, (mostly) not
342+-- including a itself
343+-- (Includes a in a few special cases like recursive do bindings) or
344+-- let/where bindings
345+
346+-- | Pattern scope
347+data PScoped a = PS (Maybe Span)
348+ Scope -- ^ use site of the pattern
349+ Scope -- ^ pattern to the right of a, not including a
350+ a
351+ deriving (Typeable, Data) -- Pattern Scope
352+
353+{- Note [TyVar Scopes]
354+Due to -XScopedTypeVariables, type variables can be in scope quite far from
355+their original binding. We resolve the scope of these type variables
356+in a separate pass
357+-}
358+data TScoped a = TS TyVarScope a -- TyVarScope
359+
360+data TVScoped a = TVS TyVarScope Scope a -- TyVarScope
361+-- ^ First scope remains constant
362+-- Second scope is used to build up the scope of a tyvar over
363+-- things to its right, ala RScoped
364+
365+-- | Each element scopes over the elements to the right
366+listScopes :: Scope -> [Located a] -> [RScoped (Located a)]
367+listScopes _ [] = []
368+listScopes rhsScope [pat] = [RS rhsScope pat]
369+listScopes rhsScope (pat : pats) = RS sc pat : pats'
370+ where
371+ pats'@((RS scope p):_) = listScopes rhsScope pats
372+ sc = combineScopes scope $ mkScope $ getLoc p
373+
374+-- | 'listScopes' specialised to 'PScoped' things
375+patScopes
376+ :: Maybe Span
377+ -> Scope
378+ -> Scope
379+ -> [LPat (GhcPass p)]
380+ -> [PScoped (LPat (GhcPass p))]
381+patScopes rsp useScope patScope xs =
382+ map (\(RS sc a) -> PS rsp useScope sc (composeSrcSpan a)) $
383+ listScopes patScope (map dL xs)
384+
385+-- | 'listScopes' specialised to 'TVScoped' things
386+tvScopes
387+ :: TyVarScope
388+ -> Scope
389+ -> [LHsTyVarBndr a]
390+ -> [TVScoped (LHsTyVarBndr a)]
391+tvScopes tvScope rhsScope xs =
392+ map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs
393+
394+{- Note [Scoping Rules for SigPat]
395+Explicitly quantified variables in pattern type signatures are not
396+brought into scope in the rhs, but implicitly quantified variables
397+are (HsWC and HsIB).
398+This is unlike other signatures, where explicitly quantified variables
399+are brought into the RHS Scope
400+For example
401+foo :: forall a. ...;
402+foo = ... -- a is in scope here
403+
404+bar (x :: forall a. a -> a) = ... -- a is not in scope here
405+-- ^ a is in scope here (pattern body)
406+
407+bax (x :: a) = ... -- a is in scope here
408+Because of HsWC and HsIB pass on their scope to their children
409+we must wrap the LHsType in pattern signatures in a
410+Shielded explictly, so that the HsWC/HsIB scope is not passed
411+on the the LHsType
412+-}
413+
414+data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead
415+
416+type family ProtectedSig a where
417+ ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs
418+ GhcRn
419+ (Shielded (LHsType GhcRn)))
420+ ProtectedSig GhcTc = NoExtField
421+
422+class ProtectSig a where
423+ protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a
424+
425+instance (HasLoc a) => HasLoc (Shielded a) where
426+ loc (SH _ a) = loc a
427+
428+instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where
429+ toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)
430+
431+instance ProtectSig GhcTc where
432+ protectSig _ _ = noExtField
433+
434+instance ProtectSig GhcRn where
435+ protectSig sc (HsWC a (HsIB b sig)) =
436+ HsWC a (HsIB b (SH sc sig))
437+ protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec
438+ protectSig _ (XHsWildCardBndrs nec) = noExtCon nec
439+
440+class HasLoc a where
441+ -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can
442+ -- know what their implicit bindings are scoping over
443+ loc :: a -> SrcSpan
444+
445+instance HasLoc thing => HasLoc (TScoped thing) where
446+ loc (TS _ a) = loc a
447+
448+instance HasLoc thing => HasLoc (PScoped thing) where
449+ loc (PS _ _ _ a) = loc a
450+
451+instance HasLoc (LHsQTyVars GhcRn) where
452+ loc (HsQTvs _ vs) = loc vs
453+ loc _ = noSrcSpan
454+
455+instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where
456+ loc (HsIB _ a) = loc a
457+ loc _ = noSrcSpan
458+
459+instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where
460+ loc (HsWC _ a) = loc a
461+ loc _ = noSrcSpan
462+
463+instance HasLoc (Located a) where
464+ loc (L l _) = l
465+
466+instance HasLoc a => HasLoc [a] where
467+ loc [] = noSrcSpan
468+ loc xs = foldl1' combineSrcSpans $ map loc xs
469+
470+instance HasLoc a => HasLoc (FamEqn s a) where
471+ loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]
472+ loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
473+ [loc a, loc tvs, loc b, loc c]
474+ loc _ = noSrcSpan
475+instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
476+ loc (HsValArg tm) = loc tm
477+ loc (HsTypeArg _ ty) = loc ty
478+ loc (HsArgPar sp) = sp
479+
480+instance HasLoc (HsDataDefn GhcRn) where
481+ loc def@(HsDataDefn{}) = loc $ dd_cons def
482+ -- Only used for data family instances, so we only need rhs
483+ -- Most probably the rest will be unhelpful anyway
484+ loc _ = noSrcSpan
485+
486+{- Note [Real DataCon Name]
487+The typechecker subtitutes the conLikeWrapId for the name, but we don't want
488+this showing up in the hieFile, so we replace the name in the Id with the
489+original datacon name
490+See also Note [Data Constructor Naming]
491+-}
492+class HasRealDataConName p where
493+ getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p)
494+
495+instance HasRealDataConName GhcRn where
496+ getRealDataCon _ n = n
497+instance HasRealDataConName GhcTc where
498+ getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) =
499+ L sp (setVarName var (conLikeName con))
500+
501+-- | The main worker class
502+-- See Note [Updating HieAst for changes in the GHC AST] for more information
503+-- on how to add/modify instances for this.
504+class ToHie a where
505+ toHie :: a -> HieM [HieAST Type]
506+
507+-- | Used to collect type info
508+class Data a => HasType a where
509+ getTypeNode :: a -> HieM [HieAST Type]
510+
511+instance (ToHie a) => ToHie [a] where
512+ toHie = concatMapM toHie
513+
514+instance (ToHie a) => ToHie (Bag a) where
515+ toHie = toHie . bagToList
516+
517+instance (ToHie a) => ToHie (Maybe a) where
518+ toHie = maybe (pure []) toHie
519+
520+instance ToHie (Context (Located NoExtField)) where
521+ toHie _ = pure []
522+
523+instance ToHie (TScoped NoExtField) where
524+ toHie _ = pure []
525+
526+instance ToHie (IEContext (Located ModuleName)) where
527+ toHie (IEC c (L (RealSrcSpan span) mname)) =
528+ pure $ [Node (NodeInfo S.empty [] idents) span []]
529+ where details = mempty{identInfo = S.singleton (IEThing c)}
530+ idents = M.singleton (Left mname) details
531+ toHie _ = pure []
532+
533+instance ToHie (Context (Located Var)) where
534+ toHie c = case c of
535+ C context (L (RealSrcSpan span) name')
536+ -> do
537+ m <- asks name_remapping
538+ let name = case lookupNameEnv m (varName name') of
539+ Just var -> var
540+ Nothing-> name'
541+ pure
542+ [Node
543+ (NodeInfo S.empty [] $
544+ M.singleton (Right $ varName name)
545+ (IdentifierDetails (Just $ varType name')
546+ (S.singleton context)))
547+ span
548+ []]
549+ _ -> pure []
550+
551+instance ToHie (Context (Located Name)) where
552+ toHie c = case c of
553+ C context (L (RealSrcSpan span) name') -> do
554+ m <- asks name_remapping
555+ let name = case lookupNameEnv m name' of
556+ Just var -> varName var
557+ Nothing -> name'
558+ pure
559+ [Node
560+ (NodeInfo S.empty [] $
561+ M.singleton (Right name)
562+ (IdentifierDetails Nothing
563+ (S.singleton context)))
564+ span
565+ []]
566+ _ -> pure []
567+
568+-- | Dummy instances - never called
569+instance ToHie (TScoped (LHsSigWcType GhcTc)) where
570+ toHie _ = pure []
571+instance ToHie (TScoped (LHsWcType GhcTc)) where
572+ toHie _ = pure []
573+instance ToHie (SigContext (LSig GhcTc)) where
574+ toHie _ = pure []
575+instance ToHie (TScoped Type) where
576+ toHie _ = pure []
577+
578+instance HasType (LHsBind GhcRn) where
579+ getTypeNode (L spn bind) = makeNode bind spn
580+
581+instance HasType (LHsBind GhcTc) where
582+ getTypeNode (L spn bind) = case bind of
583+ FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)
584+ _ -> makeNode bind spn
585+
586+instance HasType (Located (Pat GhcRn)) where
587+ getTypeNode (dL -> L spn pat) = makeNode pat spn
588+
589+instance HasType (Located (Pat GhcTc)) where
590+ getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)
591+
592+instance HasType (LHsExpr GhcRn) where
593+ getTypeNode (L spn e) = makeNode e spn
594+
595+-- | This instance tries to construct 'HieAST' nodes which include the type of
596+-- the expression. It is not yet possible to do this efficiently for all
597+-- expression forms, so we skip filling in the type for those inputs.
598+--
599+-- 'HsApp', for example, doesn't have any type information available directly on
600+-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then
601+-- query the type of that. Yet both the desugaring call and the type query both
602+-- involve recursive calls to the function and argument! This is particularly
603+-- problematic when you realize that the HIE traversal will eventually visit
604+-- those nodes too and ask for their types again.
605+--
606+-- Since the above is quite costly, we just skip cases where computing the
607+-- expression's type is going to be expensive.
608+--
609+-- See #16233
610+instance HasType (LHsExpr GhcTc) where
611+ getTypeNode e@(L spn e') = lift $
612+ -- Some expression forms have their type immediately available
613+ let tyOpt = case e' of
614+ HsLit _ l -> Just (hsLitType l)
615+ HsOverLit _ o -> Just (overLitType o)
616+
617+ HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
618+ HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
619+ HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)
620+
621+ ExplicitList ty _ _ -> Just (mkListTy ty)
622+ ExplicitSum ty _ _ _ -> Just (mkSumTy ty)
623+ HsDo ty _ _ -> Just ty
624+ HsMultiIf ty _ -> Just ty
625+
626+ _ -> Nothing
627+
628+ in
629+ case tyOpt of
630+ Just t -> makeTypeNode e' spn t
631+ Nothing
632+ | skipDesugaring e' -> fallback
633+ | otherwise -> do
634+ hs_env <- Hsc $ \e w -> return (e,w)
635+ (_,mbe) <- liftIO $ deSugarExpr hs_env e
636+ maybe fallback (makeTypeNode e' spn . exprType) mbe
637+ where
638+ fallback = makeNode e' spn
639+
640+ matchGroupType :: MatchGroupTc -> Type
641+ matchGroupType (MatchGroupTc args res) = mkVisFunTys args res
642+
643+ -- | Skip desugaring of these expressions for performance reasons.
644+ --
645+ -- See impact on Haddock output (esp. missing type annotations or links)
646+ -- before marking more things here as 'False'. See impact on Haddock
647+ -- performance before marking more things as 'True'.
648+ skipDesugaring :: HsExpr a -> Bool
649+ skipDesugaring e = case e of
650+ HsVar{} -> False
651+ HsUnboundVar{} -> False
652+ HsConLikeOut{} -> False
653+ HsRecFld{} -> False
654+ HsOverLabel{} -> False
655+ HsIPVar{} -> False
656+ HsWrap{} -> False
657+ _ -> True
658+
659+instance ( ToHie (Context (Located (IdP a)))
660+ , ToHie (MatchGroup a (LHsExpr a))
661+ , ToHie (PScoped (LPat a))
662+ , ToHie (GRHSs a (LHsExpr a))
663+ , ToHie (LHsExpr a)
664+ , ToHie (Located (PatSynBind a a))
665+ , HasType (LHsBind a)
666+ , ModifyState (IdP a)
667+ , Data (HsBind a)
668+ ) => ToHie (BindContext (LHsBind a)) where
669+ toHie (BC context scope b@(L span bind)) =
670+ concatM $ getTypeNode b : case bind of
671+ FunBind{fun_id = name, fun_matches = matches} ->
672+ [ toHie $ C (ValBind context scope $ getRealSpan span) name
673+ , toHie matches
674+ ]
675+ PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
676+ [ toHie $ PS (getRealSpan span) scope NoScope lhs
677+ , toHie rhs
678+ ]
679+ VarBind{var_rhs = expr} ->
680+ [ toHie expr
681+ ]
682+ AbsBinds{abs_exports = xs, abs_binds = binds} ->
683+ [ local (modifyState xs) $ -- Note [Name Remapping]
684+ toHie $ fmap (BC context scope) binds
685+ ]
686+ PatSynBind _ psb ->
687+ [ toHie $ L span psb -- PatSynBinds only occur at the top level
688+ ]
689+ XHsBindsLR _ -> []
690+
691+instance ( ToHie (LMatch a body)
692+ ) => ToHie (MatchGroup a body) where
693+ toHie mg = concatM $ case mg of
694+ MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->
695+ [ pure $ locOnly span
696+ , toHie alts
697+ ]
698+ MG{} -> []
699+ XMatchGroup _ -> []
700+
701+instance ( ToHie (Context (Located (IdP a)))
702+ , ToHie (PScoped (LPat a))
703+ , ToHie (HsPatSynDir a)
704+ ) => ToHie (Located (PatSynBind a a)) where
705+ toHie (L sp psb) = concatM $ case psb of
706+ PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->
707+ [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var
708+ , toHie $ toBind dets
709+ , toHie $ PS Nothing lhsScope NoScope pat
710+ , toHie dir
711+ ]
712+ where
713+ lhsScope = combineScopes varScope detScope
714+ varScope = mkLScope var
715+ detScope = case dets of
716+ (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args
717+ (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)
718+ (RecCon r) -> foldr go NoScope r
719+ go (RecordPatSynField a b) c = combineScopes c
720+ $ combineScopes (mkLScope a) (mkLScope b)
721+ detSpan = case detScope of
722+ LocalScope a -> Just a
723+ _ -> Nothing
724+ toBind (PrefixCon args) = PrefixCon $ map (C Use) args
725+ toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
726+ toBind (RecCon r) = RecCon $ map (PSC detSpan) r
727+ XPatSynBind _ -> []
728+
729+instance ( ToHie (MatchGroup a (LHsExpr a))
730+ ) => ToHie (HsPatSynDir a) where
731+ toHie dir = case dir of
732+ ExplicitBidirectional mg -> toHie mg
733+ _ -> pure []
734+
735+instance ( a ~ GhcPass p
736+ , ToHie body
737+ , ToHie (HsMatchContext (NameOrRdrName (IdP a)))
738+ , ToHie (PScoped (LPat a))
739+ , ToHie (GRHSs a body)
740+ , Data (Match a body)
741+ ) => ToHie (LMatch (GhcPass p) body) where
742+ toHie (L span m ) = concatM $ makeNode m span : case m of
743+ Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->
744+ [ toHie mctx
745+ , let rhsScope = mkScope $ grhss_span grhss
746+ in toHie $ patScopes Nothing rhsScope NoScope pats
747+ , toHie grhss
748+ ]
749+ XMatch _ -> []
750+
751+instance ( ToHie (Context (Located a))
752+ ) => ToHie (HsMatchContext a) where
753+ toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name
754+ toHie (StmtCtxt a) = toHie a
755+ toHie _ = pure []
756+
757+instance ( ToHie (HsMatchContext a)
758+ ) => ToHie (HsStmtContext a) where
759+ toHie (PatGuard a) = toHie a
760+ toHie (ParStmtCtxt a) = toHie a
761+ toHie (TransStmtCtxt a) = toHie a
762+ toHie _ = pure []
763+
764+instance ( a ~ GhcPass p
765+ , ToHie (Context (Located (IdP a)))
766+ , ToHie (RContext (HsRecFields a (PScoped (LPat a))))
767+ , ToHie (LHsExpr a)
768+ , ToHie (TScoped (LHsSigWcType a))
769+ , ProtectSig a
770+ , ToHie (TScoped (ProtectedSig a))
771+ , HasType (LPat a)
772+ , Data (HsSplice a)
773+ ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where
774+ toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =
775+ concatM $ getTypeNode lpat : case opat of
776+ WildPat _ ->
777+ []
778+ VarPat _ lname ->
779+ [ toHie $ C (PatternBind scope pscope rsp) lname
780+ ]
781+ LazyPat _ p ->
782+ [ toHie $ PS rsp scope pscope p
783+ ]
784+ AsPat _ lname pat ->
785+ [ toHie $ C (PatternBind scope
786+ (combineScopes (mkLScope (dL pat)) pscope)
787+ rsp)
788+ lname
789+ , toHie $ PS rsp scope pscope pat
790+ ]
791+ ParPat _ pat ->
792+ [ toHie $ PS rsp scope pscope pat
793+ ]
794+ BangPat _ pat ->
795+ [ toHie $ PS rsp scope pscope pat
796+ ]
797+ ListPat _ pats ->
798+ [ toHie $ patScopes rsp scope pscope pats
799+ ]
800+ TuplePat _ pats _ ->
801+ [ toHie $ patScopes rsp scope pscope pats
802+ ]
803+ SumPat _ pat _ _ ->
804+ [ toHie $ PS rsp scope pscope pat
805+ ]
806+ ConPatIn c dets ->
807+ [ toHie $ C Use c
808+ , toHie $ contextify dets
809+ ]
810+ ConPatOut {pat_con = con, pat_args = dets}->
811+ [ toHie $ C Use $ fmap conLikeName con
812+ , toHie $ contextify dets
813+ ]
814+ ViewPat _ expr pat ->
815+ [ toHie expr
816+ , toHie $ PS rsp scope pscope pat
817+ ]
818+ SplicePat _ sp ->
819+ [ toHie $ L ospan sp
820+ ]
821+ LitPat _ _ ->
822+ []
823+ NPat _ _ _ _ ->
824+ []
825+ NPlusKPat _ n _ _ _ _ ->
826+ [ toHie $ C (PatternBind scope pscope rsp) n
827+ ]
828+ SigPat _ pat sig ->
829+ [ toHie $ PS rsp scope pscope pat
830+ , let cscope = mkLScope (dL pat) in
831+ toHie $ TS (ResolvedScopes [cscope, scope, pscope])
832+ (protectSig @a cscope sig)
833+ -- See Note [Scoping Rules for SigPat]
834+ ]
835+ CoPat _ _ _ _ ->
836+ []
837+ XPat _ -> []
838+ where
839+ contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
840+ contextify (InfixCon a b) = InfixCon a' b'
841+ where [a', b'] = patScopes rsp scope pscope [a,b]
842+ contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r
843+ contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a
844+ where
845+ go (RS fscope (L spn (HsRecField lbl pat pun))) =
846+ L spn $ HsRecField lbl (PS rsp scope fscope pat) pun
847+ scoped_fds = listScopes pscope fds
848+
849+instance ( ToHie body
850+ , ToHie (LGRHS a body)
851+ , ToHie (RScoped (LHsLocalBinds a))
852+ ) => ToHie (GRHSs a body) where
853+ toHie grhs = concatM $ case grhs of
854+ GRHSs _ grhss binds ->
855+ [ toHie grhss
856+ , toHie $ RS (mkScope $ grhss_span grhs) binds
857+ ]
858+ XGRHSs _ -> []
859+
860+instance ( ToHie (Located body)
861+ , ToHie (RScoped (GuardLStmt a))
862+ , Data (GRHS a (Located body))
863+ ) => ToHie (LGRHS a (Located body)) where
864+ toHie (L span g) = concatM $ makeNode g span : case g of
865+ GRHS _ guards body ->
866+ [ toHie $ listScopes (mkLScope body) guards
867+ , toHie body
868+ ]
869+ XGRHS _ -> []
870+
871+instance ( a ~ GhcPass p
872+ , ToHie (Context (Located (IdP a)))
873+ , HasType (LHsExpr a)
874+ , ToHie (PScoped (LPat a))
875+ , ToHie (MatchGroup a (LHsExpr a))
876+ , ToHie (LGRHS a (LHsExpr a))
877+ , ToHie (RContext (HsRecordBinds a))
878+ , ToHie (RFContext (Located (AmbiguousFieldOcc a)))
879+ , ToHie (ArithSeqInfo a)
880+ , ToHie (LHsCmdTop a)
881+ , ToHie (RScoped (GuardLStmt a))
882+ , ToHie (RScoped (LHsLocalBinds a))
883+ , ToHie (TScoped (LHsWcType (NoGhcTc a)))
884+ , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))
885+ , Data (HsExpr a)
886+ , Data (HsSplice a)
887+ , Data (HsTupArg a)
888+ , Data (AmbiguousFieldOcc a)
889+ , (HasRealDataConName a)
890+ ) => ToHie (LHsExpr (GhcPass p)) where
891+ toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
892+ HsVar _ (L _ var) ->
893+ [ toHie $ C Use (L mspan var)
894+ -- Patch up var location since typechecker removes it
895+ ]
896+ HsUnboundVar _ _ ->
897+ []
898+ HsConLikeOut _ con ->
899+ [ toHie $ C Use $ L mspan $ conLikeName con
900+ ]
901+ HsRecFld _ fld ->
902+ [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)
903+ ]
904+ HsOverLabel _ _ _ -> []
905+ HsIPVar _ _ -> []
906+ HsOverLit _ _ -> []
907+ HsLit _ _ -> []
908+ HsLam _ mg ->
909+ [ toHie mg
910+ ]
911+ HsLamCase _ mg ->
912+ [ toHie mg
913+ ]
914+ HsApp _ a b ->
915+ [ toHie a
916+ , toHie b
917+ ]
918+ HsAppType _ expr sig ->
919+ [ toHie expr
920+ , toHie $ TS (ResolvedScopes []) sig
921+ ]
922+ OpApp _ a b c ->
923+ [ toHie a
924+ , toHie b
925+ , toHie c
926+ ]
927+ NegApp _ a _ ->
928+ [ toHie a
929+ ]
930+ HsPar _ a ->
931+ [ toHie a
932+ ]
933+ SectionL _ a b ->
934+ [ toHie a
935+ , toHie b
936+ ]
937+ SectionR _ a b ->
938+ [ toHie a
939+ , toHie b
940+ ]
941+ ExplicitTuple _ args _ ->
942+ [ toHie args
943+ ]
944+ ExplicitSum _ _ _ expr ->
945+ [ toHie expr
946+ ]
947+ HsCase _ expr matches ->
948+ [ toHie expr
949+ , toHie matches
950+ ]
951+ HsIf _ _ a b c ->
952+ [ toHie a
953+ , toHie b
954+ , toHie c
955+ ]
956+ HsMultiIf _ grhss ->
957+ [ toHie grhss
958+ ]
959+ HsLet _ binds expr ->
960+ [ toHie $ RS (mkLScope expr) binds
961+ , toHie expr
962+ ]
963+ HsDo _ _ (L ispan stmts) ->
964+ [ pure $ locOnly ispan
965+ , toHie $ listScopes NoScope stmts
966+ ]
967+ ExplicitList _ _ exprs ->
968+ [ toHie exprs
969+ ]
970+ RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} ->
971+ [ toHie $ C Use (getRealDataCon @a mrealcon name)
972+ -- See Note [Real DataCon Name]
973+ , toHie $ RC RecFieldAssign $ binds
974+ ]
975+ RecordUpd {rupd_expr = expr, rupd_flds = upds}->
976+ [ toHie expr
977+ , toHie $ map (RC RecFieldAssign) upds
978+ ]
979+ ExprWithTySig _ expr sig ->
980+ [ toHie expr
981+ , toHie $ TS (ResolvedScopes [mkLScope expr]) sig
982+ ]
983+ ArithSeq _ _ info ->
984+ [ toHie info
985+ ]
986+ HsSCC _ _ _ expr ->
987+ [ toHie expr
988+ ]
989+ HsCoreAnn _ _ _ expr ->
990+ [ toHie expr
991+ ]
992+ HsProc _ pat cmdtop ->
993+ [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat
994+ , toHie cmdtop
995+ ]
996+ HsStatic _ expr ->
997+ [ toHie expr
998+ ]
999+ HsTick _ _ expr ->
1000+ [ toHie expr
1001+ ]
1002+ HsBinTick _ _ _ expr ->
1003+ [ toHie expr
1004+ ]
1005+ HsTickPragma _ _ _ _ expr ->
1006+ [ toHie expr
1007+ ]
1008+ HsWrap _ _ a ->
1009+ [ toHie $ L mspan a
1010+ ]
1011+ HsBracket _ b ->
1012+ [ toHie b
1013+ ]
1014+ HsRnBracketOut _ b p ->
1015+ [ toHie b
1016+ , toHie p
1017+ ]
1018+ HsTcBracketOut _ b p ->
1019+ [ toHie b
1020+ , toHie p
1021+ ]
1022+ HsSpliceE _ x ->
1023+ [ toHie $ L mspan x
1024+ ]
1025+ XExpr _ -> []
1026+
1027+instance ( a ~ GhcPass p
1028+ , ToHie (LHsExpr a)
1029+ , Data (HsTupArg a)
1030+ ) => ToHie (LHsTupArg (GhcPass p)) where
1031+ toHie (L span arg) = concatM $ makeNode arg span : case arg of
1032+ Present _ expr ->
1033+ [ toHie expr
1034+ ]
1035+ Missing _ -> []
1036+ XTupArg _ -> []
1037+
1038+instance ( a ~ GhcPass p
1039+ , ToHie (PScoped (LPat a))
1040+ , ToHie (LHsExpr a)
1041+ , ToHie (SigContext (LSig a))
1042+ , ToHie (RScoped (LHsLocalBinds a))
1043+ , ToHie (RScoped (ApplicativeArg a))
1044+ , ToHie (Located body)
1045+ , Data (StmtLR a a (Located body))
1046+ , Data (StmtLR a a (Located (HsExpr a)))
1047+ ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where
1048+ toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of
1049+ LastStmt _ body _ _ ->
1050+ [ toHie body
1051+ ]
1052+ BindStmt _ pat body _ _ ->
1053+ [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat
1054+ , toHie body
1055+ ]
1056+ ApplicativeStmt _ stmts _ ->
1057+ [ concatMapM (toHie . RS scope . snd) stmts
1058+ ]
1059+ BodyStmt _ body _ _ ->
1060+ [ toHie body
1061+ ]
1062+ LetStmt _ binds ->
1063+ [ toHie $ RS scope binds
1064+ ]
1065+ ParStmt _ parstmts _ _ ->
1066+ [ concatMapM (\(ParStmtBlock _ stmts _ _) ->
1067+ toHie $ listScopes NoScope stmts)
1068+ parstmts
1069+ ]
1070+ TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->
1071+ [ toHie $ listScopes scope stmts
1072+ , toHie using
1073+ , toHie by
1074+ ]
1075+ RecStmt {recS_stmts = stmts} ->
1076+ [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts
1077+ ]
1078+ XStmtLR _ -> []
1079+
1080+instance ( ToHie (LHsExpr a)
1081+ , ToHie (PScoped (LPat a))
1082+ , ToHie (BindContext (LHsBind a))
1083+ , ToHie (SigContext (LSig a))
1084+ , ToHie (RScoped (HsValBindsLR a a))
1085+ , Data (HsLocalBinds a)
1086+ ) => ToHie (RScoped (LHsLocalBinds a)) where
1087+ toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of
1088+ EmptyLocalBinds _ -> []
1089+ HsIPBinds _ _ -> []
1090+ HsValBinds _ valBinds ->
1091+ [ toHie $ RS (combineScopes scope $ mkScope sp)
1092+ valBinds
1093+ ]
1094+ XHsLocalBindsLR _ -> []
1095+
1096+instance ( ToHie (BindContext (LHsBind a))
1097+ , ToHie (SigContext (LSig a))
1098+ , ToHie (RScoped (XXValBindsLR a a))
1099+ ) => ToHie (RScoped (HsValBindsLR a a)) where
1100+ toHie (RS sc v) = concatM $ case v of
1101+ ValBinds _ binds sigs ->
1102+ [ toHie $ fmap (BC RegularBind sc) binds
1103+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
1104+ ]
1105+ XValBindsLR x -> [ toHie $ RS sc x ]
1106+
1107+instance ToHie (RScoped (NHsValBindsLR GhcTc)) where
1108+ toHie (RS sc (NValBinds binds sigs)) = concatM $
1109+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
1110+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
1111+ ]
1112+instance ToHie (RScoped (NHsValBindsLR GhcRn)) where
1113+ toHie (RS sc (NValBinds binds sigs)) = concatM $
1114+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
1115+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
1116+ ]
1117+
1118+instance ( ToHie (RContext (LHsRecField a arg))
1119+ ) => ToHie (RContext (HsRecFields a arg)) where
1120+ toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields
1121+
1122+instance ( ToHie (RFContext (Located label))
1123+ , ToHie arg
1124+ , HasLoc arg
1125+ , Data label
1126+ , Data arg
1127+ ) => ToHie (RContext (LHsRecField' label arg)) where
1128+ toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of
1129+ HsRecField label expr _ ->
1130+ [ toHie $ RFC c (getRealSpan $ loc expr) label
1131+ , toHie expr
1132+ ]
1133+
1134+removeDefSrcSpan :: Name -> Name
1135+removeDefSrcSpan n = setNameLoc n noSrcSpan
1136+
1137+instance ToHie (RFContext (LFieldOcc GhcRn)) where
1138+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of
1139+ FieldOcc name _ ->
1140+ [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)
1141+ ]
1142+ XFieldOcc _ -> []
1143+
1144+instance ToHie (RFContext (LFieldOcc GhcTc)) where
1145+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of
1146+ FieldOcc var _ ->
1147+ let var' = setVarName var (removeDefSrcSpan $ varName var)
1148+ in [ toHie $ C (RecField c rhs) (L nspan var')
1149+ ]
1150+ XFieldOcc _ -> []
1151+
1152+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
1153+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
1154+ Unambiguous name _ ->
1155+ [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name
1156+ ]
1157+ Ambiguous _name _ ->
1158+ [ ]
1159+ XAmbiguousFieldOcc _ -> []
1160+
1161+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
1162+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
1163+ Unambiguous var _ ->
1164+ let var' = setVarName var (removeDefSrcSpan $ varName var)
1165+ in [ toHie $ C (RecField c rhs) (L nspan var')
1166+ ]
1167+ Ambiguous var _ ->
1168+ let var' = setVarName var (removeDefSrcSpan $ varName var)
1169+ in [ toHie $ C (RecField c rhs) (L nspan var')
1170+ ]
1171+ XAmbiguousFieldOcc _ -> []
1172+
1173+instance ( a ~ GhcPass p
1174+ , ToHie (PScoped (LPat a))
1175+ , ToHie (BindContext (LHsBind a))
1176+ , ToHie (LHsExpr a)
1177+ , ToHie (SigContext (LSig a))
1178+ , ToHie (RScoped (HsValBindsLR a a))
1179+ , Data (StmtLR a a (Located (HsExpr a)))
1180+ , Data (HsLocalBinds a)
1181+ ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
1182+ toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM
1183+ [ toHie $ PS Nothing sc NoScope pat
1184+ , toHie expr
1185+ ]
1186+ toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM
1187+ [ toHie $ listScopes NoScope stmts
1188+ , toHie $ PS Nothing sc NoScope pat
1189+ ]
1190+ toHie (RS _ (XApplicativeArg _)) = pure []
1191+
1192+instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where
1193+ toHie (PrefixCon args) = toHie args
1194+ toHie (RecCon rec) = toHie rec
1195+ toHie (InfixCon a b) = concatM [ toHie a, toHie b]
1196+
1197+instance ( ToHie (LHsCmd a)
1198+ , Data (HsCmdTop a)
1199+ ) => ToHie (LHsCmdTop a) where
1200+ toHie (L span top) = concatM $ makeNode top span : case top of
1201+ HsCmdTop _ cmd ->
1202+ [ toHie cmd
1203+ ]
1204+ XCmdTop _ -> []
1205+
1206+instance ( a ~ GhcPass p
1207+ , ToHie (PScoped (LPat a))
1208+ , ToHie (BindContext (LHsBind a))
1209+ , ToHie (LHsExpr a)
1210+ , ToHie (MatchGroup a (LHsCmd a))
1211+ , ToHie (SigContext (LSig a))
1212+ , ToHie (RScoped (HsValBindsLR a a))
1213+ , Data (HsCmd a)
1214+ , Data (HsCmdTop a)
1215+ , Data (StmtLR a a (Located (HsCmd a)))
1216+ , Data (HsLocalBinds a)
1217+ , Data (StmtLR a a (Located (HsExpr a)))
1218+ ) => ToHie (LHsCmd (GhcPass p)) where
1219+ toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of
1220+ HsCmdArrApp _ a b _ _ ->
1221+ [ toHie a
1222+ , toHie b
1223+ ]
1224+ HsCmdArrForm _ a _ _ cmdtops ->
1225+ [ toHie a
1226+ , toHie cmdtops
1227+ ]
1228+ HsCmdApp _ a b ->
1229+ [ toHie a
1230+ , toHie b
1231+ ]
1232+ HsCmdLam _ mg ->
1233+ [ toHie mg
1234+ ]
1235+ HsCmdPar _ a ->
1236+ [ toHie a
1237+ ]
1238+ HsCmdCase _ expr alts ->
1239+ [ toHie expr
1240+ , toHie alts
1241+ ]
1242+ HsCmdIf _ _ a b c ->
1243+ [ toHie a
1244+ , toHie b
1245+ , toHie c
1246+ ]
1247+ HsCmdLet _ binds cmd' ->
1248+ [ toHie $ RS (mkLScope cmd') binds
1249+ , toHie cmd'
1250+ ]
1251+ HsCmdDo _ (L ispan stmts) ->
1252+ [ pure $ locOnly ispan
1253+ , toHie $ listScopes NoScope stmts
1254+ ]
1255+ HsCmdWrap _ _ _ -> []
1256+ XCmd _ -> []
1257+
1258+instance ToHie (TyClGroup GhcRn) where
1259+ toHie TyClGroup{ group_tyclds = classes
1260+ , group_roles = roles
1261+ , group_kisigs = sigs
1262+ , group_instds = instances } =
1263+ concatM
1264+ [ toHie classes
1265+ , toHie sigs
1266+ , toHie roles
1267+ , toHie instances
1268+ ]
1269+ toHie (XTyClGroup _) = pure []
1270+
1271+instance ToHie (LTyClDecl GhcRn) where
1272+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1273+ FamDecl {tcdFam = fdecl} ->
1274+ [ toHie (L span fdecl)
1275+ ]
1276+ SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->
1277+ [ toHie $ C (Decl SynDec $ getRealSpan span) name
1278+ , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars
1279+ , toHie typ
1280+ ]
1281+ DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->
1282+ [ toHie $ C (Decl DataDec $ getRealSpan span) name
1283+ , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars
1284+ , toHie defn
1285+ ]
1286+ where
1287+ quant_scope = mkLScope $ dd_ctxt defn
1288+ rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc
1289+ sig_sc = maybe NoScope mkLScope $ dd_kindSig defn
1290+ con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn
1291+ deriv_sc = mkLScope $ dd_derivs defn
1292+ ClassDecl { tcdCtxt = context
1293+ , tcdLName = name
1294+ , tcdTyVars = vars
1295+ , tcdFDs = deps
1296+ , tcdSigs = sigs
1297+ , tcdMeths = meths
1298+ , tcdATs = typs
1299+ , tcdATDefs = deftyps
1300+ } ->
1301+ [ toHie $ C (Decl ClassDec $ getRealSpan span) name
1302+ , toHie context
1303+ , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars
1304+ , toHie deps
1305+ , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs
1306+ , toHie $ fmap (BC InstanceBind ModuleScope) meths
1307+ , toHie typs
1308+ , concatMapM (pure . locOnly . getLoc) deftyps
1309+ , toHie deftyps
1310+ ]
1311+ where
1312+ context_scope = mkLScope context
1313+ rhs_scope = foldl1' combineScopes $ map mkScope
1314+ [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
1315+ XTyClDecl _ -> []
1316+
1317+instance ToHie (LFamilyDecl GhcRn) where
1318+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1319+ FamilyDecl _ info name vars _ sig inj ->
1320+ [ toHie $ C (Decl FamDec $ getRealSpan span) name
1321+ , toHie $ TS (ResolvedScopes [rhsSpan]) vars
1322+ , toHie info
1323+ , toHie $ RS injSpan sig
1324+ , toHie inj
1325+ ]
1326+ where
1327+ rhsSpan = sigSpan `combineScopes` injSpan
1328+ sigSpan = mkScope $ getLoc sig
1329+ injSpan = maybe NoScope (mkScope . getLoc) inj
1330+ XFamilyDecl _ -> []
1331+
1332+instance ToHie (FamilyInfo GhcRn) where
1333+ toHie (ClosedTypeFamily (Just eqns)) = concatM $
1334+ [ concatMapM (pure . locOnly . getLoc) eqns
1335+ , toHie $ map go eqns
1336+ ]
1337+ where
1338+ go (L l ib) = TS (ResolvedScopes [mkScope l]) ib
1339+ toHie _ = pure []
1340+
1341+instance ToHie (RScoped (LFamilyResultSig GhcRn)) where
1342+ toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of
1343+ NoSig _ ->
1344+ []
1345+ KindSig _ k ->
1346+ [ toHie k
1347+ ]
1348+ TyVarSig _ bndr ->
1349+ [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr
1350+ ]
1351+ XFamilyResultSig _ -> []
1352+
1353+instance ToHie (Located (FunDep (Located Name))) where
1354+ toHie (L span fd@(lhs, rhs)) = concatM $
1355+ [ makeNode fd span
1356+ , toHie $ map (C Use) lhs
1357+ , toHie $ map (C Use) rhs
1358+ ]
1359+
1360+instance (ToHie rhs, HasLoc rhs)
1361+ => ToHie (TScoped (FamEqn GhcRn rhs)) where
1362+ toHie (TS _ f) = toHie f
1363+
1364+instance (ToHie rhs, HasLoc rhs)
1365+ => ToHie (FamEqn GhcRn rhs) where
1366+ toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $
1367+ [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var
1368+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
1369+ , toHie pats
1370+ , toHie rhs
1371+ ]
1372+ where scope = combineScopes patsScope rhsScope
1373+ patsScope = mkScope (loc pats)
1374+ rhsScope = mkScope (loc rhs)
1375+ toHie (XFamEqn _) = pure []
1376+
1377+instance ToHie (LInjectivityAnn GhcRn) where
1378+ toHie (L span ann) = concatM $ makeNode ann span : case ann of
1379+ InjectivityAnn lhs rhs ->
1380+ [ toHie $ C Use lhs
1381+ , toHie $ map (C Use) rhs
1382+ ]
1383+
1384+instance ToHie (HsDataDefn GhcRn) where
1385+ toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM
1386+ [ toHie ctx
1387+ , toHie mkind
1388+ , toHie cons
1389+ , toHie derivs
1390+ ]
1391+ toHie (XHsDataDefn _) = pure []
1392+
1393+instance ToHie (HsDeriving GhcRn) where
1394+ toHie (L span clauses) = concatM
1395+ [ pure $ locOnly span
1396+ , toHie clauses
1397+ ]
1398+
1399+instance ToHie (LHsDerivingClause GhcRn) where
1400+ toHie (L span cl) = concatM $ makeNode cl span : case cl of
1401+ HsDerivingClause _ strat (L ispan tys) ->
1402+ [ toHie strat
1403+ , pure $ locOnly ispan
1404+ , toHie $ map (TS (ResolvedScopes [])) tys
1405+ ]
1406+ XHsDerivingClause _ -> []
1407+
1408+instance ToHie (Located (DerivStrategy GhcRn)) where
1409+ toHie (L span strat) = concatM $ makeNode strat span : case strat of
1410+ StockStrategy -> []
1411+ AnyclassStrategy -> []
1412+ NewtypeStrategy -> []
1413+ ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]
1414+
1415+instance ToHie (Located OverlapMode) where
1416+ toHie (L span _) = pure $ locOnly span
1417+
1418+instance ToHie (LConDecl GhcRn) where
1419+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1420+ ConDeclGADT { con_names = names, con_qvars = qvars
1421+ , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
1422+ [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names
1423+ , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars
1424+ , toHie ctx
1425+ , toHie args
1426+ , toHie typ
1427+ ]
1428+ where
1429+ rhsScope = combineScopes argsScope tyScope
1430+ ctxScope = maybe NoScope mkLScope ctx
1431+ argsScope = condecl_scope args
1432+ tyScope = mkLScope typ
1433+ ConDeclH98 { con_name = name, con_ex_tvs = qvars
1434+ , con_mb_cxt = ctx, con_args = dets } ->
1435+ [ toHie $ C (Decl ConDec $ getRealSpan span) name
1436+ , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars
1437+ , toHie ctx
1438+ , toHie dets
1439+ ]
1440+ where
1441+ rhsScope = combineScopes ctxScope argsScope
1442+ ctxScope = maybe NoScope mkLScope ctx
1443+ argsScope = condecl_scope dets
1444+ XConDecl _ -> []
1445+ where condecl_scope args = case args of
1446+ PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs
1447+ InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)
1448+ RecCon x -> mkLScope x
1449+
1450+instance ToHie (Located [LConDeclField GhcRn]) where
1451+ toHie (L span decls) = concatM $
1452+ [ pure $ locOnly span
1453+ , toHie decls
1454+ ]
1455+
1456+instance ( HasLoc thing
1457+ , ToHie (TScoped thing)
1458+ ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where
1459+ toHie (TS sc (HsIB ibrn a)) = concatM $
1460+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
1461+ , toHie $ TS sc a
1462+ ]
1463+ where span = loc a
1464+ toHie (TS _ (XHsImplicitBndrs _)) = pure []
1465+
1466+instance ( HasLoc thing
1467+ , ToHie (TScoped thing)
1468+ ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where
1469+ toHie (TS sc (HsWC names a)) = concatM $
1470+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
1471+ , toHie $ TS sc a
1472+ ]
1473+ where span = loc a
1474+ toHie (TS _ (XHsWildCardBndrs _)) = pure []
1475+
1476+instance ToHie (LStandaloneKindSig GhcRn) where
1477+ toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]
1478+
1479+instance ToHie (StandaloneKindSig GhcRn) where
1480+ toHie sig = concatM $ case sig of
1481+ StandaloneKindSig _ name typ ->
1482+ [ toHie $ C TyDecl name
1483+ , toHie $ TS (ResolvedScopes []) typ
1484+ ]
1485+ XStandaloneKindSig _ -> []
1486+
1487+instance ToHie (SigContext (LSig GhcRn)) where
1488+ toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of
1489+ TypeSig _ names typ ->
1490+ [ toHie $ map (C TyDecl) names
1491+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1492+ ]
1493+ PatSynSig _ names typ ->
1494+ [ toHie $ map (C TyDecl) names
1495+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1496+ ]
1497+ ClassOpSig _ _ names typ ->
1498+ [ case styp of
1499+ ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names
1500+ _ -> toHie $ map (C $ TyDecl) names
1501+ , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
1502+ ]
1503+ IdSig _ _ -> []
1504+ FixSig _ fsig ->
1505+ [ toHie $ L sp fsig
1506+ ]
1507+ InlineSig _ name _ ->
1508+ [ toHie $ (C Use) name
1509+ ]
1510+ SpecSig _ name typs _ ->
1511+ [ toHie $ (C Use) name
1512+ , toHie $ map (TS (ResolvedScopes [])) typs
1513+ ]
1514+ SpecInstSig _ _ typ ->
1515+ [ toHie $ TS (ResolvedScopes []) typ
1516+ ]
1517+ MinimalSig _ _ form ->
1518+ [ toHie form
1519+ ]
1520+ SCCFunSig _ _ name mtxt ->
1521+ [ toHie $ (C Use) name
1522+ , pure $ maybe [] (locOnly . getLoc) mtxt
1523+ ]
1524+ CompleteMatchSig _ _ (L ispan names) typ ->
1525+ [ pure $ locOnly ispan
1526+ , toHie $ map (C Use) names
1527+ , toHie $ fmap (C Use) typ
1528+ ]
1529+ XSig _ -> []
1530+
1531+instance ToHie (LHsType GhcRn) where
1532+ toHie x = toHie $ TS (ResolvedScopes []) x
1533+
1534+instance ToHie (TScoped (LHsType GhcRn)) where
1535+ toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of
1536+ HsForAllTy _ _ bndrs body ->
1537+ [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs
1538+ , toHie body
1539+ ]
1540+ HsQualTy _ ctx body ->
1541+ [ toHie ctx
1542+ , toHie body
1543+ ]
1544+ HsTyVar _ _ var ->
1545+ [ toHie $ C Use var
1546+ ]
1547+ HsAppTy _ a b ->
1548+ [ toHie a
1549+ , toHie b
1550+ ]
1551+ HsAppKindTy _ ty ki ->
1552+ [ toHie ty
1553+ , toHie $ TS (ResolvedScopes []) ki
1554+ ]
1555+ HsFunTy _ a b ->
1556+ [ toHie a
1557+ , toHie b
1558+ ]
1559+ HsListTy _ a ->
1560+ [ toHie a
1561+ ]
1562+ HsTupleTy _ _ tys ->
1563+ [ toHie tys
1564+ ]
1565+ HsSumTy _ tys ->
1566+ [ toHie tys
1567+ ]
1568+ HsOpTy _ a op b ->
1569+ [ toHie a
1570+ , toHie $ C Use op
1571+ , toHie b
1572+ ]
1573+ HsParTy _ a ->
1574+ [ toHie a
1575+ ]
1576+ HsIParamTy _ ip ty ->
1577+ [ toHie ip
1578+ , toHie ty
1579+ ]
1580+ HsKindSig _ a b ->
1581+ [ toHie a
1582+ , toHie b
1583+ ]
1584+ HsSpliceTy _ a ->
1585+ [ toHie $ L span a
1586+ ]
1587+ HsDocTy _ a _ ->
1588+ [ toHie a
1589+ ]
1590+ HsBangTy _ _ ty ->
1591+ [ toHie ty
1592+ ]
1593+ HsRecTy _ fields ->
1594+ [ toHie fields
1595+ ]
1596+ HsExplicitListTy _ _ tys ->
1597+ [ toHie tys
1598+ ]
1599+ HsExplicitTupleTy _ tys ->
1600+ [ toHie tys
1601+ ]
1602+ HsTyLit _ _ -> []
1603+ HsWildCardTy _ -> []
1604+ HsStarTy _ _ -> []
1605+ XHsType _ -> []
1606+
1607+instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
1608+ toHie (HsValArg tm) = toHie tm
1609+ toHie (HsTypeArg _ ty) = toHie ty
1610+ toHie (HsArgPar sp) = pure $ locOnly sp
1611+
1612+instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where
1613+ toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
1614+ UserTyVar _ var ->
1615+ [ toHie $ C (TyVarBind sc tsc) var
1616+ ]
1617+ KindedTyVar _ var kind ->
1618+ [ toHie $ C (TyVarBind sc tsc) var
1619+ , toHie kind
1620+ ]
1621+ XTyVarBndr _ -> []
1622+
1623+instance ToHie (TScoped (LHsQTyVars GhcRn)) where
1624+ toHie (TS sc (HsQTvs implicits vars)) = concatM $
1625+ [ pure $ bindingsOnly bindings
1626+ , toHie $ tvScopes sc NoScope vars
1627+ ]
1628+ where
1629+ varLoc = loc vars
1630+ bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits
1631+ toHie (TS _ (XLHsQTyVars _)) = pure []
1632+
1633+instance ToHie (LHsContext GhcRn) where
1634+ toHie (L span tys) = concatM $
1635+ [ pure $ locOnly span
1636+ , toHie tys
1637+ ]
1638+
1639+instance ToHie (LConDeclField GhcRn) where
1640+ toHie (L span field) = concatM $ makeNode field span : case field of
1641+ ConDeclField _ fields typ _ ->
1642+ [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields
1643+ , toHie typ
1644+ ]
1645+ XConDeclField _ -> []
1646+
1647+instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
1648+ toHie (From expr) = toHie expr
1649+ toHie (FromThen a b) = concatM $
1650+ [ toHie a
1651+ , toHie b
1652+ ]
1653+ toHie (FromTo a b) = concatM $
1654+ [ toHie a
1655+ , toHie b
1656+ ]
1657+ toHie (FromThenTo a b c) = concatM $
1658+ [ toHie a
1659+ , toHie b
1660+ , toHie c
1661+ ]
1662+
1663+instance ToHie (LSpliceDecl GhcRn) where
1664+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1665+ SpliceDecl _ splice _ ->
1666+ [ toHie splice
1667+ ]
1668+ XSpliceDecl _ -> []
1669+
1670+instance ToHie (HsBracket a) where
1671+ toHie _ = pure []
1672+
1673+instance ToHie PendingRnSplice where
1674+ toHie _ = pure []
1675+
1676+instance ToHie PendingTcSplice where
1677+ toHie _ = pure []
1678+
1679+instance ToHie (LBooleanFormula (Located Name)) where
1680+ toHie (L span form) = concatM $ makeNode form span : case form of
1681+ Var a ->
1682+ [ toHie $ C Use a
1683+ ]
1684+ And forms ->
1685+ [ toHie forms
1686+ ]
1687+ Or forms ->
1688+ [ toHie forms
1689+ ]
1690+ Parens f ->
1691+ [ toHie f
1692+ ]
1693+
1694+instance ToHie (Located HsIPName) where
1695+ toHie (L span e) = makeNode e span
1696+
1697+instance ( ToHie (LHsExpr a)
1698+ , Data (HsSplice a)
1699+ ) => ToHie (Located (HsSplice a)) where
1700+ toHie (L span sp) = concatM $ makeNode sp span : case sp of
1701+ HsTypedSplice _ _ _ expr ->
1702+ [ toHie expr
1703+ ]
1704+ HsUntypedSplice _ _ _ expr ->
1705+ [ toHie expr
1706+ ]
1707+ HsQuasiQuote _ _ _ ispan _ ->
1708+ [ pure $ locOnly ispan
1709+ ]
1710+ HsSpliced _ _ _ ->
1711+ []
1712+ HsSplicedT _ ->
1713+ []
1714+ XSplice _ -> []
1715+
1716+instance ToHie (LRoleAnnotDecl GhcRn) where
1717+ toHie (L span annot) = concatM $ makeNode annot span : case annot of
1718+ RoleAnnotDecl _ var roles ->
1719+ [ toHie $ C Use var
1720+ , concatMapM (pure . locOnly . getLoc) roles
1721+ ]
1722+ XRoleAnnotDecl _ -> []
1723+
1724+instance ToHie (LInstDecl GhcRn) where
1725+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1726+ ClsInstD _ d ->
1727+ [ toHie $ L span d
1728+ ]
1729+ DataFamInstD _ d ->
1730+ [ toHie $ L span d
1731+ ]
1732+ TyFamInstD _ d ->
1733+ [ toHie $ L span d
1734+ ]
1735+ XInstDecl _ -> []
1736+
1737+instance ToHie (LClsInstDecl GhcRn) where
1738+ toHie (L span decl) = concatM
1739+ [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
1740+ , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
1741+ , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl
1742+ , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl
1743+ , toHie $ cid_tyfam_insts decl
1744+ , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl
1745+ , toHie $ cid_datafam_insts decl
1746+ , toHie $ cid_overlap_mode decl
1747+ ]
1748+
1749+instance ToHie (LDataFamInstDecl GhcRn) where
1750+ toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
1751+
1752+instance ToHie (LTyFamInstDecl GhcRn) where
1753+ toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
1754+
1755+instance ToHie (Context a)
1756+ => ToHie (PatSynFieldContext (RecordPatSynField a)) where
1757+ toHie (PSC sp (RecordPatSynField a b)) = concatM $
1758+ [ toHie $ C (RecField RecFieldDecl sp) a
1759+ , toHie $ C Use b
1760+ ]
1761+
1762+instance ToHie (LDerivDecl GhcRn) where
1763+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1764+ DerivDecl _ typ strat overlap ->
1765+ [ toHie $ TS (ResolvedScopes []) typ
1766+ , toHie strat
1767+ , toHie overlap
1768+ ]
1769+ XDerivDecl _ -> []
1770+
1771+instance ToHie (LFixitySig GhcRn) where
1772+ toHie (L span sig) = concatM $ makeNode sig span : case sig of
1773+ FixitySig _ vars _ ->
1774+ [ toHie $ map (C Use) vars
1775+ ]
1776+ XFixitySig _ -> []
1777+
1778+instance ToHie (LDefaultDecl GhcRn) where
1779+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1780+ DefaultDecl _ typs ->
1781+ [ toHie typs
1782+ ]
1783+ XDefaultDecl _ -> []
1784+
1785+instance ToHie (LForeignDecl GhcRn) where
1786+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1787+ ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->
1788+ [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name
1789+ , toHie $ TS (ResolvedScopes []) sig
1790+ , toHie fi
1791+ ]
1792+ ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->
1793+ [ toHie $ C Use name
1794+ , toHie $ TS (ResolvedScopes []) sig
1795+ , toHie fe
1796+ ]
1797+ XForeignDecl _ -> []
1798+
1799+instance ToHie ForeignImport where
1800+ toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $
1801+ [ locOnly a
1802+ , locOnly b
1803+ , locOnly c
1804+ ]
1805+
1806+instance ToHie ForeignExport where
1807+ toHie (CExport (L a _) (L b _)) = pure $ concat $
1808+ [ locOnly a
1809+ , locOnly b
1810+ ]
1811+
1812+instance ToHie (LWarnDecls GhcRn) where
1813+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1814+ Warnings _ _ warnings ->
1815+ [ toHie warnings
1816+ ]
1817+ XWarnDecls _ -> []
1818+
1819+instance ToHie (LWarnDecl GhcRn) where
1820+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1821+ Warning _ vars _ ->
1822+ [ toHie $ map (C Use) vars
1823+ ]
1824+ XWarnDecl _ -> []
1825+
1826+instance ToHie (LAnnDecl GhcRn) where
1827+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1828+ HsAnnotation _ _ prov expr ->
1829+ [ toHie prov
1830+ , toHie expr
1831+ ]
1832+ XAnnDecl _ -> []
1833+
1834+instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where
1835+ toHie (ValueAnnProvenance a) = toHie $ C Use a
1836+ toHie (TypeAnnProvenance a) = toHie $ C Use a
1837+ toHie ModuleAnnProvenance = pure []
1838+
1839+instance ToHie (LRuleDecls GhcRn) where
1840+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1841+ HsRules _ _ rules ->
1842+ [ toHie rules
1843+ ]
1844+ XRuleDecls _ -> []
1845+
1846+instance ToHie (LRuleDecl GhcRn) where
1847+ toHie (L _ (XRuleDecl _)) = pure []
1848+ toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
1849+ [ makeNode r span
1850+ , pure $ locOnly $ getLoc rname
1851+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
1852+ , toHie $ map (RS $ mkScope span) bndrs
1853+ , toHie exprA
1854+ , toHie exprB
1855+ ]
1856+ where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc
1857+ bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)
1858+ exprA_sc = mkLScope exprA
1859+ exprB_sc = mkLScope exprB
1860+
1861+instance ToHie (RScoped (LRuleBndr GhcRn)) where
1862+ toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
1863+ RuleBndr _ var ->
1864+ [ toHie $ C (ValBind RegularBind sc Nothing) var
1865+ ]
1866+ RuleBndrSig _ var typ ->
1867+ [ toHie $ C (ValBind RegularBind sc Nothing) var
1868+ , toHie $ TS (ResolvedScopes [sc]) typ
1869+ ]
1870+ XRuleBndr _ -> []
1871+
1872+instance ToHie (LImportDecl GhcRn) where
1873+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1874+ ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->
1875+ [ toHie $ IEC Import name
1876+ , toHie $ fmap (IEC ImportAs) as
1877+ , maybe (pure []) goIE hidden
1878+ ]
1879+ XImportDecl _ -> []
1880+ where
1881+ goIE (hiding, (L sp liens)) = concatM $
1882+ [ pure $ locOnly sp
1883+ , toHie $ map (IEC c) liens
1884+ ]
1885+ where
1886+ c = if hiding then ImportHiding else Import
1887+
1888+instance ToHie (IEContext (LIE GhcRn)) where
1889+ toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of
1890+ IEVar _ n ->
1891+ [ toHie $ IEC c n
1892+ ]
1893+ IEThingAbs _ n ->
1894+ [ toHie $ IEC c n
1895+ ]
1896+ IEThingAll _ n ->
1897+ [ toHie $ IEC c n
1898+ ]
1899+ IEThingWith _ n _ ns flds ->
1900+ [ toHie $ IEC c n
1901+ , toHie $ map (IEC c) ns
1902+ , toHie $ map (IEC c) flds
1903+ ]
1904+ IEModuleContents _ n ->
1905+ [ toHie $ IEC c n
1906+ ]
1907+ IEGroup _ _ _ -> []
1908+ IEDoc _ _ -> []
1909+ IEDocNamed _ _ -> []
1910+ XIE _ -> []
1911+
1912+instance ToHie (IEContext (LIEWrappedName Name)) where
1913+ toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of
1914+ IEName n ->
1915+ [ toHie $ C (IEThing c) n
1916+ ]
1917+ IEPattern p ->
1918+ [ toHie $ C (IEThing c) p
1919+ ]
1920+ IEType n ->
1921+ [ toHie $ C (IEThing c) n
1922+ ]
1923+
1924+instance ToHie (IEContext (Located (FieldLbl Name))) where
1925+ toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of
1926+ FieldLabel _ _ n ->
1927+ [ toHie $ C (IEThing c) $ L span n
1928+ ]
src-ghc88/Development/IDE/GHC/HieAst.hsnew file+1789
@@ -0,0 +1,1789 @@
1+
2+{-
3+Forked from GHC v8.8.1 to work around the readFile side effect in mkHiefile
4+
5+Main functions for .hie file generation
6+-}
7+{- HLINT ignore -}
8+{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE FlexibleInstances #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+{-# LANGUAGE FlexibleContexts #-}
12+{-# LANGUAGE TypeSynonymInstances #-}
13+{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE TypeApplications #-}
16+{-# LANGUAGE AllowAmbiguousTypes #-}
17+{-# LANGUAGE ViewPatterns #-}
18+{-# LANGUAGE DeriveDataTypeable #-}
19+module Development.IDE.GHC.HieAst ( mkHieFile ) where
20+
21+import Avail ( Avails )
22+import Bag ( Bag, bagToList )
23+import BasicTypes
24+import BooleanFormula
25+import Class ( FunDep )
26+import CoreUtils ( exprType )
27+import ConLike ( conLikeName )
28+import Desugar ( deSugarExpr )
29+import FieldLabel
30+import HsSyn
31+import HscTypes
32+import Module ( ModuleName, ml_hs_file )
33+import MonadUtils ( concatMapM, liftIO )
34+import Name ( Name, nameSrcSpan, setNameLoc )
35+import SrcLoc
36+import TcHsSyn ( hsLitType, hsPatType )
37+import Type ( mkFunTys, Type )
38+import TysWiredIn ( mkListTy, mkSumTy )
39+import Var ( Id, Var, setVarName, varName, varType )
40+import TcRnTypes
41+import MkIface ( mkIfaceExports )
42+
43+import HieTypes
44+import HieUtils
45+
46+import qualified Data.Array as A
47+import qualified Data.ByteString as BS
48+import qualified Data.Map as M
49+import qualified Data.Set as S
50+import Data.Data ( Data, Typeable )
51+import Data.List (foldl', foldl1' )
52+import Data.Maybe ( listToMaybe )
53+import Control.Monad.Trans.Reader
54+import Control.Monad.Trans.Class ( lift )
55+
56+-- These synonyms match those defined in main/GHC.hs
57+type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn]
58+ , Maybe [(LIE GhcRn, Avails)]
59+ , Maybe LHsDocString )
60+type TypecheckedSource = LHsBinds GhcTc
61+
62+
63+{- Note [Name Remapping]
64+The Typechecker introduces new names for mono names in AbsBinds.
65+We don't care about the distinction between mono and poly bindings,
66+so we replace all occurrences of the mono name with the poly name.
67+-}
68+newtype HieState = HieState
69+ { name_remapping :: M.Map Name Id
70+ }
71+
72+initState :: HieState
73+initState = HieState M.empty
74+
75+class ModifyState a where -- See Note [Name Remapping]
76+ addSubstitution :: a -> a -> HieState -> HieState
77+
78+instance ModifyState Name where
79+ addSubstitution _ _ hs = hs
80+
81+instance ModifyState Id where
82+ addSubstitution mono poly hs =
83+ hs{name_remapping = M.insert (varName mono) poly (name_remapping hs)}
84+
85+modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState
86+modifyState = foldr go id
87+ where
88+ go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f
89+ go _ f = f
90+
91+type HieM = ReaderT HieState Hsc
92+
93+-- | Construct an 'HieFile' from the outputs of the typechecker.
94+mkHieFile :: ModSummary
95+ -> TcGblEnv
96+ -> RenamedSource
97+ -> BS.ByteString
98+ -> Hsc HieFile
99+mkHieFile ms ts rs src = do
100+ let tc_binds = tcg_binds ts
101+ (asts', arr) <- getCompressedAsts tc_binds rs
102+ let Just src_file = ml_hs_file $ ms_location ms
103+ return $ HieFile
104+ { hie_hs_file = src_file
105+ , hie_module = ms_mod ms
106+ , hie_types = arr
107+ , hie_asts = asts'
108+ -- mkIfaceExports sorts the AvailInfos for stability
109+ , hie_exports = mkIfaceExports (tcg_exports ts)
110+ , hie_hs_src = src
111+ }
112+
113+getCompressedAsts :: TypecheckedSource -> RenamedSource
114+ -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
115+getCompressedAsts ts rs = do
116+ asts <- enrichHie ts rs
117+ return $ compressTypes asts
118+
119+enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)
120+enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do
121+ tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts
122+ rasts <- processGrp hsGrp
123+ imps <- toHie $ filter (not . ideclImplicit . unLoc) imports
124+ exps <- toHie $ fmap (map $ IEC Export . fst) exports
125+ let spanFile children = case children of
126+ [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)
127+ _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)
128+ (realSrcSpanEnd $ nodeSpan $ last children)
129+
130+ modulify xs =
131+ Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs
132+
133+ asts = HieASTs
134+ $ resolveTyVarScopes
135+ $ M.map (modulify . mergeSortAsts)
136+ $ M.fromListWith (++)
137+ $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
138+
139+ flat_asts = concat
140+ [ tasts
141+ , rasts
142+ , imps
143+ , exps
144+ ]
145+ return asts
146+ where
147+ processGrp grp = concatM
148+ [ toHie $ fmap (RS ModuleScope ) hs_valds grp
149+ , toHie $ hs_splcds grp
150+ , toHie $ hs_tyclds grp
151+ , toHie $ hs_derivds grp
152+ , toHie $ hs_fixds grp
153+ , toHie $ hs_defds grp
154+ , toHie $ hs_fords grp
155+ , toHie $ hs_warnds grp
156+ , toHie $ hs_annds grp
157+ , toHie $ hs_ruleds grp
158+ ]
159+
160+getRealSpan :: SrcSpan -> Maybe Span
161+getRealSpan (RealSrcSpan sp) = Just sp
162+getRealSpan _ = Nothing
163+
164+grhss_span :: GRHSs p body -> SrcSpan
165+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)
166+grhss_span (XGRHSs _) = error "XGRHS has no span"
167+
168+bindingsOnly :: [Context Name] -> [HieAST a]
169+bindingsOnly [] = []
170+bindingsOnly (C c n : xs) = case nameSrcSpan n of
171+ RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs
172+ where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
173+ info = mempty{identInfo = S.singleton c}
174+ _ -> bindingsOnly xs
175+
176+concatM :: Monad m => [m [a]] -> m [a]
177+concatM xs = concat <$> sequence xs
178+
179+{- Note [Capturing Scopes and other non local information]
180+toHie is a local tranformation, but scopes of bindings cannot be known locally,
181+hence we have to push the relevant info down into the binding nodes.
182+We use the following types (*Context and *Scoped) to wrap things and
183+carry the required info
184+(Maybe Span) always carries the span of the entire binding, including rhs
185+-}
186+data Context a = C ContextInfo a -- Used for names and bindings
187+
188+data RContext a = RC RecFieldContext a
189+data RFContext a = RFC RecFieldContext (Maybe Span) a
190+-- ^ context for record fields
191+
192+data IEContext a = IEC IEType a
193+-- ^ context for imports/exports
194+
195+data BindContext a = BC BindType Scope a
196+-- ^ context for imports/exports
197+
198+data PatSynFieldContext a = PSC (Maybe Span) a
199+-- ^ context for pattern synonym fields.
200+
201+data SigContext a = SC SigInfo a
202+-- ^ context for type signatures
203+
204+data SigInfo = SI SigType (Maybe Span)
205+
206+data SigType = BindSig | ClassSig | InstSig
207+
208+data RScoped a = RS Scope a
209+-- ^ Scope spans over everything to the right of a, (mostly) not
210+-- including a itself
211+-- (Includes a in a few special cases like recursive do bindings) or
212+-- let/where bindings
213+
214+-- | Pattern scope
215+data PScoped a = PS (Maybe Span)
216+ Scope -- ^ use site of the pattern
217+ Scope -- ^ pattern to the right of a, not including a
218+ a
219+ deriving (Typeable, Data) -- Pattern Scope
220+
221+{- Note [TyVar Scopes]
222+Due to -XScopedTypeVariables, type variables can be in scope quite far from
223+their original binding. We resolve the scope of these type variables
224+in a separate pass
225+-}
226+data TScoped a = TS TyVarScope a -- TyVarScope
227+
228+data TVScoped a = TVS TyVarScope Scope a -- TyVarScope
229+-- ^ First scope remains constant
230+-- Second scope is used to build up the scope of a tyvar over
231+-- things to its right, ala RScoped
232+
233+-- | Each element scopes over the elements to the right
234+listScopes :: Scope -> [Located a] -> [RScoped (Located a)]
235+listScopes _ [] = []
236+listScopes rhsScope [pat] = [RS rhsScope pat]
237+listScopes rhsScope (pat : pats) = RS sc pat : pats'
238+ where
239+ pats'@((RS scope p):_) = listScopes rhsScope pats
240+ sc = combineScopes scope $ mkScope $ getLoc p
241+
242+-- | 'listScopes' specialised to 'PScoped' things
243+patScopes
244+ :: Maybe Span
245+ -> Scope
246+ -> Scope
247+ -> [LPat (GhcPass p)]
248+ -> [PScoped (LPat (GhcPass p))]
249+patScopes rsp useScope patScope xs =
250+ map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $
251+ listScopes patScope (map dL xs)
252+
253+-- | 'listScopes' specialised to 'TVScoped' things
254+tvScopes
255+ :: TyVarScope
256+ -> Scope
257+ -> [LHsTyVarBndr a]
258+ -> [TVScoped (LHsTyVarBndr a)]
259+tvScopes tvScope rhsScope xs =
260+ map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs
261+
262+{- Note [Scoping Rules for SigPat]
263+Explicitly quantified variables in pattern type signatures are not
264+brought into scope in the rhs, but implicitly quantified variables
265+are (HsWC and HsIB).
266+This is unlike other signatures, where explicitly quantified variables
267+are brought into the RHS Scope
268+For example
269+foo :: forall a. ...;
270+foo = ... -- a is in scope here
271+
272+bar (x :: forall a. a -> a) = ... -- a is not in scope here
273+-- ^ a is in scope here (pattern body)
274+
275+bax (x :: a) = ... -- a is in scope here
276+Because of HsWC and HsIB pass on their scope to their children
277+we must wrap the LHsType in pattern signatures in a
278+Shielded explictly, so that the HsWC/HsIB scope is not passed
279+on the the LHsType
280+-}
281+
282+data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead
283+
284+type family ProtectedSig a where
285+ ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs
286+ GhcRn
287+ (Shielded (LHsType GhcRn)))
288+ ProtectedSig GhcTc = NoExt
289+
290+class ProtectSig a where
291+ protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a
292+
293+instance (HasLoc a) => HasLoc (Shielded a) where
294+ loc (SH _ a) = loc a
295+
296+instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where
297+ toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)
298+
299+instance ProtectSig GhcTc where
300+ protectSig _ _ = NoExt
301+
302+instance ProtectSig GhcRn where
303+ protectSig sc (HsWC a (HsIB b sig)) =
304+ HsWC a (HsIB b (SH sc sig))
305+ protectSig _ _ = error "protectSig not given HsWC (HsIB)"
306+
307+class HasLoc a where
308+ -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can
309+ -- know what their implicit bindings are scoping over
310+ loc :: a -> SrcSpan
311+
312+instance HasLoc thing => HasLoc (TScoped thing) where
313+ loc (TS _ a) = loc a
314+
315+instance HasLoc thing => HasLoc (PScoped thing) where
316+ loc (PS _ _ _ a) = loc a
317+
318+instance HasLoc (LHsQTyVars GhcRn) where
319+ loc (HsQTvs _ vs) = loc vs
320+ loc _ = noSrcSpan
321+
322+instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where
323+ loc (HsIB _ a) = loc a
324+ loc _ = noSrcSpan
325+
326+instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where
327+ loc (HsWC _ a) = loc a
328+ loc _ = noSrcSpan
329+
330+instance HasLoc (Located a) where
331+ loc (L l _) = l
332+
333+instance HasLoc a => HasLoc [a] where
334+ loc [] = noSrcSpan
335+ loc xs = foldl1' combineSrcSpans $ map loc xs
336+
337+instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where
338+ loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]
339+ loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
340+ [loc a, loc tvs, loc b, loc c]
341+ loc _ = noSrcSpan
342+instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
343+ loc (HsValArg tm) = loc tm
344+ loc (HsTypeArg _ ty) = loc ty
345+ loc (HsArgPar sp) = sp
346+
347+instance HasLoc (HsDataDefn GhcRn) where
348+ loc def@(HsDataDefn{}) = loc $ dd_cons def
349+ -- Only used for data family instances, so we only need rhs
350+ -- Most probably the rest will be unhelpful anyway
351+ loc _ = noSrcSpan
352+
353+instance HasLoc (Pat (GhcPass a)) where
354+ loc (dL -> L l _) = l
355+
356+-- | The main worker class
357+class ToHie a where
358+ toHie :: a -> HieM [HieAST Type]
359+
360+-- | Used to collect type info
361+class Data a => HasType a where
362+ getTypeNode :: a -> HieM [HieAST Type]
363+
364+instance (ToHie a) => ToHie [a] where
365+ toHie = concatMapM toHie
366+
367+instance (ToHie a) => ToHie (Bag a) where
368+ toHie = toHie . bagToList
369+
370+instance (ToHie a) => ToHie (Maybe a) where
371+ toHie = maybe (pure []) toHie
372+
373+instance ToHie (Context (Located NoExt)) where
374+ toHie _ = pure []
375+
376+instance ToHie (TScoped NoExt) where
377+ toHie _ = pure []
378+
379+instance ToHie (IEContext (Located ModuleName)) where
380+ toHie (IEC c (L (RealSrcSpan span) mname)) =
381+ pure $ [Node (NodeInfo S.empty [] idents) span []]
382+ where details = mempty{identInfo = S.singleton (IEThing c)}
383+ idents = M.singleton (Left mname) details
384+ toHie _ = pure []
385+
386+instance ToHie (Context (Located Var)) where
387+ toHie c = case c of
388+ C context (L (RealSrcSpan span) name')
389+ -> do
390+ m <- asks name_remapping
391+ let name = M.findWithDefault name' (varName name') m
392+ pure
393+ [Node
394+ (NodeInfo S.empty [] $
395+ M.singleton (Right $ varName name)
396+ (IdentifierDetails (Just $ varType name')
397+ (S.singleton context)))
398+ span
399+ []]
400+ _ -> pure []
401+
402+instance ToHie (Context (Located Name)) where
403+ toHie c = case c of
404+ C context (L (RealSrcSpan span) name') -> do
405+ m <- asks name_remapping
406+ let name = case M.lookup name' m of
407+ Just var -> varName var
408+ Nothing -> name'
409+ pure
410+ [Node
411+ (NodeInfo S.empty [] $
412+ M.singleton (Right name)
413+ (IdentifierDetails Nothing
414+ (S.singleton context)))
415+ span
416+ []]
417+ _ -> pure []
418+
419+-- | Dummy instances - never called
420+instance ToHie (TScoped (LHsSigWcType GhcTc)) where
421+ toHie _ = pure []
422+instance ToHie (TScoped (LHsWcType GhcTc)) where
423+ toHie _ = pure []
424+instance ToHie (SigContext (LSig GhcTc)) where
425+ toHie _ = pure []
426+instance ToHie (TScoped Type) where
427+ toHie _ = pure []
428+
429+instance HasType (LHsBind GhcRn) where
430+ getTypeNode (L spn bind) = makeNode bind spn
431+
432+instance HasType (LHsBind GhcTc) where
433+ getTypeNode (L spn bind) = case bind of
434+ FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)
435+ _ -> makeNode bind spn
436+
437+instance HasType (LPat GhcRn) where
438+ getTypeNode (dL -> L spn pat) = makeNode pat spn
439+
440+instance HasType (LPat GhcTc) where
441+ getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)
442+
443+instance HasType (LHsExpr GhcRn) where
444+ getTypeNode (L spn e) = makeNode e spn
445+
446+-- | This instance tries to construct 'HieAST' nodes which include the type of
447+-- the expression. It is not yet possible to do this efficiently for all
448+-- expression forms, so we skip filling in the type for those inputs.
449+--
450+-- 'HsApp', for example, doesn't have any type information available directly on
451+-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then
452+-- query the type of that. Yet both the desugaring call and the type query both
453+-- involve recursive calls to the function and argument! This is particularly
454+-- problematic when you realize that the HIE traversal will eventually visit
455+-- those nodes too and ask for their types again.
456+--
457+-- Since the above is quite costly, we just skip cases where computing the
458+-- expression's type is going to be expensive.
459+--
460+-- See #16233
461+instance HasType (LHsExpr GhcTc) where
462+ getTypeNode e@(L spn e') = lift $
463+ -- Some expression forms have their type immediately available
464+ let tyOpt = case e' of
465+ HsLit _ l -> Just (hsLitType l)
466+ HsOverLit _ o -> Just (overLitType o)
467+
468+ HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
469+ HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
470+ HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)
471+
472+ ExplicitList ty _ _ -> Just (mkListTy ty)
473+ ExplicitSum ty _ _ _ -> Just (mkSumTy ty)
474+ HsDo ty _ _ -> Just ty
475+ HsMultiIf ty _ -> Just ty
476+
477+ _ -> Nothing
478+
479+ in
480+ case tyOpt of
481+ _ | skipDesugaring e' -> fallback
482+ | otherwise -> do
483+ hs_env <- Hsc $ \e w -> return (e,w)
484+ (_,mbe) <- liftIO $ deSugarExpr hs_env e
485+ maybe fallback (makeTypeNode e' spn . exprType) mbe
486+ where
487+ fallback = makeNode e' spn
488+
489+ matchGroupType :: MatchGroupTc -> Type
490+ matchGroupType (MatchGroupTc args res) = mkFunTys args res
491+
492+ -- | Skip desugaring of these expressions for performance reasons.
493+ --
494+ -- See impact on Haddock output (esp. missing type annotations or links)
495+ -- before marking more things here as 'False'. See impact on Haddock
496+ -- performance before marking more things as 'True'.
497+ skipDesugaring :: HsExpr a -> Bool
498+ skipDesugaring e = case e of
499+ HsVar{} -> False
500+ HsUnboundVar{} -> False
501+ HsConLikeOut{} -> False
502+ HsRecFld{} -> False
503+ HsOverLabel{} -> False
504+ HsIPVar{} -> False
505+ HsWrap{} -> False
506+ _ -> True
507+
508+instance ( ToHie (Context (Located (IdP a)))
509+ , ToHie (MatchGroup a (LHsExpr a))
510+ , ToHie (PScoped (LPat a))
511+ , ToHie (GRHSs a (LHsExpr a))
512+ , ToHie (LHsExpr a)
513+ , ToHie (Located (PatSynBind a a))
514+ , HasType (LHsBind a)
515+ , ModifyState (IdP a)
516+ , Data (HsBind a)
517+ ) => ToHie (BindContext (LHsBind a)) where
518+ toHie (BC context scope b@(L span bind)) =
519+ concatM $ getTypeNode b : case bind of
520+ FunBind{fun_id = name, fun_matches = matches} ->
521+ [ toHie $ C (ValBind context scope $ getRealSpan span) name
522+ , toHie matches
523+ ]
524+ PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
525+ [ toHie $ PS (getRealSpan span) scope NoScope lhs
526+ , toHie rhs
527+ ]
528+ VarBind{var_rhs = expr} ->
529+ [ toHie expr
530+ ]
531+ AbsBinds{abs_exports = xs, abs_binds = binds} ->
532+ [ local (modifyState xs) $ -- Note [Name Remapping]
533+ toHie $ fmap (BC context scope) binds
534+ ]
535+ PatSynBind _ psb ->
536+ [ toHie $ L span psb -- PatSynBinds only occur at the top level
537+ ]
538+ XHsBindsLR _ -> []
539+
540+instance ( ToHie (LMatch a body)
541+ ) => ToHie (MatchGroup a body) where
542+ toHie mg = concatM $ case mg of
543+ MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->
544+ [ pure $ locOnly span
545+ , toHie alts
546+ ]
547+ MG{} -> []
548+ XMatchGroup _ -> []
549+
550+instance ( ToHie (Context (Located (IdP a)))
551+ , ToHie (PScoped (LPat a))
552+ , ToHie (HsPatSynDir a)
553+ ) => ToHie (Located (PatSynBind a a)) where
554+ toHie (L sp psb) = concatM $ case psb of
555+ PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->
556+ [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var
557+ , toHie $ toBind dets
558+ , toHie $ PS Nothing lhsScope NoScope pat
559+ , toHie dir
560+ ]
561+ where
562+ lhsScope = combineScopes varScope detScope
563+ varScope = mkLScope var
564+ detScope = case dets of
565+ (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args
566+ (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)
567+ (RecCon r) -> foldr go NoScope r
568+ go (RecordPatSynField a b) c = combineScopes c
569+ $ combineScopes (mkLScope a) (mkLScope b)
570+ detSpan = case detScope of
571+ LocalScope a -> Just a
572+ _ -> Nothing
573+ toBind (PrefixCon args) = PrefixCon $ map (C Use) args
574+ toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
575+ toBind (RecCon r) = RecCon $ map (PSC detSpan) r
576+ XPatSynBind _ -> []
577+
578+instance ( ToHie (MatchGroup a (LHsExpr a))
579+ ) => ToHie (HsPatSynDir a) where
580+ toHie dir = case dir of
581+ ExplicitBidirectional mg -> toHie mg
582+ _ -> pure []
583+
584+instance ( a ~ GhcPass p
585+ , ToHie body
586+ , ToHie (HsMatchContext (NameOrRdrName (IdP a)))
587+ , ToHie (PScoped (LPat a))
588+ , ToHie (GRHSs a body)
589+ , Data (Match a body)
590+ ) => ToHie (LMatch (GhcPass p) body) where
591+ toHie (L span m ) = concatM $ makeNode m span : case m of
592+ Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->
593+ [ toHie mctx
594+ , let rhsScope = mkScope $ grhss_span grhss
595+ in toHie $ patScopes Nothing rhsScope NoScope pats
596+ , toHie grhss
597+ ]
598+ XMatch _ -> []
599+
600+instance ( ToHie (Context (Located a))
601+ ) => ToHie (HsMatchContext a) where
602+ toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name
603+ toHie (StmtCtxt a) = toHie a
604+ toHie _ = pure []
605+
606+instance ( ToHie (HsMatchContext a)
607+ ) => ToHie (HsStmtContext a) where
608+ toHie (PatGuard a) = toHie a
609+ toHie (ParStmtCtxt a) = toHie a
610+ toHie (TransStmtCtxt a) = toHie a
611+ toHie _ = pure []
612+
613+instance ( a ~ GhcPass p
614+ , ToHie (Context (Located (IdP a)))
615+ , ToHie (RContext (HsRecFields a (PScoped (LPat a))))
616+ , ToHie (LHsExpr a)
617+ , ToHie (TScoped (LHsSigWcType a))
618+ , ProtectSig a
619+ , ToHie (TScoped (ProtectedSig a))
620+ , HasType (LPat a)
621+ , Data (HsSplice a)
622+ ) => ToHie (PScoped (LPat (GhcPass p))) where
623+ toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =
624+ concatM $ getTypeNode lpat : case opat of
625+ WildPat _ ->
626+ []
627+ VarPat _ lname ->
628+ [ toHie $ C (PatternBind scope pscope rsp) lname
629+ ]
630+ LazyPat _ p ->
631+ [ toHie $ PS rsp scope pscope p
632+ ]
633+ AsPat _ lname pat ->
634+ [ toHie $ C (PatternBind scope
635+ (combineScopes (mkLScope (dL pat)) pscope)
636+ rsp)
637+ lname
638+ , toHie $ PS rsp scope pscope pat
639+ ]
640+ ParPat _ pat ->
641+ [ toHie $ PS rsp scope pscope pat
642+ ]
643+ BangPat _ pat ->
644+ [ toHie $ PS rsp scope pscope pat
645+ ]
646+ ListPat _ pats ->
647+ [ toHie $ patScopes rsp scope pscope pats
648+ ]
649+ TuplePat _ pats _ ->
650+ [ toHie $ patScopes rsp scope pscope pats
651+ ]
652+ SumPat _ pat _ _ ->
653+ [ toHie $ PS rsp scope pscope pat
654+ ]
655+ ConPatIn c dets ->
656+ [ toHie $ C Use c
657+ , toHie $ contextify dets
658+ ]
659+ ConPatOut {pat_con = con, pat_args = dets}->
660+ [ toHie $ C Use $ fmap conLikeName con
661+ , toHie $ contextify dets
662+ ]
663+ ViewPat _ expr pat ->
664+ [ toHie expr
665+ , toHie $ PS rsp scope pscope pat
666+ ]
667+ SplicePat _ sp ->
668+ [ toHie $ L ospan sp
669+ ]
670+ LitPat _ _ ->
671+ []
672+ NPat _ _ _ _ ->
673+ []
674+ NPlusKPat _ n _ _ _ _ ->
675+ [ toHie $ C (PatternBind scope pscope rsp) n
676+ ]
677+ SigPat _ pat sig ->
678+ [ toHie $ PS rsp scope pscope pat
679+ , let cscope = mkLScope (dL pat) in
680+ toHie $ TS (ResolvedScopes [cscope, scope, pscope])
681+ (protectSig @a cscope sig)
682+ -- See Note [Scoping Rules for SigPat]
683+ ]
684+ CoPat _ _ _ _ ->
685+ []
686+ XPat _ -> []
687+ where
688+ contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
689+ contextify (InfixCon a b) = InfixCon a' b'
690+ where [a', b'] = patScopes rsp scope pscope [a,b]
691+ contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r
692+ contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a
693+ where
694+ go (RS fscope (L spn (HsRecField lbl pat pun))) =
695+ L spn $ HsRecField lbl (PS rsp scope fscope pat) pun
696+ scoped_fds = listScopes pscope fds
697+
698+instance ( ToHie body
699+ , ToHie (LGRHS a body)
700+ , ToHie (RScoped (LHsLocalBinds a))
701+ ) => ToHie (GRHSs a body) where
702+ toHie grhs = concatM $ case grhs of
703+ GRHSs _ grhss binds ->
704+ [ toHie grhss
705+ , toHie $ RS (mkScope $ grhss_span grhs) binds
706+ ]
707+ XGRHSs _ -> []
708+
709+instance ( ToHie (Located body)
710+ , ToHie (RScoped (GuardLStmt a))
711+ , Data (GRHS a (Located body))
712+ ) => ToHie (LGRHS a (Located body)) where
713+ toHie (L span g) = concatM $ makeNode g span : case g of
714+ GRHS _ guards body ->
715+ [ toHie $ listScopes (mkLScope body) guards
716+ , toHie body
717+ ]
718+ XGRHS _ -> []
719+
720+instance ( a ~ GhcPass p
721+ , ToHie (Context (Located (IdP a)))
722+ , HasType (LHsExpr a)
723+ , ToHie (PScoped (LPat a))
724+ , ToHie (MatchGroup a (LHsExpr a))
725+ , ToHie (LGRHS a (LHsExpr a))
726+ , ToHie (RContext (HsRecordBinds a))
727+ , ToHie (RFContext (Located (AmbiguousFieldOcc a)))
728+ , ToHie (ArithSeqInfo a)
729+ , ToHie (LHsCmdTop a)
730+ , ToHie (RScoped (GuardLStmt a))
731+ , ToHie (RScoped (LHsLocalBinds a))
732+ , ToHie (TScoped (LHsWcType (NoGhcTc a)))
733+ , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))
734+ , Data (HsExpr a)
735+ , Data (HsSplice a)
736+ , Data (HsTupArg a)
737+ , Data (AmbiguousFieldOcc a)
738+ ) => ToHie (LHsExpr (GhcPass p)) where
739+ toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
740+ HsVar _ (L _ var) ->
741+ [ toHie $ C Use (L mspan var)
742+ -- Patch up var location since typechecker removes it
743+ ]
744+ HsUnboundVar _ _ ->
745+ []
746+ HsConLikeOut _ con ->
747+ [ toHie $ C Use $ L mspan $ conLikeName con
748+ ]
749+ HsRecFld _ fld ->
750+ [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)
751+ ]
752+ HsOverLabel _ _ _ -> []
753+ HsIPVar _ _ -> []
754+ HsOverLit _ _ -> []
755+ HsLit _ _ -> []
756+ HsLam _ mg ->
757+ [ toHie mg
758+ ]
759+ HsLamCase _ mg ->
760+ [ toHie mg
761+ ]
762+ HsApp _ a b ->
763+ [ toHie a
764+ , toHie b
765+ ]
766+ HsAppType _ expr sig ->
767+ [ toHie expr
768+ , toHie $ TS (ResolvedScopes []) sig
769+ ]
770+ OpApp _ a b c ->
771+ [ toHie a
772+ , toHie b
773+ , toHie c
774+ ]
775+ NegApp _ a _ ->
776+ [ toHie a
777+ ]
778+ HsPar _ a ->
779+ [ toHie a
780+ ]
781+ SectionL _ a b ->
782+ [ toHie a
783+ , toHie b
784+ ]
785+ SectionR _ a b ->
786+ [ toHie a
787+ , toHie b
788+ ]
789+ ExplicitTuple _ args _ ->
790+ [ toHie args
791+ ]
792+ ExplicitSum _ _ _ expr ->
793+ [ toHie expr
794+ ]
795+ HsCase _ expr matches ->
796+ [ toHie expr
797+ , toHie matches
798+ ]
799+ HsIf _ _ a b c ->
800+ [ toHie a
801+ , toHie b
802+ , toHie c
803+ ]
804+ HsMultiIf _ grhss ->
805+ [ toHie grhss
806+ ]
807+ HsLet _ binds expr ->
808+ [ toHie $ RS (mkLScope expr) binds
809+ , toHie expr
810+ ]
811+ HsDo _ _ (L ispan stmts) ->
812+ [ pure $ locOnly ispan
813+ , toHie $ listScopes NoScope stmts
814+ ]
815+ ExplicitList _ _ exprs ->
816+ [ toHie exprs
817+ ]
818+ RecordCon {rcon_con_name = name, rcon_flds = binds}->
819+ [ toHie $ C Use name
820+ , toHie $ RC RecFieldAssign $ binds
821+ ]
822+ RecordUpd {rupd_expr = expr, rupd_flds = upds}->
823+ [ toHie expr
824+ , toHie $ map (RC RecFieldAssign) upds
825+ ]
826+ ExprWithTySig _ expr sig ->
827+ [ toHie expr
828+ , toHie $ TS (ResolvedScopes [mkLScope expr]) sig
829+ ]
830+ ArithSeq _ _ info ->
831+ [ toHie info
832+ ]
833+ HsSCC _ _ _ expr ->
834+ [ toHie expr
835+ ]
836+ HsCoreAnn _ _ _ expr ->
837+ [ toHie expr
838+ ]
839+ HsProc _ pat cmdtop ->
840+ [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat
841+ , toHie cmdtop
842+ ]
843+ HsStatic _ expr ->
844+ [ toHie expr
845+ ]
846+ HsArrApp _ a b _ _ ->
847+ [ toHie a
848+ , toHie b
849+ ]
850+ HsArrForm _ expr _ cmds ->
851+ [ toHie expr
852+ , toHie cmds
853+ ]
854+ HsTick _ _ expr ->
855+ [ toHie expr
856+ ]
857+ HsBinTick _ _ _ expr ->
858+ [ toHie expr
859+ ]
860+ HsTickPragma _ _ _ _ expr ->
861+ [ toHie expr
862+ ]
863+ HsWrap _ _ a ->
864+ [ toHie $ L mspan a
865+ ]
866+ HsBracket _ b ->
867+ [ toHie b
868+ ]
869+ HsRnBracketOut _ b p ->
870+ [ toHie b
871+ , toHie p
872+ ]
873+ HsTcBracketOut _ b p ->
874+ [ toHie b
875+ , toHie p
876+ ]
877+ HsSpliceE _ x ->
878+ [ toHie $ L mspan x
879+ ]
880+ EWildPat _ -> []
881+ EAsPat _ a b ->
882+ [ toHie $ C Use a
883+ , toHie b
884+ ]
885+ EViewPat _ a b ->
886+ [ toHie a
887+ , toHie b
888+ ]
889+ ELazyPat _ a ->
890+ [ toHie a
891+ ]
892+ XExpr _ -> []
893+
894+instance ( a ~ GhcPass p
895+ , ToHie (LHsExpr a)
896+ , Data (HsTupArg a)
897+ ) => ToHie (LHsTupArg (GhcPass p)) where
898+ toHie (L span arg) = concatM $ makeNode arg span : case arg of
899+ Present _ expr ->
900+ [ toHie expr
901+ ]
902+ Missing _ -> []
903+ XTupArg _ -> []
904+
905+instance ( a ~ GhcPass p
906+ , ToHie (PScoped (LPat a))
907+ , ToHie (LHsExpr a)
908+ , ToHie (SigContext (LSig a))
909+ , ToHie (RScoped (LHsLocalBinds a))
910+ , ToHie (RScoped (ApplicativeArg a))
911+ , ToHie (Located body)
912+ , Data (StmtLR a a (Located body))
913+ , Data (StmtLR a a (Located (HsExpr a)))
914+ ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where
915+ toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of
916+ LastStmt _ body _ _ ->
917+ [ toHie body
918+ ]
919+ BindStmt _ pat body _ _ ->
920+ [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat
921+ , toHie body
922+ ]
923+ ApplicativeStmt _ stmts _ ->
924+ [ concatMapM (toHie . RS scope . snd) stmts
925+ ]
926+ BodyStmt _ body _ _ ->
927+ [ toHie body
928+ ]
929+ LetStmt _ binds ->
930+ [ toHie $ RS scope binds
931+ ]
932+ ParStmt _ parstmts _ _ ->
933+ [ concatMapM (\(ParStmtBlock _ stmts _ _) ->
934+ toHie $ listScopes NoScope stmts)
935+ parstmts
936+ ]
937+ TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->
938+ [ toHie $ listScopes scope stmts
939+ , toHie using
940+ , toHie by
941+ ]
942+ RecStmt {recS_stmts = stmts} ->
943+ [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts
944+ ]
945+ XStmtLR _ -> []
946+
947+instance ( ToHie (LHsExpr a)
948+ , ToHie (PScoped (LPat a))
949+ , ToHie (BindContext (LHsBind a))
950+ , ToHie (SigContext (LSig a))
951+ , ToHie (RScoped (HsValBindsLR a a))
952+ , Data (HsLocalBinds a)
953+ ) => ToHie (RScoped (LHsLocalBinds a)) where
954+ toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of
955+ EmptyLocalBinds _ -> []
956+ HsIPBinds _ _ -> []
957+ HsValBinds _ valBinds ->
958+ [ toHie $ RS (combineScopes scope $ mkScope sp)
959+ valBinds
960+ ]
961+ XHsLocalBindsLR _ -> []
962+
963+instance ( ToHie (BindContext (LHsBind a))
964+ , ToHie (SigContext (LSig a))
965+ , ToHie (RScoped (XXValBindsLR a a))
966+ ) => ToHie (RScoped (HsValBindsLR a a)) where
967+ toHie (RS sc v) = concatM $ case v of
968+ ValBinds _ binds sigs ->
969+ [ toHie $ fmap (BC RegularBind sc) binds
970+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
971+ ]
972+ XValBindsLR x -> [ toHie $ RS sc x ]
973+
974+instance ToHie (RScoped (NHsValBindsLR GhcTc)) where
975+ toHie (RS sc (NValBinds binds sigs)) = concatM $
976+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
977+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
978+ ]
979+instance ToHie (RScoped (NHsValBindsLR GhcRn)) where
980+ toHie (RS sc (NValBinds binds sigs)) = concatM $
981+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
982+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
983+ ]
984+
985+instance ( ToHie (RContext (LHsRecField a arg))
986+ ) => ToHie (RContext (HsRecFields a arg)) where
987+ toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields
988+
989+instance ( ToHie (RFContext (Located label))
990+ , ToHie arg
991+ , HasLoc arg
992+ , Data label
993+ , Data arg
994+ ) => ToHie (RContext (LHsRecField' label arg)) where
995+ toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of
996+ HsRecField label expr _ ->
997+ [ toHie $ RFC c (getRealSpan $ loc expr) label
998+ , toHie expr
999+ ]
1000+
1001+removeDefSrcSpan :: Name -> Name
1002+removeDefSrcSpan n = setNameLoc n noSrcSpan
1003+
1004+instance ToHie (RFContext (LFieldOcc GhcRn)) where
1005+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of
1006+ FieldOcc name _ ->
1007+ [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)
1008+ ]
1009+ XFieldOcc _ -> []
1010+
1011+instance ToHie (RFContext (LFieldOcc GhcTc)) where
1012+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of
1013+ FieldOcc var _ ->
1014+ let var' = setVarName var (removeDefSrcSpan $ varName var)
1015+ in [ toHie $ C (RecField c rhs) (L nspan var')
1016+ ]
1017+ XFieldOcc _ -> []
1018+
1019+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
1020+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
1021+ Unambiguous name _ ->
1022+ [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name
1023+ ]
1024+ Ambiguous _name _ ->
1025+ [ ]
1026+ XAmbiguousFieldOcc _ -> []
1027+
1028+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
1029+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
1030+ Unambiguous var _ ->
1031+ let var' = setVarName var (removeDefSrcSpan $ varName var)
1032+ in [ toHie $ C (RecField c rhs) (L nspan var')
1033+ ]
1034+ Ambiguous var _ ->
1035+ let var' = setVarName var (removeDefSrcSpan $ varName var)
1036+ in [ toHie $ C (RecField c rhs) (L nspan var')
1037+ ]
1038+ XAmbiguousFieldOcc _ -> []
1039+
1040+instance ( a ~ GhcPass p
1041+ , ToHie (PScoped (LPat a))
1042+ , ToHie (BindContext (LHsBind a))
1043+ , ToHie (LHsExpr a)
1044+ , ToHie (SigContext (LSig a))
1045+ , ToHie (RScoped (HsValBindsLR a a))
1046+ , Data (StmtLR a a (Located (HsExpr a)))
1047+ , Data (HsLocalBinds a)
1048+ ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
1049+ toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM
1050+ [ toHie $ PS Nothing sc NoScope pat
1051+ , toHie expr
1052+ ]
1053+ toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM
1054+ [ toHie $ listScopes NoScope stmts
1055+ , toHie $ PS Nothing sc NoScope pat
1056+ ]
1057+ toHie (RS _ (XApplicativeArg _)) = pure []
1058+
1059+instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where
1060+ toHie (PrefixCon args) = toHie args
1061+ toHie (RecCon rec) = toHie rec
1062+ toHie (InfixCon a b) = concatM [ toHie a, toHie b]
1063+
1064+instance ( ToHie (LHsCmd a)
1065+ , Data (HsCmdTop a)
1066+ ) => ToHie (LHsCmdTop a) where
1067+ toHie (L span top) = concatM $ makeNode top span : case top of
1068+ HsCmdTop _ cmd ->
1069+ [ toHie cmd
1070+ ]
1071+ XCmdTop _ -> []
1072+
1073+instance ( a ~ GhcPass p
1074+ , ToHie (PScoped (LPat a))
1075+ , ToHie (BindContext (LHsBind a))
1076+ , ToHie (LHsExpr a)
1077+ , ToHie (MatchGroup a (LHsCmd a))
1078+ , ToHie (SigContext (LSig a))
1079+ , ToHie (RScoped (HsValBindsLR a a))
1080+ , Data (HsCmd a)
1081+ , Data (HsCmdTop a)
1082+ , Data (StmtLR a a (Located (HsCmd a)))
1083+ , Data (HsLocalBinds a)
1084+ , Data (StmtLR a a (Located (HsExpr a)))
1085+ ) => ToHie (LHsCmd (GhcPass p)) where
1086+ toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of
1087+ HsCmdArrApp _ a b _ _ ->
1088+ [ toHie a
1089+ , toHie b
1090+ ]
1091+ HsCmdArrForm _ a _ _ cmdtops ->
1092+ [ toHie a
1093+ , toHie cmdtops
1094+ ]
1095+ HsCmdApp _ a b ->
1096+ [ toHie a
1097+ , toHie b
1098+ ]
1099+ HsCmdLam _ mg ->
1100+ [ toHie mg
1101+ ]
1102+ HsCmdPar _ a ->
1103+ [ toHie a
1104+ ]
1105+ HsCmdCase _ expr alts ->
1106+ [ toHie expr
1107+ , toHie alts
1108+ ]
1109+ HsCmdIf _ _ a b c ->
1110+ [ toHie a
1111+ , toHie b
1112+ , toHie c
1113+ ]
1114+ HsCmdLet _ binds cmd' ->
1115+ [ toHie $ RS (mkLScope cmd') binds
1116+ , toHie cmd'
1117+ ]
1118+ HsCmdDo _ (L ispan stmts) ->
1119+ [ pure $ locOnly ispan
1120+ , toHie $ listScopes NoScope stmts
1121+ ]
1122+ HsCmdWrap _ _ _ -> []
1123+ XCmd _ -> []
1124+
1125+instance ToHie (TyClGroup GhcRn) where
1126+ toHie (TyClGroup _ classes roles instances) = concatM
1127+ [ toHie classes
1128+ , toHie roles
1129+ , toHie instances
1130+ ]
1131+ toHie (XTyClGroup _) = pure []
1132+
1133+instance ToHie (LTyClDecl GhcRn) where
1134+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1135+ FamDecl {tcdFam = fdecl} ->
1136+ [ toHie (L span fdecl)
1137+ ]
1138+ SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->
1139+ [ toHie $ C (Decl SynDec $ getRealSpan span) name
1140+ , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars
1141+ , toHie typ
1142+ ]
1143+ DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->
1144+ [ toHie $ C (Decl DataDec $ getRealSpan span) name
1145+ , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars
1146+ , toHie defn
1147+ ]
1148+ where
1149+ quant_scope = mkLScope $ dd_ctxt defn
1150+ rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc
1151+ sig_sc = maybe NoScope mkLScope $ dd_kindSig defn
1152+ con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn
1153+ deriv_sc = mkLScope $ dd_derivs defn
1154+ ClassDecl { tcdCtxt = context
1155+ , tcdLName = name
1156+ , tcdTyVars = vars
1157+ , tcdFDs = deps
1158+ , tcdSigs = sigs
1159+ , tcdMeths = meths
1160+ , tcdATs = typs
1161+ , tcdATDefs = deftyps
1162+ } ->
1163+ [ toHie $ C (Decl ClassDec $ getRealSpan span) name
1164+ , toHie context
1165+ , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars
1166+ , toHie deps
1167+ , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs
1168+ , toHie $ fmap (BC InstanceBind ModuleScope) meths
1169+ , toHie typs
1170+ , concatMapM (pure . locOnly . getLoc) deftyps
1171+ , toHie $ map (go . unLoc) deftyps
1172+ ]
1173+ where
1174+ context_scope = mkLScope context
1175+ rhs_scope = foldl1' combineScopes $ map mkScope
1176+ [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
1177+
1178+ go :: TyFamDefltEqn GhcRn
1179+ -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)
1180+ go (FamEqn a var bndrs pat b rhs) =
1181+ FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs
1182+ go (XFamEqn NoExt) = XFamEqn NoExt
1183+ XTyClDecl _ -> []
1184+
1185+instance ToHie (LFamilyDecl GhcRn) where
1186+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1187+ FamilyDecl _ info name vars _ sig inj ->
1188+ [ toHie $ C (Decl FamDec $ getRealSpan span) name
1189+ , toHie $ TS (ResolvedScopes [rhsSpan]) vars
1190+ , toHie info
1191+ , toHie $ RS injSpan sig
1192+ , toHie inj
1193+ ]
1194+ where
1195+ rhsSpan = sigSpan `combineScopes` injSpan
1196+ sigSpan = mkScope $ getLoc sig
1197+ injSpan = maybe NoScope (mkScope . getLoc) inj
1198+ XFamilyDecl _ -> []
1199+
1200+instance ToHie (FamilyInfo GhcRn) where
1201+ toHie (ClosedTypeFamily (Just eqns)) = concatM $
1202+ [ concatMapM (pure . locOnly . getLoc) eqns
1203+ , toHie $ map go eqns
1204+ ]
1205+ where
1206+ go (L l ib) = TS (ResolvedScopes [mkScope l]) ib
1207+ toHie _ = pure []
1208+
1209+instance ToHie (RScoped (LFamilyResultSig GhcRn)) where
1210+ toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of
1211+ NoSig _ ->
1212+ []
1213+ KindSig _ k ->
1214+ [ toHie k
1215+ ]
1216+ TyVarSig _ bndr ->
1217+ [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr
1218+ ]
1219+ XFamilyResultSig _ -> []
1220+
1221+instance ToHie (Located (FunDep (Located Name))) where
1222+ toHie (L span fd@(lhs, rhs)) = concatM $
1223+ [ makeNode fd span
1224+ , toHie $ map (C Use) lhs
1225+ , toHie $ map (C Use) rhs
1226+ ]
1227+
1228+instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs)
1229+ => ToHie (TScoped (FamEqn GhcRn pats rhs)) where
1230+ toHie (TS _ f) = toHie f
1231+
1232+instance ( ToHie pats
1233+ , ToHie rhs
1234+ , HasLoc pats
1235+ , HasLoc rhs
1236+ ) => ToHie (FamEqn GhcRn pats rhs) where
1237+ toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $
1238+ [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var
1239+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
1240+ , toHie pats
1241+ , toHie rhs
1242+ ]
1243+ where scope = combineScopes patsScope rhsScope
1244+ patsScope = mkScope (loc pats)
1245+ rhsScope = mkScope (loc rhs)
1246+ toHie (XFamEqn _) = pure []
1247+
1248+instance ToHie (LInjectivityAnn GhcRn) where
1249+ toHie (L span ann) = concatM $ makeNode ann span : case ann of
1250+ InjectivityAnn lhs rhs ->
1251+ [ toHie $ C Use lhs
1252+ , toHie $ map (C Use) rhs
1253+ ]
1254+
1255+instance ToHie (HsDataDefn GhcRn) where
1256+ toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM
1257+ [ toHie ctx
1258+ , toHie mkind
1259+ , toHie cons
1260+ , toHie derivs
1261+ ]
1262+ toHie (XHsDataDefn _) = pure []
1263+
1264+instance ToHie (HsDeriving GhcRn) where
1265+ toHie (L span clauses) = concatM
1266+ [ pure $ locOnly span
1267+ , toHie clauses
1268+ ]
1269+
1270+instance ToHie (LHsDerivingClause GhcRn) where
1271+ toHie (L span cl) = concatM $ makeNode cl span : case cl of
1272+ HsDerivingClause _ strat (L ispan tys) ->
1273+ [ toHie strat
1274+ , pure $ locOnly ispan
1275+ , toHie $ map (TS (ResolvedScopes [])) tys
1276+ ]
1277+ XHsDerivingClause _ -> []
1278+
1279+instance ToHie (Located (DerivStrategy GhcRn)) where
1280+ toHie (L span strat) = concatM $ makeNode strat span : case strat of
1281+ StockStrategy -> []
1282+ AnyclassStrategy -> []
1283+ NewtypeStrategy -> []
1284+ ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]
1285+
1286+instance ToHie (Located OverlapMode) where
1287+ toHie (L span _) = pure $ locOnly span
1288+
1289+instance ToHie (LConDecl GhcRn) where
1290+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1291+ ConDeclGADT { con_names = names, con_qvars = qvars
1292+ , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
1293+ [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names
1294+ , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars
1295+ , toHie ctx
1296+ , toHie args
1297+ , toHie typ
1298+ ]
1299+ where
1300+ rhsScope = combineScopes argsScope tyScope
1301+ ctxScope = maybe NoScope mkLScope ctx
1302+ argsScope = condecl_scope args
1303+ tyScope = mkLScope typ
1304+ ConDeclH98 { con_name = name, con_ex_tvs = qvars
1305+ , con_mb_cxt = ctx, con_args = dets } ->
1306+ [ toHie $ C (Decl ConDec $ getRealSpan span) name
1307+ , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars
1308+ , toHie ctx
1309+ , toHie dets
1310+ ]
1311+ where
1312+ rhsScope = combineScopes ctxScope argsScope
1313+ ctxScope = maybe NoScope mkLScope ctx
1314+ argsScope = condecl_scope dets
1315+ XConDecl _ -> []
1316+ where condecl_scope args = case args of
1317+ PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs
1318+ InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)
1319+ RecCon x -> mkLScope x
1320+
1321+instance ToHie (Located [LConDeclField GhcRn]) where
1322+ toHie (L span decls) = concatM $
1323+ [ pure $ locOnly span
1324+ , toHie decls
1325+ ]
1326+
1327+instance ( HasLoc thing
1328+ , ToHie (TScoped thing)
1329+ ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where
1330+ toHie (TS sc (HsIB ibrn a)) = concatM $
1331+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
1332+ , toHie $ TS sc a
1333+ ]
1334+ where span = loc a
1335+ toHie (TS _ (XHsImplicitBndrs _)) = pure []
1336+
1337+instance ( HasLoc thing
1338+ , ToHie (TScoped thing)
1339+ ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where
1340+ toHie (TS sc (HsWC names a)) = concatM $
1341+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
1342+ , toHie $ TS sc a
1343+ ]
1344+ where span = loc a
1345+ toHie (TS _ (XHsWildCardBndrs _)) = pure []
1346+
1347+instance ToHie (SigContext (LSig GhcRn)) where
1348+ toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of
1349+ TypeSig _ names typ ->
1350+ [ toHie $ map (C TyDecl) names
1351+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1352+ ]
1353+ PatSynSig _ names typ ->
1354+ [ toHie $ map (C TyDecl) names
1355+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1356+ ]
1357+ ClassOpSig _ _ names typ ->
1358+ [ case styp of
1359+ ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names
1360+ _ -> toHie $ map (C $ TyDecl) names
1361+ , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
1362+ ]
1363+ IdSig _ _ -> []
1364+ FixSig _ fsig ->
1365+ [ toHie $ L sp fsig
1366+ ]
1367+ InlineSig _ name _ ->
1368+ [ toHie $ (C Use) name
1369+ ]
1370+ SpecSig _ name typs _ ->
1371+ [ toHie $ (C Use) name
1372+ , toHie $ map (TS (ResolvedScopes [])) typs
1373+ ]
1374+ SpecInstSig _ _ typ ->
1375+ [ toHie $ TS (ResolvedScopes []) typ
1376+ ]
1377+ MinimalSig _ _ form ->
1378+ [ toHie form
1379+ ]
1380+ SCCFunSig _ _ name mtxt ->
1381+ [ toHie $ (C Use) name
1382+ , pure $ maybe [] (locOnly . getLoc) mtxt
1383+ ]
1384+ CompleteMatchSig _ _ (L ispan names) typ ->
1385+ [ pure $ locOnly ispan
1386+ , toHie $ map (C Use) names
1387+ , toHie $ fmap (C Use) typ
1388+ ]
1389+ XSig _ -> []
1390+
1391+instance ToHie (LHsType GhcRn) where
1392+ toHie x = toHie $ TS (ResolvedScopes []) x
1393+
1394+instance ToHie (TScoped (LHsType GhcRn)) where
1395+ toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of
1396+ HsForAllTy _ bndrs body ->
1397+ [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs
1398+ , toHie body
1399+ ]
1400+ HsQualTy _ ctx body ->
1401+ [ toHie ctx
1402+ , toHie body
1403+ ]
1404+ HsTyVar _ _ var ->
1405+ [ toHie $ C Use var
1406+ ]
1407+ HsAppTy _ a b ->
1408+ [ toHie a
1409+ , toHie b
1410+ ]
1411+ HsAppKindTy _ ty ki ->
1412+ [ toHie ty
1413+ , toHie $ TS (ResolvedScopes []) ki
1414+ ]
1415+ HsFunTy _ a b ->
1416+ [ toHie a
1417+ , toHie b
1418+ ]
1419+ HsListTy _ a ->
1420+ [ toHie a
1421+ ]
1422+ HsTupleTy _ _ tys ->
1423+ [ toHie tys
1424+ ]
1425+ HsSumTy _ tys ->
1426+ [ toHie tys
1427+ ]
1428+ HsOpTy _ a op b ->
1429+ [ toHie a
1430+ , toHie $ C Use op
1431+ , toHie b
1432+ ]
1433+ HsParTy _ a ->
1434+ [ toHie a
1435+ ]
1436+ HsIParamTy _ ip ty ->
1437+ [ toHie ip
1438+ , toHie ty
1439+ ]
1440+ HsKindSig _ a b ->
1441+ [ toHie a
1442+ , toHie b
1443+ ]
1444+ HsSpliceTy _ a ->
1445+ [ toHie $ L span a
1446+ ]
1447+ HsDocTy _ a _ ->
1448+ [ toHie a
1449+ ]
1450+ HsBangTy _ _ ty ->
1451+ [ toHie ty
1452+ ]
1453+ HsRecTy _ fields ->
1454+ [ toHie fields
1455+ ]
1456+ HsExplicitListTy _ _ tys ->
1457+ [ toHie tys
1458+ ]
1459+ HsExplicitTupleTy _ tys ->
1460+ [ toHie tys
1461+ ]
1462+ HsTyLit _ _ -> []
1463+ HsWildCardTy _ -> []
1464+ HsStarTy _ _ -> []
1465+ XHsType _ -> []
1466+
1467+instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
1468+ toHie (HsValArg tm) = toHie tm
1469+ toHie (HsTypeArg _ ty) = toHie ty
1470+ toHie (HsArgPar sp) = pure $ locOnly sp
1471+
1472+instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where
1473+ toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
1474+ UserTyVar _ var ->
1475+ [ toHie $ C (TyVarBind sc tsc) var
1476+ ]
1477+ KindedTyVar _ var kind ->
1478+ [ toHie $ C (TyVarBind sc tsc) var
1479+ , toHie kind
1480+ ]
1481+ XTyVarBndr _ -> []
1482+
1483+instance ToHie (TScoped (LHsQTyVars GhcRn)) where
1484+ toHie (TS sc (HsQTvs (HsQTvsRn implicits _) vars)) = concatM $
1485+ [ pure $ bindingsOnly bindings
1486+ , toHie $ tvScopes sc NoScope vars
1487+ ]
1488+ where
1489+ varLoc = loc vars
1490+ bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits
1491+ toHie (TS _ (XLHsQTyVars _)) = pure []
1492+
1493+instance ToHie (LHsContext GhcRn) where
1494+ toHie (L span tys) = concatM $
1495+ [ pure $ locOnly span
1496+ , toHie tys
1497+ ]
1498+
1499+instance ToHie (LConDeclField GhcRn) where
1500+ toHie (L span field) = concatM $ makeNode field span : case field of
1501+ ConDeclField _ fields typ _ ->
1502+ [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields
1503+ , toHie typ
1504+ ]
1505+ XConDeclField _ -> []
1506+
1507+instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
1508+ toHie (From expr) = toHie expr
1509+ toHie (FromThen a b) = concatM $
1510+ [ toHie a
1511+ , toHie b
1512+ ]
1513+ toHie (FromTo a b) = concatM $
1514+ [ toHie a
1515+ , toHie b
1516+ ]
1517+ toHie (FromThenTo a b c) = concatM $
1518+ [ toHie a
1519+ , toHie b
1520+ , toHie c
1521+ ]
1522+
1523+instance ToHie (LSpliceDecl GhcRn) where
1524+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1525+ SpliceDecl _ splice _ ->
1526+ [ toHie splice
1527+ ]
1528+ XSpliceDecl _ -> []
1529+
1530+instance ToHie (HsBracket a) where
1531+ toHie _ = pure []
1532+
1533+instance ToHie PendingRnSplice where
1534+ toHie _ = pure []
1535+
1536+instance ToHie PendingTcSplice where
1537+ toHie _ = pure []
1538+
1539+instance ToHie (LBooleanFormula (Located Name)) where
1540+ toHie (L span form) = concatM $ makeNode form span : case form of
1541+ Var a ->
1542+ [ toHie $ C Use a
1543+ ]
1544+ And forms ->
1545+ [ toHie forms
1546+ ]
1547+ Or forms ->
1548+ [ toHie forms
1549+ ]
1550+ Parens f ->
1551+ [ toHie f
1552+ ]
1553+
1554+instance ToHie (Located HsIPName) where
1555+ toHie (L span e) = makeNode e span
1556+
1557+instance ( ToHie (LHsExpr a)
1558+ , Data (HsSplice a)
1559+ ) => ToHie (Located (HsSplice a)) where
1560+ toHie (L span sp) = concatM $ makeNode sp span : case sp of
1561+ HsTypedSplice _ _ _ expr ->
1562+ [ toHie expr
1563+ ]
1564+ HsUntypedSplice _ _ _ expr ->
1565+ [ toHie expr
1566+ ]
1567+ HsQuasiQuote _ _ _ ispan _ ->
1568+ [ pure $ locOnly ispan
1569+ ]
1570+ HsSpliced _ _ _ ->
1571+ []
1572+ HsSplicedT _ ->
1573+ []
1574+ XSplice _ -> []
1575+
1576+instance ToHie (LRoleAnnotDecl GhcRn) where
1577+ toHie (L span annot) = concatM $ makeNode annot span : case annot of
1578+ RoleAnnotDecl _ var roles ->
1579+ [ toHie $ C Use var
1580+ , concatMapM (pure . locOnly . getLoc) roles
1581+ ]
1582+ XRoleAnnotDecl _ -> []
1583+
1584+instance ToHie (LInstDecl GhcRn) where
1585+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1586+ ClsInstD _ d ->
1587+ [ toHie $ L span d
1588+ ]
1589+ DataFamInstD _ d ->
1590+ [ toHie $ L span d
1591+ ]
1592+ TyFamInstD _ d ->
1593+ [ toHie $ L span d
1594+ ]
1595+ XInstDecl _ -> []
1596+
1597+instance ToHie (LClsInstDecl GhcRn) where
1598+ toHie (L span decl) = concatM
1599+ [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
1600+ , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
1601+ , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl
1602+ , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl
1603+ , toHie $ cid_tyfam_insts decl
1604+ , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl
1605+ , toHie $ cid_datafam_insts decl
1606+ , toHie $ cid_overlap_mode decl
1607+ ]
1608+
1609+instance ToHie (LDataFamInstDecl GhcRn) where
1610+ toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
1611+
1612+instance ToHie (LTyFamInstDecl GhcRn) where
1613+ toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
1614+
1615+instance ToHie (Context a)
1616+ => ToHie (PatSynFieldContext (RecordPatSynField a)) where
1617+ toHie (PSC sp (RecordPatSynField a b)) = concatM $
1618+ [ toHie $ C (RecField RecFieldDecl sp) a
1619+ , toHie $ C Use b
1620+ ]
1621+
1622+instance ToHie (LDerivDecl GhcRn) where
1623+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1624+ DerivDecl _ typ strat overlap ->
1625+ [ toHie $ TS (ResolvedScopes []) typ
1626+ , toHie strat
1627+ , toHie overlap
1628+ ]
1629+ XDerivDecl _ -> []
1630+
1631+instance ToHie (LFixitySig GhcRn) where
1632+ toHie (L span sig) = concatM $ makeNode sig span : case sig of
1633+ FixitySig _ vars _ ->
1634+ [ toHie $ map (C Use) vars
1635+ ]
1636+ XFixitySig _ -> []
1637+
1638+instance ToHie (LDefaultDecl GhcRn) where
1639+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1640+ DefaultDecl _ typs ->
1641+ [ toHie typs
1642+ ]
1643+ XDefaultDecl _ -> []
1644+
1645+instance ToHie (LForeignDecl GhcRn) where
1646+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1647+ ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->
1648+ [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name
1649+ , toHie $ TS (ResolvedScopes []) sig
1650+ , toHie fi
1651+ ]
1652+ ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->
1653+ [ toHie $ C Use name
1654+ , toHie $ TS (ResolvedScopes []) sig
1655+ , toHie fe
1656+ ]
1657+ XForeignDecl _ -> []
1658+
1659+instance ToHie ForeignImport where
1660+ toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $
1661+ [ locOnly a
1662+ , locOnly b
1663+ , locOnly c
1664+ ]
1665+
1666+instance ToHie ForeignExport where
1667+ toHie (CExport (L a _) (L b _)) = pure $ concat $
1668+ [ locOnly a
1669+ , locOnly b
1670+ ]
1671+
1672+instance ToHie (LWarnDecls GhcRn) where
1673+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1674+ Warnings _ _ warnings ->
1675+ [ toHie warnings
1676+ ]
1677+ XWarnDecls _ -> []
1678+
1679+instance ToHie (LWarnDecl GhcRn) where
1680+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1681+ Warning _ vars _ ->
1682+ [ toHie $ map (C Use) vars
1683+ ]
1684+ XWarnDecl _ -> []
1685+
1686+instance ToHie (LAnnDecl GhcRn) where
1687+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1688+ HsAnnotation _ _ prov expr ->
1689+ [ toHie prov
1690+ , toHie expr
1691+ ]
1692+ XAnnDecl _ -> []
1693+
1694+instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where
1695+ toHie (ValueAnnProvenance a) = toHie $ C Use a
1696+ toHie (TypeAnnProvenance a) = toHie $ C Use a
1697+ toHie ModuleAnnProvenance = pure []
1698+
1699+instance ToHie (LRuleDecls GhcRn) where
1700+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1701+ HsRules _ _ rules ->
1702+ [ toHie rules
1703+ ]
1704+ XRuleDecls _ -> []
1705+
1706+instance ToHie (LRuleDecl GhcRn) where
1707+ toHie (L _ (XRuleDecl _)) = pure []
1708+ toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
1709+ [ makeNode r span
1710+ , pure $ locOnly $ getLoc rname
1711+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
1712+ , toHie $ map (RS $ mkScope span) bndrs
1713+ , toHie exprA
1714+ , toHie exprB
1715+ ]
1716+ where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc
1717+ bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)
1718+ exprA_sc = mkLScope exprA
1719+ exprB_sc = mkLScope exprB
1720+
1721+instance ToHie (RScoped (LRuleBndr GhcRn)) where
1722+ toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
1723+ RuleBndr _ var ->
1724+ [ toHie $ C (ValBind RegularBind sc Nothing) var
1725+ ]
1726+ RuleBndrSig _ var typ ->
1727+ [ toHie $ C (ValBind RegularBind sc Nothing) var
1728+ , toHie $ TS (ResolvedScopes [sc]) typ
1729+ ]
1730+ XRuleBndr _ -> []
1731+
1732+instance ToHie (LImportDecl GhcRn) where
1733+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1734+ ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->
1735+ [ toHie $ IEC Import name
1736+ , toHie $ fmap (IEC ImportAs) as
1737+ , maybe (pure []) goIE hidden
1738+ ]
1739+ XImportDecl _ -> []
1740+ where
1741+ goIE (hiding, (L sp liens)) = concatM $
1742+ [ pure $ locOnly sp
1743+ , toHie $ map (IEC c) liens
1744+ ]
1745+ where
1746+ c = if hiding then ImportHiding else Import
1747+
1748+instance ToHie (IEContext (LIE GhcRn)) where
1749+ toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of
1750+ IEVar _ n ->
1751+ [ toHie $ IEC c n
1752+ ]
1753+ IEThingAbs _ n ->
1754+ [ toHie $ IEC c n
1755+ ]
1756+ IEThingAll _ n ->
1757+ [ toHie $ IEC c n
1758+ ]
1759+ IEThingWith _ n _ ns flds ->
1760+ [ toHie $ IEC c n
1761+ , toHie $ map (IEC c) ns
1762+ , toHie $ map (IEC c) flds
1763+ ]
1764+ IEModuleContents _ n ->
1765+ [ toHie $ IEC c n
1766+ ]
1767+ IEGroup _ _ _ -> []
1768+ IEDoc _ _ -> []
1769+ IEDocNamed _ _ -> []
1770+ XIE _ -> []
1771+
1772+instance ToHie (IEContext (LIEWrappedName Name)) where
1773+ toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of
1774+ IEName n ->
1775+ [ toHie $ C (IEThing c) n
1776+ ]
1777+ IEPattern p ->
1778+ [ toHie $ C (IEThing c) p
1779+ ]
1780+ IEType n ->
1781+ [ toHie $ C (IEThing c) n
1782+ ]
1783+
1784+instance ToHie (IEContext (Located (FieldLbl Name))) where
1785+ toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of
1786+ FieldLabel _ _ n ->
1787+ [ toHie $ C (IEThing c) $ L span n
1788+ ]
1789+
src/Development/IDE/Compat.hsnew file+19
@@ -0,0 +1,19 @@
1+{-# LANGUAGE CPP #-}
2+module Development.IDE.Compat
3+ (
4+ getProcessID
5+ ) where
6+
7+#ifdef mingw32_HOST_OS
8+
9+import qualified System.Win32.Process as P (getCurrentProcessId)
10+getProcessID :: IO Int
11+getProcessID = fromIntegral <$> P.getCurrentProcessId
12+
13+#else
14+
15+import qualified System.Posix.Process as P (getProcessID)
16+getProcessID :: IO Int
17+getProcessID = fromIntegral <$> P.getProcessID
18+
19+#endif
src/Development/IDE/Core/Compile.hs+322−105
@@ -9,6 +9,7 @@
9-- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.
9-- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.
10module Development.IDE.Core.Compile
10module Development.IDE.Core.Compile
11 ( TcModuleResult(..)
11 ( TcModuleResult(..)
12+ , RunSimplifier(..)
12 , compileModule
13 , compileModule
13 , parseModule
14 , parseModule
14 , typecheckModule
15 , typecheckModule
@@ -16,10 +17,18 @@ module Development.IDE.Core.Compile
16 , addRelativeImport
17 , addRelativeImport
17 , mkTcModuleResult
18 , mkTcModuleResult
18 , generateByteCode
19 , generateByteCode
20+ , generateAndWriteHieFile
21+ , generateAndWriteHiFile
22+ , getModSummaryFromImports
23+ , loadHieFile
24+ , loadInterface
25+ , loadDepModule
26+ , loadModuleHome
19 ) where
27 ) where
20
28
21import Development.IDE.Core.RuleTypes
29import Development.IDE.Core.RuleTypes
22import Development.IDE.Core.Preprocessor
30import Development.IDE.Core.Preprocessor
31+import Development.IDE.Core.Shake
23import Development.IDE.GHC.Error
32import Development.IDE.GHC.Error
24import Development.IDE.GHC.Warnings
33import Development.IDE.GHC.Warnings
25import Development.IDE.Types.Diagnostics
34import Development.IDE.Types.Diagnostics
@@ -28,6 +37,7 @@ import Development.IDE.GHC.Util
28import qualified GHC.LanguageExtensions.Type as GHC
37import qualified GHC.LanguageExtensions.Type as GHC
29import Development.IDE.Types.Options
38import Development.IDE.Types.Options
30import Development.IDE.Types.Location
39import Development.IDE.Types.Location
40+import Outputable
31
41
32#if MIN_GHC_API_VERSION(8,6,0)
42#if MIN_GHC_API_VERSION(8,6,0)
33import DynamicLoading (initializePlugins)
43import DynamicLoading (initializePlugins)
@@ -36,42 +46,60 @@ import DynamicLoading (initializePlugins)
36import GHC hiding (parseModule, typecheckModule)
46import GHC hiding (parseModule, typecheckModule)
37import qualified Parser
47import qualified Parser
38import Lexer
48import Lexer
49+#if MIN_GHC_API_VERSION(8,10,0)
50+#else
39import ErrUtils
51import ErrUtils
52+#endif
40
53
41−import qualified GHC
54+import Finder
55+import qualified Development.IDE.GHC.Compat as GHC
56+import qualified Development.IDE.GHC.Compat as Compat
42import GhcMonad
57import GhcMonad
43import GhcPlugins as GHC hiding (fst3, (<>))
58import GhcPlugins as GHC hiding (fst3, (<>))
44import qualified HeaderInfo as Hdr
59import qualified HeaderInfo as Hdr
45−import HscMain (hscInteractive)
60+import HscMain (hscInteractive, hscSimplify)
61+import LoadIface (readIface)
62+import qualified Maybes
46import MkIface
63import MkIface
64+import NameCache
47import StringBuffer as SB
65import StringBuffer as SB
66+import TcRnMonad (initIfaceLoad, tcg_th_coreplugins)
67+import TcIface (typecheckIface)
48import TidyPgm
68import TidyPgm
49
69
70+import Control.Exception.Safe
50import Control.Monad.Extra
71import Control.Monad.Extra
51import Control.Monad.Except
72import Control.Monad.Except
52import Control.Monad.Trans.Except
73import Control.Monad.Trans.Except
53−import Data.Function
74+import Data.Bifunctor (first, second)
54−import Data.Ord
55import qualified Data.Text as T
75import qualified Data.Text as T
56import Data.IORef
76import Data.IORef
57import Data.List.Extra
77import Data.List.Extra
58import Data.Maybe
78import Data.Maybe
59−import Data.Tuple.Extra
60import qualified Data.Map.Strict as Map
79import qualified Data.Map.Strict as Map
61import System.FilePath
80import System.FilePath
81+import System.Directory
82+import System.IO.Extra
83+import Data.Either.Extra (maybeToEither)
84+import Control.DeepSeq (rnf)
85+import Control.Exception (evaluate)
86+import Exception (ExceptionMonad)
62
87
63
88
64−-- | Given a string buffer, return a pre-processed @ParsedModule@.
89+-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
65parseModule
90parseModule
66 :: IdeOptions
91 :: IdeOptions
67 -> HscEnv
92 -> HscEnv
93+ -> [PackageName]
68 -> FilePath
94 -> FilePath
69 -> Maybe SB.StringBuffer
95 -> Maybe SB.StringBuffer
70− -> IO ([FileDiagnostic], Maybe ParsedModule)
96+ -> IO (IdeResult (StringBuffer, ParsedModule))
71−parseModule IdeOptions{..} env file =
97+parseModule IdeOptions{..} env comp_pkgs filename mbContents =
72− fmap (either (, Nothing) (second Just)) .
98+ fmap (either (, Nothing) id) $
73− -- We need packages since imports fail to resolve otherwise.
99+ evalGhcEnv env $ runExceptT $ do
100+ (contents, dflags) <- preprocessor filename mbContents
74− runGhcEnv env . runExceptT . parseFileContents optPreprocessor file
101+ (diag, modu) <- parseFileContents optPreprocessor dflags comp_pkgs filename contents
102+ return (diag, Just (contents, modu))
75
103
76
104
77-- | Given a package identifier, what packages does it depend on
105-- | Given a package identifier, what packages does it depend on
@@ -82,31 +110,39 @@ computePackageDeps
82computePackageDeps env pkg = do
110computePackageDeps env pkg = do
83 let dflags = hsc_dflags env
111 let dflags = hsc_dflags env
84 case lookupInstalledPackage dflags pkg of
112 case lookupInstalledPackage dflags pkg of
85− Nothing -> return $ Left [ideErrorText (toNormalizedFilePath noFilePath) $
113+ Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $
86 T.pack $ "unknown package: " ++ show pkg]
114 T.pack $ "unknown package: " ++ show pkg]
87 Just pkgInfo -> return $ Right $ depends pkgInfo
115 Just pkgInfo -> return $ Right $ depends pkgInfo
88
116
89−
90−-- | Typecheck a single module using the supplied dependencies and packages.
91−typecheckModule
92− :: IdeDefer
117+typecheckModule :: IdeDefer
93− -> HscEnv
118+ -> HscEnv
94− -> [TcModuleResult]
119+ -> [(ModSummary, (ModIface, Maybe Linkable))]
95− -> ParsedModule
120+ -> ParsedModule
96− -> IO ([FileDiagnostic], Maybe TcModuleResult)
121+ -> IO (IdeResult (HscEnv, TcModuleResult))
97−typecheckModule (IdeDefer defer) packageState deps pm =
122+typecheckModule (IdeDefer defer) hsc depsIn pm = do
98− let demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
99− in
100− fmap (either (, Nothing) (second Just)) $
123+ fmap (either (, Nothing) (second Just . sequence) . sequence) $
101− runGhcEnv packageState $
124+ runGhcEnv hsc $
102− catchSrcErrors "typecheck" $ do
125+ catchSrcErrors "typecheck" $ do
103− setupEnv deps
126+ -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.
127+ -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.
128+ -- Long-term we might just want to change the order returned by GetDependencies
129+ let deps = reverse depsIn
130+
131+ setupFinderCache (map fst deps)
132+
104− let modSummary = pm_mod_summary pm
133+ let modSummary = pm_mod_summary pm
134+ dflags = ms_hspp_opts modSummary
135+
136+ mapM_ (uncurry loadDepModule . snd) deps
105− modSummary' <- initPlugins modSummary
137+ modSummary' <- initPlugins modSummary
106− (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
138+ (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
139+ GHC.typecheckModule $ enableTopLevelWarnings
107− GHC.typecheckModule $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
140+ $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
108− tcm2 <- mkTcModuleResult tcm
141+ tcm2 <- mkTcModuleResult tcm
142+ let errorPipeline = unDefer . hideDiag dflags
109− return (map unDefer warnings, tcm2)
143+ return (map errorPipeline warnings, tcm2)
144+ where
145+ demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
110
146
111initPlugins :: GhcMonad m => ModSummary -> m ModSummary
147initPlugins :: GhcMonad m => ModSummary -> m ModSummary
112initPlugins modSummary = do
148initPlugins modSummary = do
@@ -118,18 +154,25 @@ initPlugins modSummary = do
118 return modSummary
154 return modSummary
119#endif
155#endif
120
156
157+-- | Whether we should run the -O0 simplifier when generating core.
158+--
159+-- This is required for template Haskell to work but we disable this in DAML.
160+-- See #256
161+newtype RunSimplifier = RunSimplifier Bool
162+
121-- | Compile a single type-checked module to a 'CoreModule' value, or
163-- | Compile a single type-checked module to a 'CoreModule' value, or
122-- provide errors.
164-- provide errors.
123compileModule
165compileModule
166+ :: RunSimplifier
124− :: HscEnv
167+ -> HscEnv
125− -> [TcModuleResult]
168+ -> [(ModSummary, HomeModInfo)]
126 -> TcModuleResult
169 -> TcModuleResult
127− -> IO ([FileDiagnostic], Maybe (SafeHaskellMode, CgGuts, ModDetails))
170+ -> IO (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
128−compileModule packageState deps tmr =
171+compileModule (RunSimplifier simplify) packageState deps tmr =
129 fmap (either (, Nothing) (second Just)) $
172 fmap (either (, Nothing) (second Just)) $
130− runGhcEnv packageState $
173+ evalGhcEnv packageState $
131 catchSrcErrors "compile" $ do
174 catchSrcErrors "compile" $ do
132− setupEnv (deps ++ [tmr])
175+ setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])
133
176
134 let tm = tmrModule tmr
177 let tm = tmrModule tmr
135 session <- getSession
178 session <- getSession
@@ -138,20 +181,30 @@ compileModule packageState deps tmr =
138 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
181 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
139 let tm' = tm{tm_parsed_module = pm'}
182 let tm' = tm{tm_parsed_module = pm'}
140 GHC.dm_core_module <$> GHC.desugarModule tm'
183 GHC.dm_core_module <$> GHC.desugarModule tm'
141−
184+ let tc_result = fst (tm_internals_ (tmrModule tmr))
185+ desugared_guts <-
186+ if simplify
187+ then do
188+ plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
189+ liftIO $ hscSimplify session plugins desugar
190+ else pure desugar
142 -- give variables unique OccNames
191 -- give variables unique OccNames
143− (guts, details) <- liftIO $ tidyProgram session desugar
192+ (guts, details) <- liftIO $ tidyProgram session desugared_guts
144 return (map snd warnings, (mg_safe_haskell desugar, guts, details))
193 return (map snd warnings, (mg_safe_haskell desugar, guts, details))
145
194
146−generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO ([FileDiagnostic], Maybe Linkable)
195+generateByteCode :: HscEnv -> [(ModSummary, HomeModInfo)] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable)
147generateByteCode hscEnv deps tmr guts =
196generateByteCode hscEnv deps tmr guts =
148 fmap (either (, Nothing) (second Just)) $
197 fmap (either (, Nothing) (second Just)) $
149− runGhcEnv hscEnv $
198+ evalGhcEnv hscEnv $
150 catchSrcErrors "bytecode" $ do
199 catchSrcErrors "bytecode" $ do
151− setupEnv (deps ++ [tmr])
200+ setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])
152 session <- getSession
201 session <- getSession
153 (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->
202 (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->
203+#if MIN_GHC_API_VERSION(8,10,0)
154− liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)
204+ liftIO $ hscInteractive session guts (GHC.ms_location $ tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)
205+#else
206+ liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)
207+#endif
155 let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr
208 let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr
156 let unlinked = BCOs bytecode sptEntries
209 let unlinked = BCOs bytecode sptEntries
157 let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
210 let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
@@ -170,12 +223,20 @@ demoteTypeErrorsToWarnings =
170 . (`gopt_set` Opt_DeferTypedHoles)
223 . (`gopt_set` Opt_DeferTypedHoles)
171 . (`gopt_set` Opt_DeferOutOfScopeVariables)
224 . (`gopt_set` Opt_DeferOutOfScopeVariables)
172
225
173− update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary
226+enableTopLevelWarnings :: ParsedModule -> ParsedModule
174− update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}
227+enableTopLevelWarnings =
228+ (update_pm_mod_summary . update_hspp_opts)
229+ ((`wopt_set` Opt_WarnMissingPatternSynonymSignatures) .
230+ (`wopt_set` Opt_WarnMissingSignatures))
231+ -- the line below would show also warnings for let bindings without signature
232+ -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures)))
175
233
234+update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary
235+update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}
236+
176− update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule
237+update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule
177− update_pm_mod_summary up pm =
238+update_pm_mod_summary up pm =
178− pm{pm_mod_summary = up $ pm_mod_summary pm}
239+ pm{pm_mod_summary = up $ pm_mod_summary pm}
179
240
180unDefer :: (WarnReason, FileDiagnostic) -> FileDiagnostic
241unDefer :: (WarnReason, FileDiagnostic) -> FileDiagnostic
181unDefer (Reason Opt_WarnDeferredTypeErrors , fd) = upgradeWarningToError fd
242unDefer (Reason Opt_WarnDeferredTypeErrors , fd) = upgradeWarningToError fd
@@ -184,12 +245,17 @@ unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = upgradeWarningToError
184unDefer ( _ , fd) = fd
245unDefer ( _ , fd) = fd
185
246
186upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
247upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
187−upgradeWarningToError (nfp, fd) =
248+upgradeWarningToError (nfp, sh, fd) =
188− (nfp, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where
249+ (nfp, sh, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where
189 warn2err :: T.Text -> T.Text
250 warn2err :: T.Text -> T.Text
190 warn2err = T.intercalate ": error:" . T.splitOn ": warning:"
251 warn2err = T.intercalate ": error:" . T.splitOn ": warning:"
191
252
253+hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
254+hideDiag originalFlags (Reason warning, (nfp, _sh, fd))
255+ | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))
256+hideDiag _originalFlags t = t
257+
192−addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags
258+addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags
193addRelativeImport fp modu dflags = dflags
259addRelativeImport fp modu dflags = dflags
194 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
260 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
195
261
@@ -199,25 +265,81 @@ mkTcModuleResult
199 -> m TcModuleResult
265 -> m TcModuleResult
200mkTcModuleResult tcm = do
266mkTcModuleResult tcm = do
201 session <- getSession
267 session <- getSession
268+ let sf = modInfoSafe (tm_checked_module_info tcm)
269+#if MIN_GHC_API_VERSION(8,10,0)
270+ iface <- liftIO $ mkIfaceTc session sf details tcGblEnv
271+#else
202− (iface, _) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv
272+ (iface, _) <- liftIO $ mkIfaceTc session Nothing sf details tcGblEnv
273+#endif
203 let mod_info = HomeModInfo iface details Nothing
274 let mod_info = HomeModInfo iface details Nothing
204 return $ TcModuleResult tcm mod_info
275 return $ TcModuleResult tcm mod_info
205 where
276 where
206 (tcGblEnv, details) = tm_internals_ tcm
277 (tcGblEnv, details) = tm_internals_ tcm
207
278
279+atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO ()
280+atomicFileWrite targetPath write = do
281+ let dir = takeDirectory targetPath
282+ createDirectoryIfMissing True dir
283+ (tempFilePath, cleanUp) <- newTempFileWithin dir
284+ (write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp
285+
286+generateAndWriteHieFile :: HscEnv -> TypecheckedModule -> IO [FileDiagnostic]
287+generateAndWriteHieFile hscEnv tcm =
288+ handleGenerationErrors dflags "extended interface generation" $ do
289+ case tm_renamed_source tcm of
290+ Just rnsrc -> do
291+ hf <- runHsc hscEnv $
292+ GHC.mkHieFile mod_summary (fst $ tm_internals_ tcm) rnsrc ""
293+ atomicFileWrite targetPath $ flip GHC.writeHieFile hf
294+ _ ->
295+ return ()
296+ where
297+ dflags = hsc_dflags hscEnv
298+ mod_summary = pm_mod_summary $ tm_parsed_module tcm
299+ mod_location = ms_location mod_summary
300+ targetPath = Compat.ml_hie_file mod_location
301+
302+generateAndWriteHiFile :: HscEnv -> TcModuleResult -> IO [FileDiagnostic]
303+generateAndWriteHiFile hscEnv tc =
304+ handleGenerationErrors dflags "interface generation" $ do
305+ atomicFileWrite targetPath $ \fp ->
306+ writeIfaceFile dflags fp modIface
307+ where
308+ modIface = hm_iface $ tmrModInfo tc
309+ modSummary = tmrModSummary tc
310+ targetPath = withBootSuffix $ ml_hi_file $ ms_location $ tmrModSummary tc
311+ withBootSuffix = case ms_hsc_src modSummary of
312+ HsBootFile -> addBootSuffix
313+ _ -> id
314+ dflags = hsc_dflags hscEnv
315+
316+handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]
317+handleGenerationErrors dflags source action =
318+ action >> return [] `catches`
319+ [ Handler $ return . diagFromGhcException source dflags
320+ , Handler $ return . diagFromString source DsError (noSpan "<internal>")
321+ . (("Error during " ++ T.unpack source) ++) . show @SomeException
322+ ]
323+
324+
208-- | Setup the environment that GHC needs according to our
325-- | Setup the environment that GHC needs according to our
209-- best understanding (!)
326-- best understanding (!)
327+--
328+-- This involves setting up the finder cache and populating the
329+-- HPT.
210−setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
330+setupEnv :: GhcMonad m => [(ModSummary, HomeModInfo)] -> m ()
211−setupEnv tmsIn = do
331+setupEnv tms = do
212− -- if both a .hs-boot file and a .hs file appear here, we want to make sure that the .hs file
332+ setupFinderCache (map fst tms)
213− -- takes precedence, so put the .hs-boot file earlier in the list
333+ -- load dependent modules, which must be in topological order.
214− let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule
334+ modifySession $ \e ->
215− tms = sortBy (compare `on` Down . isSourceFile) tmsIn
335+ foldl' (\e (_, hmi) -> loadModuleHome hmi e) e tms
216
336
337+-- | Initialise the finder cache, dependencies should be topologically
338+-- sorted.
339+setupFinderCache :: GhcMonad m => [ModSummary] -> m ()
340+setupFinderCache mss = do
217 session <- getSession
341 session <- getSession
218
342
219− let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
220−
221 -- set the target and module graph in the session
343 -- set the target and module graph in the session
222 let graph = mkModuleGraph mss
344 let graph = mkModuleGraph mss
223 setSession session { hsc_mod_graph = graph }
345 setSession session { hsc_mod_graph = graph }
@@ -236,26 +358,40 @@ setupEnv tmsIn = do
236 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache
358 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache
237 modifySession $ \s -> s { hsc_FC = newFinderCacheVar }
359 modifySession $ \s -> s { hsc_FC = newFinderCacheVar }
238
360
239− -- load dependent modules, which must be in topological order.
240− mapM_ loadModuleHome tms
241−
242
361
243-- | Load a module, quickly. Input doesn't need to be desugared.
362-- | Load a module, quickly. Input doesn't need to be desugared.
244-- A module must be loaded before dependent modules can be typechecked.
363-- A module must be loaded before dependent modules can be typechecked.
245-- This variant of loadModuleHome will *never* cause recompilation, it just
364-- This variant of loadModuleHome will *never* cause recompilation, it just
246-- modifies the session.
365-- modifies the session.
366+--
367+-- The order modules are loaded is important when there are hs-boot files.
368+-- In particular you should make sure to load the .hs version of a file after the
369+-- .hs-boot version.
247loadModuleHome
370loadModuleHome
248− :: (GhcMonad m)
371+ :: HomeModInfo
249− => TcModuleResult
372+ -> HscEnv
250− -> m ()
373+ -> HscEnv
251−loadModuleHome tmr = modifySession $ \e ->
374+loadModuleHome mod_info e =
375+ e { hsc_HPT = addToHpt (hsc_HPT e) mod_name mod_info }
376+ where
377+ mod_name = moduleName $ mi_module $ hm_iface mod_info
378+
379+-- | Load module interface.
380+loadDepModuleIO :: ModIface -> Maybe Linkable -> HscEnv -> IO HscEnv
381+loadDepModuleIO iface linkable hsc = do
382+ details <- liftIO $ fixIO $ \details -> do
252− e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
383+ let hsc' = hsc { hsc_HPT = addToHpt (hsc_HPT hsc) mod (HomeModInfo iface details linkable) }
253− where
384+ initIfaceLoad hsc' (typecheckIface iface)
254− ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
385+ let mod_info = HomeModInfo iface details linkable
255− mod_info = tmrModInfo tmr
386+ return $ loadModuleHome mod_info hsc
256− mod = ms_mod_name ms
387+ where
257−
388+ mod = moduleName $ mi_module iface
258
389
390+loadDepModule :: GhcMonad m => ModIface -> Maybe Linkable -> m ()
391+loadDepModule iface linkable = do
392+ e <- getSession
393+ e' <- liftIO $ loadDepModuleIO iface linkable e
394+ setSession e'
259
395
260-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's
396-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's
261-- name and its imports.
397-- name and its imports.
@@ -276,30 +412,18 @@ getImportsParsed dflags (L loc parsed) = do
276 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
412 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
277 ])
413 ])
278
414
279−
280-- | Produce a module summary from a StringBuffer.
415-- | Produce a module summary from a StringBuffer.
281getModSummaryFromBuffer
416getModSummaryFromBuffer
282 :: GhcMonad m
417 :: GhcMonad m
283 => FilePath
418 => FilePath
284− -> SB.StringBuffer
285 -> DynFlags
419 -> DynFlags
286 -> GHC.ParsedSource
420 -> GHC.ParsedSource
287 -> ExceptT [FileDiagnostic] m ModSummary
421 -> ExceptT [FileDiagnostic] m ModSummary
288−getModSummaryFromBuffer fp contents dflags parsed = do
422+getModSummaryFromBuffer fp dflags parsed = do
289 (modName, imports) <- liftEither $ getImportsParsed dflags parsed
423 (modName, imports) <- liftEither $ getImportsParsed dflags parsed
290
424
291− let modLoc = ModLocation
425+ modLoc <- liftIO $ mkHomeModLocation dflags modName fp
292− { ml_hs_file = Just fp
293− , ml_hi_file = derivedFile "hi"
294− , ml_obj_file = derivedFile "o"
295−#if MIN_GHC_API_VERSION(8,8,0)
296− , ml_hie_file = derivedFile "hie"
297−#endif
298− -- This does not consider the dflags configuration
299− -- (-osuf and -hisuf, object and hi dir.s).
300− -- However, we anyway don't want to generate them.
301− }
302− InstalledUnitId unitId = thisInstalledUnitId dflags
426+ let InstalledUnitId unitId = thisInstalledUnitId dflags
303 return $ ModSummary
427 return $ ModSummary
304 { ms_mod = mkModule (fsToUnitId unitId) modName
428 { ms_mod = mkModule (fsToUnitId unitId) modName
305 , ms_location = modLoc
429 , ms_location = modLoc
@@ -311,7 +435,7 @@ getModSummaryFromBuffer fp contents dflags parsed = do
311 , ms_textual_imps = [imp | (False, imp) <- imports]
435 , ms_textual_imps = [imp | (False, imp) <- imports]
312 , ms_hspp_file = fp
436 , ms_hspp_file = fp
313 , ms_hspp_opts = dflags
437 , ms_hspp_opts = dflags
314− , ms_hspp_buf = Just contents
438+ , ms_hspp_buf = Nothing
315
439
316 -- defaults:
440 -- defaults:
317 , ms_hsc_src = sourceType
441 , ms_hsc_src = sourceType
@@ -324,27 +448,71 @@ getModSummaryFromBuffer fp contents dflags parsed = do
324 , ms_parsed_mod = Nothing
448 , ms_parsed_mod = Nothing
325 }
449 }
326 where
450 where
327− (sourceType, derivedFile) =
451+ sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile
328− let (stem, ext) = splitExtension fp in
452+
329− if "-boot" `isSuffixOf` ext
453+-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports.
330− then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")
454+-- Runs preprocessors as needed.
331− else (HsSrcFile , \newExt -> stem <.> newExt)
455+getModSummaryFromImports
332−
456+ :: (HasDynFlags m, ExceptionMonad m, MonadIO m)
333−
457+ => FilePath
458+ -> Maybe SB.StringBuffer
459+ -> ExceptT [FileDiagnostic] m ModSummary
460+getModSummaryFromImports fp contents = do
461+ (contents, dflags) <- preprocessor fp contents
462+ (srcImports, textualImports, L _ moduleName) <-
463+ ExceptT $ liftIO $ first (diagFromErrMsgs "parser" dflags) <$> GHC.getHeaderImports dflags contents fp fp
464+
465+ -- Force bits that might keep the string buffer and DynFlags alive unnecessarily
466+ liftIO $ evaluate $ rnf srcImports
467+ liftIO $ evaluate $ rnf textualImports
468+
469+ modLoc <- liftIO $ mkHomeModLocation dflags moduleName fp
470+
471+ let mod = mkModule (thisPackage dflags) moduleName
472+ sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile
473+ summary =
474+ ModSummary
475+ { ms_mod = mod
476+#if MIN_GHC_API_VERSION(8,8,0)
477+ , ms_hie_date = Nothing
478+#endif
479+ , ms_hs_date = error "Rules should not depend on ms_hs_date"
480+ -- When we are working with a virtual file we do not have a file date.
481+ -- To avoid silent issues where something is not processed because the date
482+ -- has not changed, we make sure that things blow up if they depend on the date.
483+ , ms_hsc_src = sourceType
484+ , ms_hspp_buf = Nothing
485+ , ms_hspp_file = fp
486+ , ms_hspp_opts = dflags
487+ , ms_iface_date = Nothing
488+ , ms_location = modLoc
489+ , ms_obj_date = Nothing
490+ , ms_parsed_mod = Nothing
491+ , ms_srcimps = srcImports
492+ , ms_textual_imps = textualImports
493+ }
494+ return summary
495+
496+
334−-- | Given a buffer, flags, file path and module summary, produce a
497+-- | Given a buffer, flags, and file path, produce a
335−-- parsed module (or errors) and any parse warnings.
498+-- parsed module (or errors) and any parse warnings. Does not run any preprocessors
336parseFileContents
499parseFileContents
337 :: GhcMonad m
500 :: GhcMonad m
338 => (GHC.ParsedSource -> IdePreprocessedSource)
501 => (GHC.ParsedSource -> IdePreprocessedSource)
502+ -> DynFlags -- ^ flags to use
503+ -> [PackageName] -- ^ The package imports to ignore
339 -> FilePath -- ^ the filename (for source locations)
504 -> FilePath -- ^ the filename (for source locations)
340− -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
505+ -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
341 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
506 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
342−parseFileContents customPreprocessor filename mbContents = do
507+parseFileContents customPreprocessor dflags comp_pkgs filename contents = do
343− (contents, dflags) <- preprocessor filename mbContents
344 let loc = mkRealSrcLoc (mkFastString filename) 1 1
508 let loc = mkRealSrcLoc (mkFastString filename) 1 1
345 case unP Parser.parseModule (mkPState dflags contents loc) of
509 case unP Parser.parseModule (mkPState dflags contents loc) of
510+#if MIN_GHC_API_VERSION(8,10,0)
511+ PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags
512+#else
346 PFailed _ locErr msgErr ->
513 PFailed _ locErr msgErr ->
347 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
514 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
515+#endif
348 POk pst rdr_module ->
516 POk pst rdr_module ->
349 let hpm_annotations =
517 let hpm_annotations =
350 (Map.fromListWith (++) $ annotations pst,
518 (Map.fromListWith (++) $ annotations pst,
@@ -368,14 +536,63 @@ parseFileContents customPreprocessor filename mbContents = do
368 -- Ok, we got here. It's safe to continue.
536 -- Ok, we got here. It's safe to continue.
369 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
537 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
370 unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs
538 unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs
539+ let parsed' = removePackageImports comp_pkgs parsed
371 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
540 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
372− ms <- getModSummaryFromBuffer filename contents dflags parsed
541+ ms <- getModSummaryFromBuffer filename dflags parsed'
373 let pm =
542 let pm =
374 ParsedModule {
543 ParsedModule {
375 pm_mod_summary = ms
544 pm_mod_summary = ms
376− , pm_parsed_source = parsed
545+ , pm_parsed_source = parsed'
377 , pm_extra_src_files=[] -- src imports not allowed
546 , pm_extra_src_files=[] -- src imports not allowed
378 , pm_annotations = hpm_annotations
547 , pm_annotations = hpm_annotations
379 }
548 }
380 warnings = diagFromErrMsgs "parser" dflags warns
549 warnings = diagFromErrMsgs "parser" dflags warns
381 pure (warnings ++ preproc_warnings, pm)
550 pure (warnings ++ preproc_warnings, pm)
551+
552+
553+-- | After parsing the module remove all package imports referring to
554+-- these packages as we have already dealt with what they map to.
555+removePackageImports :: [PackageName] -> GHC.ParsedSource -> GHC.ParsedSource
556+removePackageImports pkgs (L l h@HsModule {hsmodImports} ) = L l (h { hsmodImports = imports' })
557+ where
558+ imports' = map do_one_import hsmodImports
559+ do_one_import (L l i@ImportDecl{ideclPkgQual}) =
560+ case PackageName . sl_fs <$> ideclPkgQual of
561+ Just pn | pn `elem` pkgs -> L l (i { ideclPkgQual = Nothing })
562+ _ -> L l i
563+#if MIN_GHC_API_VERSION(8,6,0)
564+ do_one_import l = l
565+#endif
566+
567+loadHieFile :: FilePath -> IO GHC.HieFile
568+loadHieFile f = do
569+ u <- mkSplitUniqSupply 'a'
570+ let nameCache = initNameCache u []
571+ fmap (GHC.hie_file_result . fst) $ GHC.readHieFile nameCache f
572+
573+-- | Retuns an up-to-date module interface if available.
574+-- Assumes file exists.
575+-- Requires the 'HscEnv' to be set up with dependencies
576+loadInterface
577+ :: HscEnv
578+ -> ModSummary
579+ -> [HiFileResult]
580+ -> IO (Either String ModIface)
581+loadInterface session ms deps = do
582+ let hiFile = case ms_hsc_src ms of
583+ HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)
584+ _ -> ml_hi_file $ ms_location ms
585+ r <- initIfaceLoad session $ readIface (ms_mod ms) hiFile
586+ case r of
587+ Maybes.Succeeded iface -> do
588+ session' <- foldM (\e d -> loadDepModuleIO (hirModIface d) Nothing e) session deps
589+ (reason, iface') <- checkOldIface session' ms SourceUnmodified (Just iface)
590+ return $ maybeToEither (showReason reason) iface'
591+ Maybes.Failed err -> do
592+ let errMsg = showSDoc (hsc_dflags session) err
593+ return $ Left errMsg
594+
595+showReason :: RecompileRequired -> String
596+showReason MustCompile = "Stale"
597+showReason (RecompBecause reason) = "Stale (" ++ reason ++ ")"
598+showReason UpToDate = "Up to date"
src/Development/IDE/Core/Debouncer.hs+18−11
@@ -3,16 +3,18 @@
3
3
4module Development.IDE.Core.Debouncer
4module Development.IDE.Core.Debouncer
5 ( Debouncer
5 ( Debouncer
6− , newDebouncer
7 , registerEvent
6 , registerEvent
7+ , newAsyncDebouncer
8+ , noopDebouncer
8 ) where
9 ) where
9
10
10import Control.Concurrent.Extra
11import Control.Concurrent.Extra
11import Control.Concurrent.Async
12import Control.Concurrent.Async
12import Control.Exception
13import Control.Exception
13import Control.Monad.Extra
14import Control.Monad.Extra
14−import Data.Map.Strict (Map)
15+import Data.Hashable
16+import Data.HashMap.Strict (HashMap)
15−import qualified Data.Map.Strict as Map
17+import qualified Data.HashMap.Strict as Map
16import System.Time.Extra
18import System.Time.Extra
17
19
18-- | A debouncer can be used to avoid triggering many events
20-- | A debouncer can be used to avoid triggering many events
@@ -21,13 +23,14 @@ import System.Time.Extra
21-- by delaying each event for a given time. If another event
23-- by delaying each event for a given time. If another event
22-- is registered for the same key within that timeframe,
24-- is registered for the same key within that timeframe,
23-- only the new event will fire.
25-- only the new event will fire.
26+--
27+-- We abstract over the debouncer used so we an use a proper debouncer in the IDE but disable
28+-- debouncing in the DAML CLI compiler.
24−newtype Debouncer k = Debouncer (Var (Map k (Async ())))
29+newtype Debouncer k = Debouncer { registerEvent :: Seconds -> k -> IO () -> IO () }
25
30
26−-- | Create a new empty debouncer.
31+-- | Debouncer used in the IDE that delays events as expected.
27−newDebouncer :: IO (Debouncer k)
32+newAsyncDebouncer :: (Eq k, Hashable k) => IO (Debouncer k)
28−newDebouncer = do
33+newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty
29− m <- newVar Map.empty
30− pure $ Debouncer m
31
34
32-- | Register an event that will fire after the given delay if no other event
35-- | Register an event that will fire after the given delay if no other event
33-- for the same key gets registered until then.
36-- for the same key gets registered until then.
@@ -35,11 +38,15 @@ newDebouncer = do
35-- If there is a pending event for the same key, the pending event will be killed.
38-- If there is a pending event for the same key, the pending event will be killed.
36-- Events are run unmasked so it is up to the user of `registerEvent`
39-- Events are run unmasked so it is up to the user of `registerEvent`
37-- to mask if required.
40-- to mask if required.
38−registerEvent :: Ord k => Debouncer k -> Seconds -> k -> IO () -> IO ()
41+asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()
39−registerEvent (Debouncer d) delay k fire = modifyVar_ d $ \m -> mask_ $ do
42+asyncRegisterEvent d delay k fire = modifyVar_ d $ \m -> mask_ $ do
40 whenJust (Map.lookup k m) cancel
43 whenJust (Map.lookup k m) cancel
41 a <- asyncWithUnmask $ \unmask -> unmask $ do
44 a <- asyncWithUnmask $ \unmask -> unmask $ do
42 sleep delay
45 sleep delay
43 fire
46 fire
44 modifyVar_ d (pure . Map.delete k)
47 modifyVar_ d (pure . Map.delete k)
45 pure $ Map.insert k a m
48 pure $ Map.insert k a m
49+
50+-- | Debouncer used in the DAML CLI compiler that emits events immediately.
51+noopDebouncer :: Debouncer k
52+noopDebouncer = Debouncer $ \_ _ a -> a
src/Development/IDE/Core/FileExists.hsnew file+181
@@ -0,0 +1,181 @@
1+{-# LANGUAGE OverloadedLists #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE UndecidableInstances #-}
4+module Development.IDE.Core.FileExists
5+ ( fileExistsRules
6+ , modifyFileExists
7+ , getFileExists
8+ )
9+where
10+
11+import Control.Concurrent.Extra
12+import Control.Exception
13+import Control.Monad.Extra
14+import qualified Data.Aeson as A
15+import Data.Binary
16+import qualified Data.ByteString as BS
17+import Data.HashMap.Strict (HashMap)
18+import qualified Data.HashMap.Strict as HashMap
19+import Data.Maybe
20+import qualified Data.Text as T
21+import Development.IDE.Core.FileStore
22+import Development.IDE.Core.IdeConfiguration
23+import Development.IDE.Core.Shake
24+import Development.IDE.Types.Location
25+import Development.IDE.Types.Logger
26+import Development.Shake
27+import Development.Shake.Classes
28+import GHC.Generics
29+import Language.Haskell.LSP.Messages
30+import Language.Haskell.LSP.Types
31+import Language.Haskell.LSP.Types.Capabilities
32+import qualified System.Directory as Dir
33+
34+-- | A map for tracking the file existence
35+type FileExistsMap = (HashMap NormalizedFilePath Bool)
36+
37+-- | A wrapper around a mutable 'FileExistsMap'
38+newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap)
39+
40+instance IsIdeGlobal FileExistsMapVar
41+
42+-- | Grab the current global value of 'FileExistsMap' without acquiring a dependency
43+getFileExistsMapUntracked :: Action FileExistsMap
44+getFileExistsMapUntracked = do
45+ FileExistsMapVar v <- getIdeGlobalAction
46+ liftIO $ readVar v
47+
48+-- | Modify the global store of file exists
49+modifyFileExistsAction :: (FileExistsMap -> IO FileExistsMap) -> Action ()
50+modifyFileExistsAction f = do
51+ FileExistsMapVar var <- getIdeGlobalAction
52+ liftIO $ modifyVar_ var f
53+
54+-- | Modify the global store of file exists
55+modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO ()
56+modifyFileExists state changes = do
57+ FileExistsMapVar var <- getIdeGlobalState state
58+ changesMap <- evaluate $ HashMap.fromList changes
59+
60+ -- Masked to ensure that the previous values are flushed together with the map update
61+ mask $ \_ -> do
62+ -- update the map
63+ modifyVar_ var $ evaluate . HashMap.union changesMap
64+ -- flush previous values
65+ mapM_ (deleteValue state GetFileExists . fst) changes
66+
67+-------------------------------------------------------------------------------------
68+
69+type instance RuleResult GetFileExists = Bool
70+
71+data GetFileExists = GetFileExists
72+ deriving (Eq, Show, Typeable, Generic)
73+
74+instance NFData GetFileExists
75+instance Hashable GetFileExists
76+instance Binary GetFileExists
77+
78+-- | Returns True if the file exists
79+-- Note that a file is not considered to exist unless it is saved to disk.
80+-- In particular, VFS existence is not enough.
81+-- Consider the following example:
82+-- 1. The file @A.hs@ containing the line @import B@ is added to the files of interest
83+-- Since @B.hs@ is neither open nor exists, GetLocatedImports finds Nothing
84+-- 2. The editor creates a new buffer @B.hs@
85+-- Unless the editor also sends a @DidChangeWatchedFile@ event, ghcide will not pick it up
86+-- Most editors, e.g. VSCode, only send the event when the file is saved to disk.
87+getFileExists :: NormalizedFilePath -> Action Bool
88+getFileExists fp = use_ GetFileExists fp
89+
90+-- | Installs the 'getFileExists' rules.
91+-- Provides a fast implementation if client supports dynamic watched files.
92+-- Creates a global state as a side effect in that case.
93+fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules ()
94+fileExistsRules getLspId ClientCapabilities{_workspace} vfs = do
95+ -- Create the global always, although it should only be used if we have fast rules.
96+ -- But there's a chance someone will send unexpected notifications anyway,
97+ -- e.g. https://github.com/digital-asset/ghcide/issues/599
98+ addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])
99+ case () of
100+ _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
101+ , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
102+ , Just True <- _dynamicRegistration
103+ -> fileExistsRulesFast getLspId vfs
104+ | otherwise -> do
105+ logger <- logger <$> getShakeExtrasRules
106+ liftIO $ logDebug logger "Warning: Client does not support watched files. Falling back to OS polling"
107+ fileExistsRulesSlow vfs
108+
109+-- Requires an lsp client that provides WatchedFiles notifications.
110+fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()
111+fileExistsRulesFast getLspId vfs =
112+ defineEarlyCutoff $ \GetFileExists file -> do
113+ isWf <- isWorkspaceFile file
114+ if isWf
115+ then fileExistsFast getLspId vfs file
116+ else fileExistsSlow vfs file
117+
118+fileExistsFast :: IO LspId -> VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))
119+fileExistsFast getLspId vfs file = do
120+ fileExistsMap <- getFileExistsMapUntracked
121+ let mbFilesWatched = HashMap.lookup file fileExistsMap
122+ case mbFilesWatched of
123+ Just fv -> pure (summarizeExists fv, ([], Just fv))
124+ Nothing -> do
125+ exist <- liftIO $ getFileExistsVFS vfs file
126+ ShakeExtras { eventer } <- getShakeExtras
127+
128+ -- add a listener for VFS Create/Delete file events,
129+ -- taking the FileExistsMap lock to prevent race conditions
130+ -- that would lead to multiple listeners for the same path
131+ modifyFileExistsAction $ \x -> do
132+ case HashMap.alterF (,Just exist) file x of
133+ (Nothing, x') -> do
134+ -- if the listener addition fails, we never recover. This is a bug.
135+ addListener eventer file
136+ return x'
137+ (Just _, _) ->
138+ -- if the key was already there, do nothing
139+ return x
140+
141+ pure (summarizeExists exist, ([], Just exist))
142+ where
143+ addListener eventer fp = do
144+ reqId <- getLspId
145+ let
146+ req = RequestMessage "2.0" reqId ClientRegisterCapability regParams
147+ fpAsId = T.pack $ fromNormalizedFilePath fp
148+ regParams = RegistrationParams (List [registration])
149+ registration = Registration fpAsId
150+ WorkspaceDidChangeWatchedFiles
151+ (Just (A.toJSON regOptions))
152+ regOptions =
153+ DidChangeWatchedFilesRegistrationOptions { _watchers = List [watcher] }
154+ watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True}
155+ watcher = FileSystemWatcher { _globPattern = fromNormalizedFilePath fp
156+ , _kind = Just watchKind
157+ }
158+
159+ eventer $ ReqRegisterCapability req
160+
161+summarizeExists :: Bool -> Maybe BS.ByteString
162+summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty
163+
164+fileExistsRulesSlow:: VFSHandle -> Rules ()
165+fileExistsRulesSlow vfs =
166+ defineEarlyCutoff $ \GetFileExists file -> fileExistsSlow vfs file
167+
168+fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))
169+fileExistsSlow vfs file = do
170+ alwaysRerun
171+ exist <- liftIO $ getFileExistsVFS vfs file
172+ pure (summarizeExists exist, ([], Just exist))
173+
174+getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool
175+getFileExistsVFS vfs file = do
176+ -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
177+ -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
178+ -- cached 'No' rather than an exception in the wrong place
179+ handle (\(_ :: IOException) -> return False) $
180+ (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
181+ Dir.doesFileExist (fromNormalizedFilePath file)
src/Development/IDE/Core/FileStore.hs+21−69
@@ -4,32 +4,25 @@
4{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE TypeFamilies #-}
5
5
6module Development.IDE.Core.FileStore(
6module Development.IDE.Core.FileStore(
7− getFileExists, getFileContents,
7+ getFileContents,
8+ getVirtualFile,
8 setBufferModified,
9 setBufferModified,
9 setSomethingModified,
10 setSomethingModified,
10 fileStoreRules,
11 fileStoreRules,
11 VFSHandle,
12 VFSHandle,
12 makeVFSHandle,
13 makeVFSHandle,
13− makeLSPVFSHandle,
14+ makeLSPVFSHandle
14− getSourceFingerprint
15 ) where
15 ) where
16
16
17−import Foreign.Ptr
18−import Foreign.ForeignPtr
19−import Fingerprint
20−import StringBuffer
21import Development.IDE.GHC.Orphans()
17import Development.IDE.GHC.Orphans()
22−import Development.IDE.GHC.Util
18+import Development.IDE.Core.Shake
23−
24import Control.Concurrent.Extra
19import Control.Concurrent.Extra
25import qualified Data.Map.Strict as Map
20import qualified Data.Map.Strict as Map
26import Data.Maybe
21import Data.Maybe
27import qualified Data.Text as T
22import qualified Data.Text as T
28import Control.Monad.Extra
23import Control.Monad.Extra
29−import qualified System.Directory as Dir
30import Development.Shake
24import Development.Shake
31import Development.Shake.Classes
25import Development.Shake.Classes
32−import Development.IDE.Core.Shake
33import Control.Exception
26import Control.Exception
34import GHC.Generics
27import GHC.Generics
35import Data.Either.Extra
28import Data.Either.Extra
@@ -41,7 +34,9 @@ import qualified Data.Rope.UTF16 as Rope
41
34
42#ifdef mingw32_HOST_OS
35#ifdef mingw32_HOST_OS
43import Data.Time
36import Data.Time
37+import qualified System.Directory as Dir
44#else
38#else
39+import Foreign.Ptr
45import Foreign.C.String
40import Foreign.C.String
46import Foreign.C.Types
41import Foreign.C.Types
47import Foreign.Marshal (alloca)
42import Foreign.Marshal (alloca)
@@ -76,7 +71,8 @@ makeVFSHandle = do
76 modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $
71 modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $
77 case content of
72 case content of
78 Nothing -> Map.delete uri vfs
73 Nothing -> Map.delete uri vfs
74+ -- The second version number is only used in persistFileVFS which we do not use so we set it to 0.
79− Just content -> Map.insert uri (VirtualFile nextVersion (Rope.fromText content)) vfs
75+ Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) vfs
80 }
76 }
81
77
82makeLSPVFSHandle :: LspFuncs c -> VFSHandle
78makeLSPVFSHandle :: LspFuncs c -> VFSHandle
@@ -87,18 +83,7 @@ makeLSPVFSHandle lspFuncs = VFSHandle
87
83
88
84
89-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
85-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
90−type instance RuleResult GetFileContents = (FileVersion, Maybe StringBuffer)
86+type instance RuleResult GetFileContents = (FileVersion, Maybe T.Text)
91−
92−-- | Does the file exist.
93−type instance RuleResult GetFileExists = Bool
94−
95−type instance RuleResult FingerprintSource = Fingerprint
96−
97−data GetFileExists = GetFileExists
98− deriving (Eq, Show, Generic)
99−instance Hashable GetFileExists
100−instance NFData GetFileExists
101−instance Binary GetFileExists
102
87
103data GetFileContents = GetFileContents
88data GetFileContents = GetFileContents
104 deriving (Eq, Show, Generic)
89 deriving (Eq, Show, Generic)
@@ -106,40 +91,16 @@ instance Hashable GetFileContents
106instance NFData GetFileContents
91instance NFData GetFileContents
107instance Binary GetFileContents
92instance Binary GetFileContents
108
93
109−data FingerprintSource = FingerprintSource
110− deriving (Eq, Show, Generic)
111−instance Hashable FingerprintSource
112−instance NFData FingerprintSource
113−instance Binary FingerprintSource
114−
115−fingerprintSourceRule :: Rules ()
116−fingerprintSourceRule =
117− define $ \FingerprintSource file -> do
118− (_, mbContent) <- getFileContents file
119− content <- liftIO $ maybe (hGetStringBuffer $ fromNormalizedFilePath file) pure mbContent
120− fingerprint <- liftIO $ fpStringBuffer content
121− pure ([], Just fingerprint)
122− where fpStringBuffer (StringBuffer buf len cur) = withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len
123−
124−getFileExistsRule :: VFSHandle -> Rules ()
125−getFileExistsRule vfs =
126− defineEarlyCutoff $ \GetFileExists file -> do
127− alwaysRerun
128− res <- liftIO $ handle (\(_ :: IOException) -> return False) $
129− (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
130− Dir.doesFileExist (fromNormalizedFilePath file)
131− return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))
132−
133−
134getModificationTimeRule :: VFSHandle -> Rules ()
94getModificationTimeRule :: VFSHandle -> Rules ()
135getModificationTimeRule vfs =
95getModificationTimeRule vfs =
136 defineEarlyCutoff $ \GetModificationTime file -> do
96 defineEarlyCutoff $ \GetModificationTime file -> do
137 let file' = fromNormalizedFilePath file
97 let file' = fromNormalizedFilePath file
138− let wrap time = (Just time, ([], Just $ ModificationTime time))
98+ let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s))
139 alwaysRerun
99 alwaysRerun
140 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
100 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
141 case mbVirtual of
101 case mbVirtual of
102+ Just (virtualFileVersion -> ver) ->
142− Just (VirtualFile ver _) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
103+ pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
143 Nothing -> liftIO $ fmap wrap (getModTime file')
104 Nothing -> liftIO $ fmap wrap (getModTime file')
144 `catch` \(e :: IOException) -> do
105 `catch` \(e :: IOException) -> do
145 let err | isDoesNotExistError e = "File does not exist: " ++ file'
106 let err | isDoesNotExistError e = "File does not exist: " ++ file'
@@ -153,11 +114,15 @@ getModificationTimeRule vfs =
153 -- time spent checking file modifications (which happens on every change)
114 -- time spent checking file modifications (which happens on every change)
154 -- from > 0.5s to ~0.15s.
115 -- from > 0.5s to ~0.15s.
155 -- We might also want to try speeding this up on Windows at some point.
116 -- We might also want to try speeding this up on Windows at some point.
117+ -- TODO leverage DidChangeWatchedFile lsp notifications on clients that
118+ -- support them, as done for GetFileExists
156− getModTime :: FilePath -> IO BS.ByteString
119+ getModTime :: FilePath -> IO (Int,Int)
157 getModTime f =
120 getModTime f =
158#ifdef mingw32_HOST_OS
121#ifdef mingw32_HOST_OS
159 do time <- Dir.getModificationTime f
122 do time <- Dir.getModificationTime f
123+ let !day = fromInteger $ toModifiedJulianDay $ utctDay time
160− pure $! BS.pack $ show (toModifiedJulianDay $ utctDay time, diffTimeToPicoseconds $ utctDayTime time)
124+ !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time
125+ pure (day, dayTime)
161#else
126#else
162 withCString f $ \f' ->
127 withCString f $ \f' ->
163 alloca $ \secPtr ->
128 alloca $ \secPtr ->
@@ -165,16 +130,13 @@ getModificationTimeRule vfs =
165 Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr
130 Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr
166 sec <- peek secPtr
131 sec <- peek secPtr
167 nsec <- peek nsecPtr
132 nsec <- peek nsecPtr
168− pure $! BS.pack $ show sec <> "." <> show nsec
133+ pure (fromEnum sec, fromIntegral nsec)
169
134
170-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow
135-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow
171-- as doing the FFI call ourselves :(.
136-- as doing the FFI call ourselves :(.
172foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int
137foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int
173#endif
138#endif
174
139
175−getSourceFingerprint :: NormalizedFilePath -> Action Fingerprint
176−getSourceFingerprint = use_ FingerprintSource
177−
178getFileContentsRule :: VFSHandle -> Rules ()
140getFileContentsRule :: VFSHandle -> Rules ()
179getFileContentsRule vfs =
141getFileContentsRule vfs =
180 define $ \GetFileContents file -> do
142 define $ \GetFileContents file -> do
@@ -182,7 +144,7 @@ getFileContentsRule vfs =
182 time <- use_ GetModificationTime file
144 time <- use_ GetModificationTime file
183 res <- liftIO $ ideTryIOException file $ do
145 res <- liftIO $ ideTryIOException file $ do
184 mbVirtual <- getVirtualFile vfs $ filePathToUri' file
146 mbVirtual <- getVirtualFile vfs $ filePathToUri' file
185− pure $ textToStringBuffer . Rope.toText . _text <$> mbVirtual
147+ pure $ Rope.toText . _text <$> mbVirtual
186 case res of
148 case res of
187 Left err -> return ([err], Nothing)
149 Left err -> return ([err], Nothing)
188 Right contents -> return ([], Just (time, contents))
150 Right contents -> return ([], Just (time, contents))
@@ -194,24 +156,14 @@ ideTryIOException fp act =
194 <$> try act
156 <$> try act
195
157
196
158
197−getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe StringBuffer)
159+getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe T.Text)
198getFileContents = use_ GetFileContents
160getFileContents = use_ GetFileContents
199
161
200−getFileExists :: NormalizedFilePath -> Action Bool
201−getFileExists =
202− -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
203− -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
204− -- cached 'No' rather than an exception in the wrong place
205− use_ GetFileExists
206−
207−
208fileStoreRules :: VFSHandle -> Rules ()
162fileStoreRules :: VFSHandle -> Rules ()
209fileStoreRules vfs = do
163fileStoreRules vfs = do
210 addIdeGlobal vfs
164 addIdeGlobal vfs
211 getModificationTimeRule vfs
165 getModificationTimeRule vfs
212 getFileContentsRule vfs
166 getFileContentsRule vfs
213− getFileExistsRule vfs
214− fingerprintSourceRule
215
167
216
168
217-- | Notify the compiler service that a particular file has been modified.
169-- | Notify the compiler service that a particular file has been modified.
src/Development/IDE/Core/IdeConfiguration.hsnew file+71
@@ -0,0 +1,71 @@
1+{-# LANGUAGE DuplicateRecordFields #-}
2+module Development.IDE.Core.IdeConfiguration
3+ ( IdeConfiguration(..)
4+ , registerIdeConfiguration
5+ , parseConfiguration
6+ , parseWorkspaceFolder
7+ , isWorkspaceFile
8+ , modifyWorkspaceFolders
9+ )
10+where
11+
12+import Control.Concurrent.Extra
13+import Control.Monad
14+import Data.HashSet (HashSet, singleton)
15+import Data.Text (Text, isPrefixOf)
16+import Development.IDE.Core.Shake
17+import Development.IDE.Types.Location
18+import Development.Shake
19+import Language.Haskell.LSP.Types
20+import System.FilePath (isRelative)
21+
22+-- | Lsp client relevant configuration details
23+data IdeConfiguration = IdeConfiguration
24+ { workspaceFolders :: HashSet NormalizedUri
25+ }
26+ deriving (Show)
27+
28+newtype IdeConfigurationVar = IdeConfigurationVar {unIdeConfigurationRef :: Var IdeConfiguration}
29+
30+instance IsIdeGlobal IdeConfigurationVar
31+
32+registerIdeConfiguration :: ShakeExtras -> IdeConfiguration -> IO ()
33+registerIdeConfiguration extras =
34+ addIdeGlobalExtras extras . IdeConfigurationVar <=< newVar
35+
36+getIdeConfiguration :: Action IdeConfiguration
37+getIdeConfiguration =
38+ getIdeGlobalAction >>= liftIO . readVar . unIdeConfigurationRef
39+
40+parseConfiguration :: InitializeParams -> IdeConfiguration
41+parseConfiguration InitializeParams {..} =
42+ IdeConfiguration { .. }
43+ where
44+ workspaceFolders =
45+ foldMap (singleton . toNormalizedUri) _rootUri
46+ <> (foldMap . foldMap)
47+ (singleton . parseWorkspaceFolder)
48+ _workspaceFolders
49+
50+parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri
51+parseWorkspaceFolder =
52+ toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text)
53+
54+modifyWorkspaceFolders
55+ :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()
56+modifyWorkspaceFolders ide f = do
57+ IdeConfigurationVar var <- getIdeGlobalState ide
58+ IdeConfiguration ws <- readVar var
59+ writeVar var (IdeConfiguration (f ws))
60+
61+isWorkspaceFile :: NormalizedFilePath -> Action Bool
62+isWorkspaceFile file =
63+ if isRelative (fromNormalizedFilePath file)
64+ then return True
65+ else do
66+ IdeConfiguration {..} <- getIdeConfiguration
67+ let toText = getUri . fromNormalizedUri
68+ return $
69+ any
70+ (\root -> toText root `isPrefixOf` toText (filePathToUri' file))
71+ workspaceFolders
src/Development/IDE/Core/OfInterest.hs+24−24
@@ -1,19 +1,17 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4−
5−{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
7
6
8−-- | A Shake implementation of the compiler service, built
7+-- | Utilities and state for the files of interest - those which are currently
9−-- using the "Shaker" abstraction layer for in-memory use.
8+-- open in the editor. The useful function is 'getFilesOfInterest'.
10−--
11module Development.IDE.Core.OfInterest(
9module Development.IDE.Core.OfInterest(
12 ofInterestRules,
10 ofInterestRules,
13 getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,
11 getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,
14 ) where
12 ) where
15
13
16−import Control.Concurrent.Extra
14+import Control.Concurrent.Extra
17import Data.Binary
15import Data.Binary
18import Data.Hashable
16import Data.Hashable
19import Control.DeepSeq
17import Control.DeepSeq
@@ -21,25 +19,22 @@ import GHC.Generics
21import Data.Typeable
19import Data.Typeable
22import qualified Data.ByteString.UTF8 as BS
20import qualified Data.ByteString.UTF8 as BS
23import Control.Exception
21import Control.Exception
24−import Development.IDE.Types.Location
22+import Data.HashSet (HashSet)
25−import Development.IDE.Types.Logger
26−import Data.Set (Set)
27−import qualified Data.Set as Set
23+import qualified Data.HashSet as HashSet
28import qualified Data.Text as T
24import qualified Data.Text as T
29import Data.Tuple.Extra
25import Data.Tuple.Extra
30import Data.Functor
26import Data.Functor
31−import Development.Shake
32−
33−import Development.IDE.Core.Shake
27+import Development.Shake
34
28
29+import Development.IDE.Types.Location
30+import Development.IDE.Types.Logger
31+import Development.IDE.Core.Shake
35
32
36
33
37−newtype OfInterestVar = OfInterestVar (Var (Set NormalizedFilePath))
34+newtype OfInterestVar = OfInterestVar (Var (HashSet NormalizedFilePath))
38instance IsIdeGlobal OfInterestVar
35instance IsIdeGlobal OfInterestVar
39
36
40−
41−type instance RuleResult GetFilesOfInterest = Set NormalizedFilePath
37+type instance RuleResult GetFilesOfInterest = HashSet NormalizedFilePath
42−
43
38
44data GetFilesOfInterest = GetFilesOfInterest
39data GetFilesOfInterest = GetFilesOfInterest
45 deriving (Eq, Show, Typeable, Generic)
40 deriving (Eq, Show, Typeable, Generic)
@@ -48,16 +43,18 @@ instance NFData GetFilesOfInterest
48instance Binary GetFilesOfInterest
43instance Binary GetFilesOfInterest
49
44
50
45
46+-- | The rule that initialises the files of interest state.
51ofInterestRules :: Rules ()
47ofInterestRules :: Rules ()
52ofInterestRules = do
48ofInterestRules = do
53− addIdeGlobal . OfInterestVar =<< liftIO (newVar Set.empty)
49+ addIdeGlobal . OfInterestVar =<< liftIO (newVar HashSet.empty)
54 defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do
50 defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do
55 alwaysRerun
51 alwaysRerun
56 filesOfInterest <- getFilesOfInterestUntracked
52 filesOfInterest <- getFilesOfInterestUntracked
57 pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest))
53 pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest))
58
54
59
55
56+-- | Get the files that are open in the IDE.
60−getFilesOfInterest :: Action (Set NormalizedFilePath)
57+getFilesOfInterest :: Action (HashSet NormalizedFilePath)
61getFilesOfInterest = useNoFile_ GetFilesOfInterest
58getFilesOfInterest = useNoFile_ GetFilesOfInterest
62
59
63
60
@@ -65,18 +62,21 @@ getFilesOfInterest = useNoFile_ GetFilesOfInterest
65------------------------------------------------------------
62------------------------------------------------------------
66-- Exposed API
63-- Exposed API
67
64
68−-- | Set the files-of-interest which will be built and kept-up-to-date.
65+-- | Set the files-of-interest - not usually necessary or advisable.
66+-- The LSP client will keep this information up to date.
69−setFilesOfInterest :: IdeState -> Set NormalizedFilePath -> IO ()
67+setFilesOfInterest :: IdeState -> HashSet NormalizedFilePath -> IO ()
70setFilesOfInterest state files = modifyFilesOfInterest state (const files)
68setFilesOfInterest state files = modifyFilesOfInterest state (const files)
71
69
72−getFilesOfInterestUntracked :: Action (Set NormalizedFilePath)
70+getFilesOfInterestUntracked :: Action (HashSet NormalizedFilePath)
73getFilesOfInterestUntracked = do
71getFilesOfInterestUntracked = do
74 OfInterestVar var <- getIdeGlobalAction
72 OfInterestVar var <- getIdeGlobalAction
75 liftIO $ readVar var
73 liftIO $ readVar var
76
74
75+-- | Modify the files-of-interest - not usually necessary or advisable.
76+-- The LSP client will keep this information up to date.
77−modifyFilesOfInterest :: IdeState -> (Set NormalizedFilePath -> Set NormalizedFilePath) -> IO ()
77+modifyFilesOfInterest :: IdeState -> (HashSet NormalizedFilePath -> HashSet NormalizedFilePath) -> IO ()
78modifyFilesOfInterest state f = do
78modifyFilesOfInterest state f = do
79 OfInterestVar var <- getIdeGlobalState state
79 OfInterestVar var <- getIdeGlobalState state
80 files <- modifyVar var $ pure . dupe . f
80 files <- modifyVar var $ pure . dupe . f
81− logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ Set.toList files)
81+ logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashSet.toList files)
82 void $ shakeRun state []
82 void $ shakeRun state []
src/Development/IDE/Core/PositionMapping.hs+48−10
@@ -2,10 +2,15 @@
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3module Development.IDE.Core.PositionMapping
3module Development.IDE.Core.PositionMapping
4 ( PositionMapping(..)
4 ( PositionMapping(..)
5+ , fromCurrentPosition
6+ , toCurrentPosition
7+ , PositionDelta(..)
8+ , addDelta
9+ , mkDelta
5 , toCurrentRange
10 , toCurrentRange
6 , fromCurrentRange
11 , fromCurrentRange
7 , applyChange
12 , applyChange
8− , idMapping
13+ , zeroMapping
9 -- toCurrent and fromCurrent are mainly exposed for testing
14 -- toCurrent and fromCurrent are mainly exposed for testing
10 , toCurrent
15 , toCurrent
11 , fromCurrent
16 , fromCurrent
@@ -14,12 +19,25 @@ module Development.IDE.Core.PositionMapping
14import Control.Monad
19import Control.Monad
15import qualified Data.Text as T
20import qualified Data.Text as T
16import Language.Haskell.LSP.Types
21import Language.Haskell.LSP.Types
22+import Data.List
17
23
18−data PositionMapping = PositionMapping
24+-- The position delta is the difference between two versions
25+data PositionDelta = PositionDelta
19− { toCurrentPosition :: !(Position -> Maybe Position)
26+ { toDelta :: !(Position -> Maybe Position)
20− , fromCurrentPosition :: !(Position -> Maybe Position)
27+ , fromDelta :: !(Position -> Maybe Position)
21 }
28 }
22
29
30+fromCurrentPosition :: PositionMapping -> Position -> Maybe Position
31+fromCurrentPosition (PositionMapping pm) = fromDelta pm
32+
33+toCurrentPosition :: PositionMapping -> Position -> Maybe Position
34+toCurrentPosition (PositionMapping pm) = toDelta pm
35+
36+-- A position mapping is the difference from the current version to
37+-- a specific version
38+newtype PositionMapping = PositionMapping PositionDelta
39+
40+
23toCurrentRange :: PositionMapping -> Range -> Maybe Range
41toCurrentRange :: PositionMapping -> Range -> Maybe Range
24toCurrentRange mapping (Range a b) =
42toCurrentRange mapping (Range a b) =
25 Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b
43 Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b
@@ -28,13 +46,33 @@ fromCurrentRange :: PositionMapping -> Range -> Maybe Range
28fromCurrentRange mapping (Range a b) =
46fromCurrentRange mapping (Range a b) =
29 Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b
47 Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b
30
48
31−idMapping :: PositionMapping
49+zeroMapping :: PositionMapping
32−idMapping = PositionMapping Just Just
50+zeroMapping = PositionMapping idDelta
51+
52+-- | Compose two position mappings. Composes in the same way as function
53+-- composition (ie the second argument is applyed to the position first).
54+composeDelta :: PositionDelta
55+ -> PositionDelta
56+ -> PositionDelta
57+composeDelta (PositionDelta to1 from1) (PositionDelta to2 from2) =
58+ PositionDelta (to1 <=< to2)
59+ (from1 >=> from2)
60+
61+idDelta :: PositionDelta
62+idDelta = PositionDelta Just Just
63+
64+-- | Convert a set of changes into a delta from k to k + 1
65+mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta
66+mkDelta cs = foldl' applyChange idDelta cs
67+
68+-- | Add a new delta onto a Mapping k n to make a Mapping (k - 1) n
69+addDelta :: PositionDelta -> PositionMapping -> PositionMapping
70+addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm)
33
71
34−applyChange :: PositionMapping -> TextDocumentContentChangeEvent -> PositionMapping
72+applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta
35−applyChange posMapping (TextDocumentContentChangeEvent (Just r) _ t) = PositionMapping
73+applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta
36− { toCurrentPosition = toCurrent r t <=< toCurrentPosition posMapping
74+ { toDelta = toCurrent r t <=< toDelta
37− , fromCurrentPosition = fromCurrentPosition posMapping <=< fromCurrent r t
75+ , fromDelta = fromDelta <=< fromCurrent r t
38 }
76 }
39applyChange posMapping _ = posMapping
77applyChange posMapping _ = posMapping
40
78
src/Development/IDE/Core/Preprocessor.hs+104−8
@@ -8,7 +8,6 @@ module Development.IDE.Core.Preprocessor
8import Development.IDE.GHC.CPP
8import Development.IDE.GHC.CPP
9import Development.IDE.GHC.Orphans()
9import Development.IDE.GHC.Orphans()
10import Development.IDE.GHC.Compat
10import Development.IDE.GHC.Compat
11−import GHC
12import GhcMonad
11import GhcMonad
13import StringBuffer as SB
12import StringBuffer as SB
14
13
@@ -19,16 +18,26 @@ import Data.Char
19import DynFlags
18import DynFlags
20import qualified HeaderInfo as Hdr
19import qualified HeaderInfo as Hdr
21import Development.IDE.Types.Diagnostics
20import Development.IDE.Types.Diagnostics
21+import Development.IDE.Types.Location
22import Development.IDE.GHC.Error
22import Development.IDE.GHC.Error
23−import SysTools (Option (..), runUnlit)
23+import SysTools (Option (..), runUnlit, runPp)
24import Control.Monad.Trans.Except
24import Control.Monad.Trans.Except
25import qualified GHC.LanguageExtensions as LangExt
25import qualified GHC.LanguageExtensions as LangExt
26import Data.Maybe
26import Data.Maybe
27+import Control.Exception.Safe (catch, throw)
28+import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
29+import Data.Text (Text)
30+import qualified Data.Text as T
31+import Outputable (showSDoc)
32+import Control.DeepSeq (NFData(rnf))
33+import Control.Exception (evaluate)
34+import Control.Monad.IO.Class (MonadIO)
35+import Exception (ExceptionMonad)
27
36
28
37
29-- | Given a file and some contents, apply any necessary preprocessors,
38-- | Given a file and some contents, apply any necessary preprocessors,
30-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.
39-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.
31−preprocessor :: GhcMonad m => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)
40+preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)
32preprocessor filename mbContents = do
41preprocessor filename mbContents = do
33 -- Perform unlit
42 -- Perform unlit
34 (isOnDisk, contents) <-
43 (isOnDisk, contents) <-
@@ -43,12 +52,79 @@ preprocessor filename mbContents = do
43
52
44 -- Perform cpp
53 -- Perform cpp
45 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
54 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
55+ (isOnDisk, contents, dflags) <-
46− if not $ xopt LangExt.Cpp dflags then
56+ if not $ xopt LangExt.Cpp dflags then
57+ return (isOnDisk, contents, dflags)
58+ else do
59+ cppLogs <- liftIO $ newIORef []
60+ contents <- ExceptT
61+ $ liftIO
62+ $ (Right <$> (runCpp dflags {log_action = logAction cppLogs} filename
63+ $ if isOnDisk then Nothing else Just contents))
64+ `catch`
65+ ( \(e :: GhcException) -> do
66+ logs <- readIORef cppLogs
67+ case diagsFromCPPLogs filename (reverse logs) of
68+ [] -> throw e
69+ diags -> return $ Left diags
70+ )
71+ dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
72+ return (False, contents, dflags)
73+
74+ -- Perform preprocessor
75+ if not $ gopt Opt_Pp dflags then
47 return (contents, dflags)
76 return (contents, dflags)
48 else do
77 else do
49− contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents
78+ contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents
50 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
79 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
51 return (contents, dflags)
80 return (contents, dflags)
81+ where
82+ logAction :: IORef [CPPLog] -> LogAction
83+ logAction cppLogs dflags _reason severity srcSpan _style msg = do
84+ let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg
85+ modifyIORef cppLogs (log :)
86+
87+
88+data CPPLog = CPPLog Severity SrcSpan Text
89+ deriving (Show)
90+
91+
92+data CPPDiag
93+ = CPPDiag
94+ { cdRange :: Range,
95+ cdSeverity :: Maybe DiagnosticSeverity,
96+ cdMessage :: [Text]
97+ }
98+ deriving (Show)
99+
100+
101+diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic]
102+diagsFromCPPLogs filename logs =
103+ map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $
104+ go [] logs
105+ where
106+ -- On errors, CPP calls logAction with a real span for the initial log and
107+ -- then additional informational logs with `UnhelpfulSpan`. Collect those
108+ -- informational log messages and attaches them to the initial log message.
109+ go :: [CPPDiag] -> [CPPLog] -> [CPPDiag]
110+ go acc [] = reverse $ map (\d -> d {cdMessage = reverse $ cdMessage d}) acc
111+ go acc (CPPLog sev span@(RealSrcSpan _) msg : logs) =
112+ let diag = CPPDiag (srcSpanToRange span) (toDSeverity sev) [msg]
113+ in go (diag : acc) logs
114+ go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) =
115+ go (diag {cdMessage = msg : cdMessage diag} : diags) logs
116+ go [] (CPPLog _sev (UnhelpfulSpan _) _msg : logs) = go [] logs
117+ cppDiagToDiagnostic :: CPPDiag -> Diagnostic
118+ cppDiagToDiagnostic d =
119+ Diagnostic
120+ { _range = cdRange d,
121+ _severity = cdSeverity d,
122+ _code = Nothing,
123+ _source = Just "CPP",
124+ _message = T.unlines $ cdMessage d,
125+ _relatedInformation = Nothing,
126+ _tags = Nothing
127+ }
52
128
53
129
54isLiterate :: FilePath -> Bool
130isLiterate :: FilePath -> Bool
@@ -57,13 +133,17 @@ isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]
57
133
58-- | This reads the pragma information directly from the provided buffer.
134-- | This reads the pragma information directly from the provided buffer.
59parsePragmasIntoDynFlags
135parsePragmasIntoDynFlags
60− :: GhcMonad m
136+ :: (ExceptionMonad m, HasDynFlags m, MonadIO m)
61 => FilePath
137 => FilePath
62 -> SB.StringBuffer
138 -> SB.StringBuffer
63 -> m (Either [FileDiagnostic] DynFlags)
139 -> m (Either [FileDiagnostic] DynFlags)
64parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do
140parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do
65− dflags0 <- getSessionDynFlags
141+ dflags0 <- getDynFlags
66 let opts = Hdr.getOptions dflags0 contents fp
142 let opts = Hdr.getOptions dflags0 contents fp
143+
144+ -- Force bits that might keep the dflags and stringBuffer alive unnecessarily
145+ liftIO $ evaluate $ rnf opts
146+
67 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
147 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
68 return dflags
148 return dflags
69
149
@@ -95,11 +175,12 @@ runLhs dflags filename contents = withTempDir $ \dir -> do
95 escape (c:cs) = c : escape cs
175 escape (c:cs) = c : escape cs
96 escape [] = []
176 escape [] = []
97
177
98−
99-- | Run CPP on a file
178-- | Run CPP on a file
100runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
179runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
101runCpp dflags filename contents = withTempDir $ \dir -> do
180runCpp dflags filename contents = withTempDir $ \dir -> do
102 let out = dir </> takeFileName filename <.> "out"
181 let out = dir </> takeFileName filename <.> "out"
182+ dflags <- pure $ addOptP "-D__GHCIDE__" dflags
183+
103 case contents of
184 case contents of
104 Nothing -> do
185 Nothing -> do
105 -- Happy case, file is not modified, so run CPP on it in-place
186 -- Happy case, file is not modified, so run CPP on it in-place
@@ -132,3 +213,18 @@ runCpp dflags filename contents = withTempDir $ \dir -> do
132 = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""
213 = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""
133 | otherwise = x
214 | otherwise = x
134 stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
215 stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
216+
217+
218+-- | Run a preprocessor on a file
219+runPreprocessor :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
220+runPreprocessor dflags filename contents = withTempDir $ \dir -> do
221+ let out = dir </> takeFileName filename <.> "out"
222+ inp <- case contents of
223+ Nothing -> return filename
224+ Just contents -> do
225+ let inp = dir </> takeFileName filename <.> "hs"
226+ withBinaryFile inp WriteMode $ \h ->
227+ hPutStringBuffer h contents
228+ return inp
229+ runPp dflags [SysTools.Option filename, SysTools.Option inp, SysTools.FileOption "" out]
230+ SB.hGetStringBuffer out
src/Development/IDE/Core/RuleTypes.hs+51−12
@@ -15,7 +15,6 @@ import Control.DeepSeq
15import Data.Binary
15import Data.Binary
16import Development.IDE.Import.DependencyInformation
16import Development.IDE.Import.DependencyInformation
17import Development.IDE.GHC.Util
17import Development.IDE.GHC.Util
18−import Development.IDE.Types.Location
19import Data.Hashable
18import Data.Hashable
20import Data.Typeable
19import Data.Typeable
21import qualified Data.Set as S
20import qualified Data.Set as S
@@ -25,9 +24,9 @@ import GHC.Generics (Generic)
25import GHC
24import GHC
26import Module (InstalledUnitId)
25import Module (InstalledUnitId)
27import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)
26import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)
28−import Development.IDE.GHC.Compat
29
27
30import Development.IDE.Spans.Type
28import Development.IDE.Spans.Type
29+import Development.IDE.Import.FindImports (ArtifactsLocation)
31
30
32
31
33-- NOTATION
32-- NOTATION
@@ -58,11 +57,27 @@ instance Show TcModuleResult where
58instance NFData TcModuleResult where
57instance NFData TcModuleResult where
59 rnf = rwhnf
58 rnf = rwhnf
60
59
60+tmrModSummary :: TcModuleResult -> ModSummary
61+tmrModSummary = pm_mod_summary . tm_parsed_module . tmrModule
62+
63+data HiFileResult = HiFileResult
64+ { hirModSummary :: !ModSummary
65+ -- Bang patterns here are important to stop the result retaining
66+ -- a reference to a typechecked module
67+ , hirModIface :: !ModIface
68+ }
69+
70+instance NFData HiFileResult where
71+ rnf = rwhnf
72+
73+instance Show HiFileResult where
74+ show = show . hirModSummary
75+
61-- | The type checked version of this file, requires TypeCheck+
76-- | The type checked version of this file, requires TypeCheck+
62type instance RuleResult TypeCheck = TcModuleResult
77type instance RuleResult TypeCheck = TcModuleResult
63
78
64-- | Information about what spans occur where, requires TypeCheck
79-- | Information about what spans occur where, requires TypeCheck
65−type instance RuleResult GetSpanInfo = [SpanInfo]
80+type instance RuleResult GetSpanInfo = SpansInfo
66
81
67-- | Convert to Core, requires TypeCheck*
82-- | Convert to Core, requires TypeCheck*
68type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)
83type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)
@@ -75,16 +90,24 @@ type instance RuleResult GhcSession = HscEnvEq
75
90
76-- | Resolve the imports in a module to the file path of a module
91-- | Resolve the imports in a module to the file path of a module
77-- in the same package or the package id of another package.
92-- in the same package or the package id of another package.
78−type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe NormalizedFilePath)], S.Set InstalledUnitId)
93+type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId)
79
94
80-- | This rule is used to report import cycles. It depends on GetDependencyInformation.
95-- | This rule is used to report import cycles. It depends on GetDependencyInformation.
81-- We cannot report the cycles directly from GetDependencyInformation since
96-- We cannot report the cycles directly from GetDependencyInformation since
82-- we can only report diagnostics for the current file.
97-- we can only report diagnostics for the current file.
83type instance RuleResult ReportImportCycles = ()
98type instance RuleResult ReportImportCycles = ()
84
99
85−-- | Read the given HIE file.
100+-- | Read the module interface file
86−type instance RuleResult GetHieFile = HieFile
101+type instance RuleResult GetHiFile = HiFileResult
102+
103+-- | Get a module interface, either from an interface file or a typechecked module
104+type instance RuleResult GetModIface = HiFileResult
87
105
106+type instance RuleResult IsFileOfInterest = Bool
107+
108+-- | Generate a ModSummary that has enough information to be used to get .hi and .hie files.
109+-- without needing to parse the entire source
110+type instance RuleResult GetModSummary = ModSummary
88
111
89data GetParsedModule = GetParsedModule
112data GetParsedModule = GetParsedModule
90 deriving (Eq, Show, Typeable, Generic)
113 deriving (Eq, Show, Typeable, Generic)
@@ -146,10 +169,26 @@ instance Hashable GhcSession
146instance NFData GhcSession
169instance NFData GhcSession
147instance Binary GhcSession
170instance Binary GhcSession
148
171
149−-- Note that we embed the filepath here instead of using the filepath associated with Shake keys.
172+data GetHiFile = GetHiFile
150−-- Otherwise we will garbage collect the result since files in package dependencies will not be declared reachable.
173+ deriving (Eq, Show, Typeable, Generic)
151−data GetHieFile = GetHieFile FilePath
174+instance Hashable GetHiFile
175+instance NFData GetHiFile
176+instance Binary GetHiFile
177+
178+data GetModIface = GetModIface
179+ deriving (Eq, Show, Typeable, Generic)
180+instance Hashable GetModIface
181+instance NFData GetModIface
182+instance Binary GetModIface
183+
184+data IsFileOfInterest = IsFileOfInterest
185+ deriving (Eq, Show, Typeable, Generic)
186+instance Hashable IsFileOfInterest
187+instance NFData IsFileOfInterest
188+instance Binary IsFileOfInterest
189+
190+data GetModSummary = GetModSummary
152 deriving (Eq, Show, Typeable, Generic)
191 deriving (Eq, Show, Typeable, Generic)
153−instance Hashable GetHieFile
192+instance Hashable GetModSummary
154−instance NFData GetHieFile
193+instance NFData GetModSummary
155−instance Binary GetHieFile
194+instance Binary GetModSummary
src/Development/IDE/Core/Rules.hs+426−123
@@ -1,16 +1,18 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4+{-# LANGUAGE CPP #-}
4−{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeFamilies #-}
5−{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE DuplicateRecordFields #-}
7{-# LANGUAGE DuplicateRecordFields #-}
8+#include "ghc-api-version.h"
7
9
8-- | A Shake implementation of the compiler service, built
10-- | A Shake implementation of the compiler service, built
9-- using the "Shaker" abstraction layer for in-memory use.
11-- using the "Shaker" abstraction layer for in-memory use.
10--
12--
11module Development.IDE.Core.Rules(
13module Development.IDE.Core.Rules(
12 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
14 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
13− Priority(..),
15+ Priority(..), GhcSessionIO(..), GhcSessionFun(..),
14 priorityTypeCheck,
16 priorityTypeCheck,
15 priorityGenerateCore,
17 priorityGenerateCore,
16 priorityFilesOfInterest,
18 priorityFilesOfInterest,
@@ -21,51 +23,59 @@ module Development.IDE.Core.Rules(
21 getDefinition,
23 getDefinition,
22 getDependencies,
24 getDependencies,
23 getParsedModule,
25 getParsedModule,
24− fileFromParsedModule,
25 generateCore,
26 generateCore,
26 ) where
27 ) where
27
28
28import Fingerprint
29import Fingerprint
29
30
30−import Data.Binary
31+import Data.Binary hiding (get, put)
32+import Data.Bifunctor (first, second)
31−import Control.Monad
33+import Control.Monad.Extra
32import Control.Monad.Trans.Class
34import Control.Monad.Trans.Class
33import Control.Monad.Trans.Maybe
35import Control.Monad.Trans.Maybe
34import Development.IDE.Core.Compile
36import Development.IDE.Core.Compile
37+import Development.IDE.Core.OfInterest
35import Development.IDE.Types.Options
38import Development.IDE.Types.Options
36import Development.IDE.Spans.Calculate
39import Development.IDE.Spans.Calculate
37import Development.IDE.Import.DependencyInformation
40import Development.IDE.Import.DependencyInformation
38import Development.IDE.Import.FindImports
41import Development.IDE.Import.FindImports
39−import Development.IDE.Core.FileStore
42+import Development.IDE.Core.FileExists
43+import Development.IDE.Core.FileStore (getFileContents)
40import Development.IDE.Types.Diagnostics
44import Development.IDE.Types.Diagnostics
41import Development.IDE.Types.Location
45import Development.IDE.Types.Location
46+import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)
42import Development.IDE.GHC.Util
47import Development.IDE.GHC.Util
43−import Data.Coerce
48+import Development.IDE.GHC.WithDynFlags
44import Data.Either.Extra
49import Data.Either.Extra
45import Data.Maybe
50import Data.Maybe
46import Data.Foldable
51import Data.Foldable
47import qualified Data.IntMap.Strict as IntMap
52import qualified Data.IntMap.Strict as IntMap
48−import qualified Data.IntSet as IntSet
53+import Data.IntMap.Strict (IntMap)
49import Data.List
54import Data.List
55+import Data.Ord
50import qualified Data.Set as Set
56import qualified Data.Set as Set
51import qualified Data.Text as T
57import qualified Data.Text as T
52import Development.IDE.GHC.Error
58import Development.IDE.GHC.Error
53import Development.Shake hiding (Diagnostic)
59import Development.Shake hiding (Diagnostic)
54import Development.IDE.Core.RuleTypes
60import Development.IDE.Core.RuleTypes
61+import Development.IDE.Spans.Type
62+import qualified Data.ByteString.Char8 as BS
55
63
56−import GHC hiding (parseModule, typecheckModule)
57import qualified GHC.LanguageExtensions as LangExt
64import qualified GHC.LanguageExtensions as LangExt
58−import Development.IDE.GHC.Compat
59−import UniqSupply
60−import NameCache
61import HscTypes
65import HscTypes
66+import PackageConfig
62−import DynFlags (xopt)
67+import DynFlags (gopt_set, xopt)
63import GHC.Generics(Generic)
68import GHC.Generics(Generic)
64
69
65import qualified Development.IDE.Spans.AtPoint as AtPoint
70import qualified Development.IDE.Spans.AtPoint as AtPoint
66import Development.IDE.Core.Service
71import Development.IDE.Core.Service
67import Development.IDE.Core.Shake
72import Development.IDE.Core.Shake
68−import Development.Shake.Classes
73+import Development.Shake.Classes hiding (get, put)
74+import Control.Monad.Trans.Except (runExceptT)
75+import Data.ByteString (ByteString)
76+import Control.Concurrent.Async (concurrently)
77+
78+import Control.Monad.State
69
79
70-- | This is useful for rules to convert rules that can only produce errors or
80-- | This is useful for rules to convert rules that can only produce errors or
71-- a result into the more general IdeResult type that supports producing
81-- a result into the more general IdeResult type that supports producing
@@ -79,14 +89,14 @@ useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v
79useE k = MaybeT . use k
89useE k = MaybeT . use k
80
90
81useNoFileE :: IdeRule k v => k -> MaybeT Action v
91useNoFileE :: IdeRule k v => k -> MaybeT Action v
82−useNoFileE k = useE k ""
92+useNoFileE k = useE k emptyFilePath
83
93
84usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
94usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
85usesE k = MaybeT . fmap sequence . uses k
95usesE k = MaybeT . fmap sequence . uses k
86
96
87defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
97defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
88defineNoFile f = define $ \k file -> do
98defineNoFile f = define $ \k file -> do
89− if file == "" then do res <- f k; return ([], Just res) else
99+ if file == emptyFilePath then do res <- f k; return ([], Just res) else
90 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
100 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
91
101
92
102
@@ -102,19 +112,66 @@ getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file
102getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text]))
112getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text]))
103getAtPoint file pos = fmap join $ runMaybeT $ do
113getAtPoint file pos = fmap join $ runMaybeT $ do
104 opts <- lift getIdeOptions
114 opts <- lift getIdeOptions
105− files <- transitiveModuleDeps <$> useE GetDependencies file
106− tms <- usesE TypeCheck (file : files)
107 spans <- useE GetSpanInfo file
115 spans <- useE GetSpanInfo file
108− return $ AtPoint.atPoint opts (map tmrModule tms) spans pos
116+ return $ AtPoint.atPoint opts spans pos
109
117
110-- | Goto Definition.
118-- | Goto Definition.
111getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
119getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
112getDefinition file pos = fmap join $ runMaybeT $ do
120getDefinition file pos = fmap join $ runMaybeT $ do
113− spans <- useE GetSpanInfo file
114− pkgState <- hscEnv <$> useE GhcSession file
115 opts <- lift getIdeOptions
121 opts <- lift getIdeOptions
116− let getHieFile x = useNoFile (GetHieFile x)
122+ spans <- useE GetSpanInfo file
117− lift $ AtPoint.gotoDefinition getHieFile opts pkgState spans pos
123+ lift $ AtPoint.gotoDefinition (getHieFile file) opts (spansExprs spans) pos
124+
125+getHieFile
126+ :: NormalizedFilePath -- ^ file we're editing
127+ -> Module -- ^ module dep we want info for
128+ -> Action (Maybe (HieFile, FilePath)) -- ^ hie stuff for the module
129+getHieFile file mod = do
130+ TransitiveDependencies {transitiveNamedModuleDeps} <- use_ GetDependencies file
131+ case find (\x -> nmdModuleName x == moduleName mod) transitiveNamedModuleDeps of
132+ Just NamedModuleDep{nmdFilePath=nfp} -> do
133+ let modPath = fromNormalizedFilePath nfp
134+ (_diags, hieFile) <- getHomeHieFile nfp
135+ return $ (, modPath) <$> hieFile
136+ _ -> getPackageHieFile mod file
137+
138+
139+getHomeHieFile :: NormalizedFilePath -> Action ([a], Maybe HieFile)
140+getHomeHieFile f = do
141+ ms <- use_ GetModSummary f
142+ let normal_hie_f = toNormalizedFilePath' hie_f
143+ hie_f = ml_hie_file $ ms_location ms
144+ mbHieTimestamp <- use GetModificationTime normal_hie_f
145+ srcTimestamp <- use_ GetModificationTime f
146+ let isUpToDate
147+ | Just d <- mbHieTimestamp = comparing modificationTime d srcTimestamp == GT
148+ | otherwise = False
149+
150+ unless isUpToDate $
151+ void $ use_ TypeCheck f
152+
153+ hf <- liftIO $ whenMaybe isUpToDate (loadHieFile hie_f)
154+ return ([], hf)
155+
156+getPackageHieFile :: Module -- ^ Package Module to load .hie file for
157+ -> NormalizedFilePath -- ^ Path of home module importing the package module
158+ -> Action (Maybe (HieFile, FilePath))
159+getPackageHieFile mod file = do
160+ pkgState <- hscEnv <$> use_ GhcSession file
161+ IdeOptions {..} <- getIdeOptions
162+ let unitId = moduleUnitId mod
163+ case lookupPackageConfig unitId pkgState of
164+ Just pkgConfig -> do
165+ -- 'optLocateHieFile' returns Nothing if the file does not exist
166+ hieFile <- liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod
167+ path <- liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod
168+ case (hieFile, path) of
169+ (Just hiePath, Just modPath) ->
170+ -- deliberately loaded outside the Shake graph
171+ -- to avoid dependencies on non-workspace files
172+ liftIO $ Just . (, modPath) <$> loadHieFile hiePath
173+ _ -> return Nothing
174+ _ -> return Nothing
118
175
119-- | Parse the contents of a daml file.
176-- | Parse the contents of a daml file.
120getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
177getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
@@ -134,26 +191,60 @@ priorityFilesOfInterest :: Priority
134priorityFilesOfInterest = Priority (-2)
191priorityFilesOfInterest = Priority (-2)
135
192
136getParsedModuleRule :: Rules ()
193getParsedModuleRule :: Rules ()
137−getParsedModuleRule =
138− defineEarlyCutoff $ \GetParsedModule file -> do
194+getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
139− (_, contents) <- getFileContents file
140− packageState <- hscEnv <$> use_ GhcSession file
195+ sess <- use_ GhcSession file
196+ let hsc = hscEnv sess
197+ -- These packages are used when removing PackageImports from a
198+ -- parsed module
199+ comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)
141− opt <- getIdeOptions
200+ opt <- getIdeOptions
201+ (_, contents) <- getFileContents file
202+
203+ let dflags = hsc_dflags hsc
204+ mainParse = getParsedModuleDefinition hsc opt comp_pkgs file contents
205+
206+ -- Parse again (if necessary) to capture Haddock parse errors
207+ if gopt Opt_Haddock dflags
208+ then
209+ liftIO mainParse
210+ else do
211+ let hscHaddock = hsc{hsc_dflags = gopt_set dflags Opt_Haddock}
212+ haddockParse = do
213+ (_, (!diagsHaddock, _)) <-
214+ getParsedModuleDefinition hscHaddock opt comp_pkgs file contents
215+ return diagsHaddock
216+
217+ ((fingerPrint, (diags, res)), diagsHaddock) <-
218+ -- parse twice, with and without Haddocks, concurrently
219+ -- we cannot ignore Haddock parse errors because files of
220+ -- non-interest are always parsed with Haddocks
221+ liftIO $ concurrently mainParse haddockParse
222+
223+ return (fingerPrint, (mergeDiagnostics diags diagsHaddock, res))
224+
225+getParsedModuleDefinition :: HscEnv -> IdeOptions -> [PackageName] -> NormalizedFilePath -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))
226+getParsedModuleDefinition packageState opt comp_pkgs file contents = do
142− r <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents
227+ (diag, res) <- parseModule opt packageState comp_pkgs (fromNormalizedFilePath file) (fmap textToStringBuffer contents)
143− mbFingerprint <- traverse (const $ getSourceFingerprint file) (optShakeFiles opt)
228+ case res of
229+ Nothing -> pure (Nothing, (diag, Nothing))
230+ Just (contents, modu) -> do
231+ mbFingerprint <- if isNothing $ optShakeFiles opt
232+ then pure Nothing
233+ else Just . fingerprintToBS <$> fingerprintFromStringBuffer contents
144− pure (fingerprintToBS <$> mbFingerprint, r)
234+ pure (mbFingerprint, (diag, Just modu))
145
235
146getLocatedImportsRule :: Rules ()
236getLocatedImportsRule :: Rules ()
147getLocatedImportsRule =
237getLocatedImportsRule =
148 define $ \GetLocatedImports file -> do
238 define $ \GetLocatedImports file -> do
149− pm <- use_ GetParsedModule file
239+ ms <- use_ GetModSummary file
150− let ms = pm_mod_summary pm
151 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
240 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
152− env <- hscEnv <$> use_ GhcSession file
241+ env_eq <- use_ GhcSession file
242+ let env = hscEnv env_eq
243+ let import_dirs = deps env_eq
153− let dflags = addRelativeImport file pm $ hsc_dflags env
244+ let dflags = addRelativeImport file (moduleName $ ms_mod ms) $ hsc_dflags env
154 opt <- getIdeOptions
245 opt <- getIdeOptions
155 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
246 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
156− diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource
247+ diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getFileExists modName mbPkgName isSource
157 case diagOrImp of
248 case diagOrImp of
158 Left diags -> pure (diags, Left (modName, Nothing))
249 Left diags -> pure (diags, Left (modName, Nothing))
159 Right (FileImport path) -> pure ([], Left (modName, Just path))
250 Right (FileImport path) -> pure ([], Left (modName, Just path))
@@ -167,48 +258,109 @@ getLocatedImportsRule =
167 Nothing -> pure (concat diags, Nothing)
258 Nothing -> pure (concat diags, Nothing)
168 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))
259 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))
169
260
261+type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a
262+
263+execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1)
264+execRawDepM act =
265+ execStateT act
266+ ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty
267+ , IntMap.empty
268+ )
170
269
171-- | Given a target file path, construct the raw dependency results by following
270-- | Given a target file path, construct the raw dependency results by following
172-- imports recursively.
271-- imports recursively.
173−rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation
272+rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation
174−rawDependencyInformation f = do
273+rawDependencyInformation fs = do
175− let (initialId, initialMap) = getPathId f emptyPathIdMap
274+ (rdi, ss) <- execRawDepM (mapM_ go fs)
176− go (IntSet.singleton $ getFilePathId initialId)
275+ let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss
177− (RawDependencyInformation IntMap.empty initialMap)
276+ return (rdi { rawBootMap = bm })
178 where
277 where
179− go fs rawDepInfo =
278+ go :: NormalizedFilePath -- ^ Current module being processed
180− case IntSet.minView fs of
279+ -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId
181− -- Queue is empty
280+ go f = do
182− Nothing -> pure rawDepInfo
281+ -- First check to see if we have already processed the FilePath
183− -- Pop f from the queue and process it
282+ -- If we have, just return its Id but don't update any of the state.
184− Just (f, fs) -> do
283+ -- Otherwise, we need to process its imports.
185− let fId = FilePathId f
284+ checkAlreadyProcessed f $ do
285+ al <- lift $ modSummaryToArtifactsLocation f <$> use_ GetModSummary f
286+ -- Get a fresh FilePathId for the new file
287+ fId <- getFreshFid al
288+ -- Adding an edge to the bootmap so we can make sure to
289+ -- insert boot nodes before the real files.
290+ addBootMap al fId
291+ -- Try to parse the imports of the file
186− importsOrErr <- use GetLocatedImports $ idToPath (rawPathIdMap rawDepInfo) fId
292+ importsOrErr <- lift $ use GetLocatedImports f
187− case importsOrErr of
293+ case importsOrErr of
188− Nothing ->
294+ Nothing -> do
189− -- File doesn’t parse
295+ -- File doesn't parse so add the module as a failure into the
296+ -- dependency information, continue processing the other
297+ -- elements in the queue
190− let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo
298+ modifyRawDepInfo (insertImport fId (Left ModuleParseError))
191− in go fs rawDepInfo'
299+ return fId
192− Just (modImports, pkgImports) -> do
300+ Just (modImports, pkgImports) -> do
193− let f :: PathIdMap -> (a, Maybe NormalizedFilePath) -> (PathIdMap, (a, Maybe FilePathId))
301+ -- Get NFPs of the imports which have corresponding files
194− f pathMap (imp, mbPath) = case mbPath of
302+ -- Imports either come locally from a file or from a package.
195− Nothing -> (pathMap, (imp, Nothing))
303+ let (no_file, with_file) = splitImports modImports
196− Just path ->
304+ (mns, ls) = unzip with_file
197− let (pathId, pathMap') = getPathId path pathMap
305+ -- Recursively process all the imports we just learnt about
198− in (pathMap', (imp, Just pathId))
306+ -- and get back a list of their FilePathIds
199− -- Convert paths in imports to ids and update the path map
307+ fids <- mapM (go . artifactFilePath) ls
200− let (pathIdMap, modImports') = mapAccumL f (rawPathIdMap rawDepInfo) modImports
308+ -- Associate together the ModuleName with the FilePathId
201− -- Files that we haven’t seen before are added to the queue.
309+ let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids)
202− let newFiles =
310+ -- Insert into the map the information about this modules
203− IntSet.fromList (coerce $ mapMaybe snd modImports')
311+ -- imports.
204− IntSet.\\ IntMap.keysSet (rawImports rawDepInfo)
205− let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo
312+ modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports' pkgImports)
206− go (newFiles `IntSet.union` fs) (rawDepInfo' { rawPathIdMap = pathIdMap })
313+ return fId
314+
315+
316+ checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId
317+ checkAlreadyProcessed nfp k = do
318+ (rawDepInfo, _) <- get
319+ maybe k return (lookupPathToId (rawPathIdMap rawDepInfo) nfp)
320+
321+ modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation) -> RawDepM ()
322+ modifyRawDepInfo f = modify (first f)
323+
324+ addBootMap :: ArtifactsLocation -> FilePathId -> RawDepM ()
325+ addBootMap al fId =
326+ modify (\(rd, ss) -> (rd, if isBootLocation al
327+ then IntMap.insert (getFilePathId fId) al ss
328+ else ss))
329+
330+ getFreshFid :: ArtifactsLocation -> RawDepM FilePathId
331+ getFreshFid al = do
332+ (rawDepInfo, ss) <- get
333+ let (fId, path_map) = getPathId al (rawPathIdMap rawDepInfo)
334+ -- Insert the File into the bootmap if it's a boot module
335+ let rawDepInfo' = rawDepInfo { rawPathIdMap = path_map }
336+ put (rawDepInfo', ss)
337+ return fId
338+
339+ -- Split in (package imports, local imports)
340+ splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)]
341+ -> ([Located ModuleName], [(Located ModuleName, ArtifactsLocation)])
342+ splitImports = foldr splitImportsLoop ([],[])
343+
344+ splitImportsLoop (imp, Nothing) (ns, ls) = (imp:ns, ls)
345+ splitImportsLoop (imp, Just artifact) (ns, ls) = (ns, (imp,artifact) : ls)
346+
347+ updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =
348+ if not artifactIsSource
349+ then
350+ let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix artifactModLocation)
351+ in case msource_mod_id of
352+ Just source_mod_id -> insertBootId source_mod_id (FilePathId boot_mod_id) bm
353+ Nothing -> bm
354+ else bm
355+
356+ dropBootSuffix :: ModLocation -> FilePath
357+ dropBootSuffix (ModLocation (Just hs_src) _ _) = reverse . drop (length @[] "-boot") . reverse $ hs_src
358+ dropBootSuffix _ = error "dropBootSuffix"
207
359
208getDependencyInformationRule :: Rules ()
360getDependencyInformationRule :: Rules ()
209getDependencyInformationRule =
361getDependencyInformationRule =
210 define $ \GetDependencyInformation file -> do
362 define $ \GetDependencyInformation file -> do
211− rawDepInfo <- rawDependencyInformation file
363+ rawDepInfo <- rawDependencyInformation [file]
212 pure ([], Just $ processDependencyInformation rawDepInfo)
364 pure ([], Just $ processDependencyInformation rawDepInfo)
213
365
214reportImportCyclesRule :: Rules ()
366reportImportCyclesRule :: Rules ()
@@ -229,19 +381,20 @@ reportImportCyclesRule =
229 where cycleErrorInFile f (PartOfCycle imp fs)
381 where cycleErrorInFile f (PartOfCycle imp fs)
230 | f `elem` fs = Just (imp, fs)
382 | f `elem` fs = Just (imp, fs)
231 cycleErrorInFile _ _ = Nothing
383 cycleErrorInFile _ _ = Nothing
232− toDiag imp mods = (fp ,) $ Diagnostic
384+ toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic
233 { _range = (_range :: Location -> Range) loc
385 { _range = (_range :: Location -> Range) loc
234 , _severity = Just DsError
386 , _severity = Just DsError
235 , _source = Just "Import cycle detection"
387 , _source = Just "Import cycle detection"
236 , _message = "Cyclic module dependency between " <> showCycle mods
388 , _message = "Cyclic module dependency between " <> showCycle mods
237 , _code = Nothing
389 , _code = Nothing
238 , _relatedInformation = Nothing
390 , _relatedInformation = Nothing
391+ , _tags = Nothing
239 }
392 }
240 where loc = srcSpanToLocation (getLoc imp)
393 where loc = srcSpanToLocation (getLoc imp)
241− fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)
394+ fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp)
242 getModuleName file = do
395 getModuleName file = do
243− pm <- use_ GetParsedModule file
396+ ms <- use_ GetModSummary file
244− pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)
397+ pure (moduleNameString . moduleName . ms_mod $ ms)
245 showCycle mods = T.intercalate ", " (map T.pack mods)
398 showCycle mods = T.intercalate ", " (map T.pack mods)
246
399
247-- returns all transitive dependencies in topological order.
400-- returns all transitive dependencies in topological order.
@@ -249,7 +402,7 @@ reportImportCyclesRule =
249getDependenciesRule :: Rules ()
402getDependenciesRule :: Rules ()
250getDependenciesRule =
403getDependenciesRule =
251 defineEarlyCutoff $ \GetDependencies file -> do
404 defineEarlyCutoff $ \GetDependencies file -> do
252− depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file
405+ depInfo <- use_ GetDependencyInformation file
253 let allFiles = reachableModules depInfo
406 let allFiles = reachableModules depInfo
254 _ <- uses_ ReportImportCycles allFiles
407 _ <- uses_ ReportImportCycles allFiles
255 opts <- getIdeOptions
408 opts <- getIdeOptions
@@ -261,48 +414,101 @@ getSpanInfoRule :: Rules ()
261getSpanInfoRule =
414getSpanInfoRule =
262 define $ \GetSpanInfo file -> do
415 define $ \GetSpanInfo file -> do
263 tc <- use_ TypeCheck file
416 tc <- use_ TypeCheck file
264− (fileImports, _) <- use_ GetLocatedImports file
265 packageState <- hscEnv <$> use_ GhcSession file
417 packageState <- hscEnv <$> use_ GhcSession file
418+ deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
419+ let tdeps = transitiveModuleDeps deps
420+
421+-- When possible, rely on the haddocks embedded in our interface files
422+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'
423+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
424+ let parsedDeps = []
425+#else
426+ parsedDeps <- uses_ GetParsedModule tdeps
427+#endif
428+
429+ ifaces <- uses_ GetModIface tdeps
430+ (fileImports, _) <- use_ GetLocatedImports file
431+ let imports = second (fmap artifactFilePath) <$> fileImports
266− x <- liftIO $ getSrcSpanInfos packageState fileImports tc
432+ x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps (map hirModIface ifaces)
267 return ([], Just x)
433 return ([], Just x)
268
434
269-- Typechecks a module.
435-- Typechecks a module.
270typeCheckRule :: Rules ()
436typeCheckRule :: Rules ()
271−typeCheckRule =
272− define $ \TypeCheck file -> do
437+typeCheckRule = define $ \TypeCheck file -> do
273− pm <- use_ GetParsedModule file
438+ pm <- use_ GetParsedModule file
439+ -- do not generate interface files as this rule is called
440+ -- for files of interest on every keystroke
441+ typeCheckRuleDefinition file pm SkipGenerationOfInterfaceFiles
442+
443+data GenerateInterfaceFiles
444+ = DoGenerateInterfaceFiles
445+ | SkipGenerationOfInterfaceFiles
446+ deriving (Show)
447+
448+-- This is factored out so it can be directly called from the GetModIface
449+-- rule. Directly calling this rule means that on the initial load we can
450+-- garbage collect all the intermediate typechecked modules rather than
451+-- retain the information forever in the shake graph.
452+typeCheckRuleDefinition
453+ :: NormalizedFilePath -- ^ Path to source file
454+ -> ParsedModule
455+ -> GenerateInterfaceFiles -- ^ Should generate .hi and .hie files ?
456+ -> Action (IdeResult TcModuleResult)
457+typeCheckRuleDefinition file pm generateArtifacts = do
274− deps <- use_ GetDependencies file
458+ deps <- use_ GetDependencies file
275− packageState <- hscEnv <$> use_ GhcSession file
459+ hsc <- hscEnv <$> use_ GhcSession file
276− -- Figure out whether we need TemplateHaskell or QuasiQuotes support
460+ -- Figure out whether we need TemplateHaskell or QuasiQuotes support
277− let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph packageState
461+ let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc
278− file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)
462+ file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)
279− any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq
463+ any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq
464+ mirs <- uses_ GetModIface (transitiveModuleDeps deps)
280− tms <- if any_uses_th_qq
465+ bytecodes <- if any_uses_th_qq
281− -- If we use TH or QQ, we must obtain the bytecode
466+ then -- If we use TH or QQ, we must obtain the bytecode
282− then do
283− bytecodes <- uses_ GenerateByteCode (transitiveModuleDeps deps)
467+ fmap Just <$> uses_ GenerateByteCode (transitiveModuleDeps deps)
284− tmrs <- uses_ TypeCheck (transitiveModuleDeps deps)
468+ else
285− pure (zipWith addByteCode bytecodes tmrs)
469+ pure $ repeat Nothing
286− else uses_ TypeCheck (transitiveModuleDeps deps)
470+
287− setPriority priorityTypeCheck
471+ setPriority priorityTypeCheck
288− IdeOptions{ optDefer = defer} <- getIdeOptions
472+ IdeOptions { optDefer = defer } <- getIdeOptions
473+
474+ addUsageDependencies $ liftIO $ do
289− liftIO $ typecheckModule defer packageState tms pm
475+ res <- typecheckModule defer hsc (zipWith unpack mirs bytecodes) pm
476+ case res of
477+ (diags, Just (hsc,tcm)) | DoGenerateInterfaceFiles <- generateArtifacts -> do
478+ diagsHie <- generateAndWriteHieFile hsc (tmrModule tcm)
479+ diagsHi <- generateAndWriteHiFile hsc tcm
480+ return (diags <> diagsHi <> diagsHie, Just tcm)
481+ (diags, res) ->
482+ return (diags, snd <$> res)
290− where
483+ where
484+ unpack HiFileResult{..} bc = (hirModSummary, (hirModIface, bc))
485+ uses_th_qq dflags =
291− uses_th_qq dflags = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
486+ xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
487+
292− addByteCode :: Linkable -> TcModuleResult -> TcModuleResult
488+ addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)
293− addByteCode lm tmr = tmr { tmrModInfo = (tmrModInfo tmr) { hm_linkable = Just lm } }
489+ addUsageDependencies a = do
294−
490+ r@(_, mtc) <- a
491+ forM_ mtc $ \tc -> do
492+ let used_files = mapMaybe udep (mi_usages (hm_iface (tmrModInfo tc)))
493+ udep (UsageFile fp _h) = Just fp
494+ udep _ = Nothing
495+ -- Add a dependency on these files which are added by things like
496+ -- qAddDependentFile
497+ void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files)
498+ return r
499+
500+
295−generateCore :: NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
501+generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
296−generateCore file = do
502+generateCore runSimplifier file = do
297 deps <- use_ GetDependencies file
503 deps <- use_ GetDependencies file
298 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
504 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
299 setPriority priorityGenerateCore
505 setPriority priorityGenerateCore
300 packageState <- hscEnv <$> use_ GhcSession file
506 packageState <- hscEnv <$> use_ GhcSession file
301− liftIO $ compileModule packageState tms tm
507+ liftIO $ compileModule runSimplifier packageState [(tmrModSummary x, tmrModInfo x) | x <- tms] tm
302
508
303generateCoreRule :: Rules ()
509generateCoreRule :: Rules ()
304generateCoreRule =
510generateCoreRule =
305− define $ \GenerateCore -> generateCore
511+ define $ \GenerateCore -> generateCore (RunSimplifier True)
306
512
307generateByteCodeRule :: Rules ()
513generateByteCodeRule :: Rules ()
308generateByteCodeRule =
514generateByteCodeRule =
@@ -311,7 +517,7 @@ generateByteCodeRule =
311 (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)
517 (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)
312 session <- hscEnv <$> use_ GhcSession file
518 session <- hscEnv <$> use_ GhcSession file
313 (_, guts, _) <- use_ GenerateCore file
519 (_, guts, _) <- use_ GenerateCore file
314− liftIO $ generateByteCode session tms tm guts
520+ liftIO $ generateByteCode session [(tmrModSummary x, tmrModInfo x) | x <- tms] tm guts
315
521
316-- A local rule type to get caching. We want to use newCache, but it has
522-- A local rule type to get caching. We want to use newCache, but it has
317-- thread killed exception issues, so we lift it to a full rule.
523-- thread killed exception issues, so we lift it to a full rule.
@@ -323,7 +529,7 @@ instance Hashable GhcSessionIO
323instance NFData GhcSessionIO
529instance NFData GhcSessionIO
324instance Binary GhcSessionIO
530instance Binary GhcSessionIO
325
531
326−newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq)
532+newtype GhcSessionFun = GhcSessionFun (FilePath -> Action (IdeResult HscEnvEq))
327instance Show GhcSessionFun where show _ = "GhcSessionFun"
533instance Show GhcSessionFun where show _ = "GhcSessionFun"
328instance NFData GhcSessionFun where rnf !_ = ()
534instance NFData GhcSessionFun where rnf !_ = ()
329
535
@@ -332,20 +538,119 @@ loadGhcSession :: Rules ()
332loadGhcSession = do
538loadGhcSession = do
333 defineNoFile $ \GhcSessionIO -> do
539 defineNoFile $ \GhcSessionIO -> do
334 opts <- getIdeOptions
540 opts <- getIdeOptions
335− liftIO $ GhcSessionFun <$> optGhcSession opts
541+ GhcSessionFun <$> optGhcSession opts
542+ -- This function should always be rerun because it consults a cache to
543+ -- see what HscEnv needs to be used for the file, which can change.
544+ -- However, it should also cut-off early if it's the same HscEnv as
545+ -- last time
336 defineEarlyCutoff $ \GhcSession file -> do
546 defineEarlyCutoff $ \GhcSession file -> do
337 GhcSessionFun fun <- useNoFile_ GhcSessionIO
547 GhcSessionFun fun <- useNoFile_ GhcSessionIO
548+ alwaysRerun
338 val <- fun $ fromNormalizedFilePath file
549 val <- fun $ fromNormalizedFilePath file
339− opts <- getIdeOptions
340− return ("" <$ optShakeFiles opts, ([], Just val))
341
550
551+ -- TODO: What was this doing before?
552+ opts <- getIdeOptions
553+ let cutoffHash =
554+ case optShakeFiles opts of
555+ -- optShakeFiles is only set in the DAML case.
556+ -- https://github.com/digital-asset/ghcide/pull/522#discussion_r428622915
557+ Just {} -> ""
558+ -- Hash the HscEnvEq returned so cutoff if it didn't change
559+ -- from last time
560+ Nothing -> BS.pack (show (hash (snd val)))
561+ return (Just cutoffHash, val)
562+
563+getHiFileRule :: Rules ()
564+getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do
565+ -- get all dependencies interface files, to check for freshness
566+ (deps,_) <- use_ GetLocatedImports f
567+ depHis <- traverse (use GetHiFile) (mapMaybe (fmap artifactFilePath . snd) deps)
568+
569+ ms <- use_ GetModSummary f
570+ let hiFile = toNormalizedFilePath'
571+ $ case ms_hsc_src ms of
572+ HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)
573+ _ -> ml_hi_file $ ms_location ms
574+
575+ case sequence depHis of
576+ Nothing -> pure (Nothing, ([], Nothing))
577+ Just deps -> do
578+ gotHiFile <- getFileExists hiFile
579+ if not gotHiFile
580+ then pure (Nothing, ([], Nothing))
581+ else do
582+ hiVersion <- use_ GetModificationTime hiFile
583+ modVersion <- use_ GetModificationTime f
584+ let sourceModified = modificationTime hiVersion < modificationTime modVersion
585+ if sourceModified
586+ then do
587+ pure (Nothing, ([], Nothing))
588+ else do
589+ session <- hscEnv <$> use_ GhcSession f
590+ r <- liftIO $ loadInterface session ms deps
591+ case r of
592+ Right iface -> do
593+ let result = HiFileResult ms iface
594+ return (Just (fingerprintToBS (getModuleHash iface)), ([], Just result))
595+ Left err -> do
596+ let diag = ideErrorWithSource (Just "interface file loading") (Just DsError) f . T.pack $ err
597+ return (Nothing, (pure diag, Nothing))
598+
599+getModSummaryRule :: Rules ()
600+getModSummaryRule = define $ \GetModSummary f -> do
601+ dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f
602+ (_, mFileContent) <- getFileContents f
603+ modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $
604+ getModSummaryFromImports (fromNormalizedFilePath f) (textToStringBuffer <$> mFileContent)
605+ return $ either (,Nothing) (([], ) . Just) modS
606+
607+getModIfaceRule :: Rules ()
608+getModIfaceRule = define $ \GetModIface f -> do
609+ fileOfInterest <- use_ IsFileOfInterest f
610+ let useHiFile =
611+ -- Never load interface files for files of interest
612+ not fileOfInterest
613+ mbHiFile <- if useHiFile then use GetHiFile f else return Nothing
614+ case mbHiFile of
615+ Just x ->
616+ return ([], Just x)
617+ Nothing
618+ | fileOfInterest -> do
619+ -- For files of interest only, create a Shake dependency on typecheck
620+ tmr <- use TypeCheck f
621+ return ([], extract tmr)
622+ | otherwise -> do
623+ -- the interface file does not exist or is out of date.
624+ -- Invoke typechecking directly to update it without incurring a dependency
625+ -- on the parsed module and the typecheck rules
626+ sess <- use_ GhcSession f
627+ let hsc = hscEnv sess
628+ -- After parsing the module remove all package imports referring to
629+ -- these packages as we have already dealt with what they map to.
630+ comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)
631+ opt <- getIdeOptions
632+ (_, contents) <- getFileContents f
633+ -- Embed --haddocks in the interface file
634+ hsc <- pure hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock}
635+ (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f contents
636+ case mb_pm of
637+ Nothing -> return (diags, Nothing)
638+ Just pm -> do
639+ (diags', tmr) <- typeCheckRuleDefinition f pm DoGenerateInterfaceFiles
640+ -- Bang pattern is important to avoid leaking 'tmr'
641+ let !res = extract tmr
642+ return (diags <> diags', res)
643+ where
644+ extract Nothing = Nothing
645+ extract (Just tmr) =
646+ -- Bang patterns are important to force the inner fields
647+ Just $! HiFileResult (tmrModSummary tmr) (hm_iface $ tmrModInfo tmr)
342
648
343−getHieFileRule :: Rules ()
649+isFileOfInterestRule :: Rules ()
344−getHieFileRule =
650+isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do
345− defineNoFile $ \(GetHieFile f) -> do
651+ filesOfInterest <- getFilesOfInterest
346− u <- liftIO $ mkSplitUniqSupply 'a'
652+ let res = f `elem` filesOfInterest
347− let nameCache = initNameCache u []
653+ return (Just (if res then "1" else ""), ([], Just res))
348− liftIO $ fmap (hie_file_result . fst) $ readHieFile nameCache f
349
654
350-- | A rule that wires per-file rules together
655-- | A rule that wires per-file rules together
351mainRule :: Rules ()
656mainRule :: Rules ()
@@ -360,9 +665,7 @@ mainRule = do
360 generateCoreRule
665 generateCoreRule
361 generateByteCodeRule
666 generateByteCodeRule
362 loadGhcSession
667 loadGhcSession
363− getHieFileRule
668+ getHiFileRule
364−
669+ getModIfaceRule
365−------------------------------------------------------------
670+ isFileOfInterestRule
366−
671+ getModSummaryRule
367−fileFromParsedModule :: ParsedModule -> NormalizedFilePath
368−fileFromParsedModule = toNormalizedFilePath . ms_hspp_file . pm_mod_summary
src/Development/IDE/Core/Service.hs+10−3
@@ -23,13 +23,16 @@ import Control.Concurrent.Async
23import Data.Maybe
23import Data.Maybe
24import Development.IDE.Types.Options (IdeOptions(..))
24import Development.IDE.Types.Options (IdeOptions(..))
25import Control.Monad
25import Control.Monad
26+import Development.IDE.Core.Debouncer
26−import Development.IDE.Core.FileStore
27+import Development.IDE.Core.FileStore (VFSHandle, fileStoreRules)
28+import Development.IDE.Core.FileExists (fileExistsRules)
27import Development.IDE.Core.OfInterest
29import Development.IDE.Core.OfInterest
28import Development.IDE.Types.Logger
30import Development.IDE.Types.Logger
29import Development.Shake
31import Development.Shake
30import Data.Either.Extra
32import Data.Either.Extra
31import qualified Language.Haskell.LSP.Messages as LSP
33import qualified Language.Haskell.LSP.Messages as LSP
32import qualified Language.Haskell.LSP.Types as LSP
34import qualified Language.Haskell.LSP.Types as LSP
35+import qualified Language.Haskell.LSP.Types.Capabilities as LSP
33
36
34import Development.IDE.Core.Shake
37import Development.IDE.Core.Shake
35
38
@@ -42,18 +45,21 @@ instance IsIdeGlobal GlobalIdeOptions
42-- Exposed API
45-- Exposed API
43
46
44-- | Initialise the Compiler Service.
47-- | Initialise the Compiler Service.
48+initialise :: LSP.ClientCapabilities
45−initialise :: Rules ()
49+ -> Rules ()
46 -> IO LSP.LspId
50 -> IO LSP.LspId
47 -> (LSP.FromServerMessage -> IO ())
51 -> (LSP.FromServerMessage -> IO ())
48 -> Logger
52 -> Logger
53+ -> Debouncer LSP.NormalizedUri
49 -> IdeOptions
54 -> IdeOptions
50 -> VFSHandle
55 -> VFSHandle
51 -> IO IdeState
56 -> IO IdeState
52−initialise mainRule getLspId toDiags logger options vfs =
57+initialise caps mainRule getLspId toDiags logger debouncer options vfs =
53 shakeOpen
58 shakeOpen
54 getLspId
59 getLspId
55 toDiags
60 toDiags
56 logger
61 logger
62+ debouncer
57 (optShakeProfiling options)
63 (optShakeProfiling options)
58 (optReportProgress options)
64 (optReportProgress options)
59 shakeOptions
65 shakeOptions
@@ -63,6 +69,7 @@ initialise mainRule getLspId toDiags logger options vfs =
63 addIdeGlobal $ GlobalIdeOptions options
69 addIdeGlobal $ GlobalIdeOptions options
64 fileStoreRules vfs
70 fileStoreRules vfs
65 ofInterestRules
71 ofInterestRules
72+ fileExistsRules getLspId caps vfs
66 mainRule
73 mainRule
67
74
68writeProfile :: IdeState -> FilePath -> IO ()
75writeProfile :: IdeState -> FilePath -> IO ()
src/Development/IDE/Core/Shake.hs+214−152
@@ -19,25 +19,28 @@
19-- always stored as real Haskell values, whereas Shake serialises all 'A' values
19-- always stored as real Haskell values, whereas Shake serialises all 'A' values
20-- between runs. To deserialise a Shake value, we just consult Values.
20-- between runs. To deserialise a Shake value, we just consult Values.
21module Development.IDE.Core.Shake(
21module Development.IDE.Core.Shake(
22− IdeState,
22+ IdeState, shakeExtras,
23+ ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
23 IdeRule, IdeResult, GetModificationTime(..),
24 IdeRule, IdeResult, GetModificationTime(..),
24 shakeOpen, shakeShut,
25 shakeOpen, shakeShut,
25 shakeRun,
26 shakeRun,
26 shakeProfile,
27 shakeProfile,
27 use, useWithStale, useNoFile, uses, usesWithStale,
28 use, useWithStale, useNoFile, uses, usesWithStale,
28 use_, useNoFile_, uses_,
29 use_, useNoFile_, uses_,
29− define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, fingerprintToBS,
30+ define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,
30 getDiagnostics, unsafeClearDiagnostics,
31 getDiagnostics, unsafeClearDiagnostics,
32+ getHiddenDiagnostics,
31− IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
33+ IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,
32 garbageCollect,
34 garbageCollect,
33 setPriority,
35 setPriority,
34 sendEvent,
36 sendEvent,
35 ideLogger,
37 ideLogger,
36 actionLogger,
38 actionLogger,
37− FileVersion(..),
39+ FileVersion(..), modificationTime,
38 Priority(..),
40 Priority(..),
39 updatePositionMapping,
41 updatePositionMapping,
42+ deleteValue,
40− OnDiskRule(..)
43+ OnDiskRule(..),
41 ) where
44 ) where
42
45
43import Development.Shake hiding (ShakeValue, doesFileExist)
46import Development.Shake hiding (ShakeValue, doesFileExist)
@@ -46,30 +49,27 @@ import Development.Shake.Classes
46import Development.Shake.Rule
49import Development.Shake.Rule
47import qualified Data.HashMap.Strict as HMap
50import qualified Data.HashMap.Strict as HMap
48import qualified Data.Map.Strict as Map
51import qualified Data.Map.Strict as Map
49−import qualified Data.Map.Merge.Strict as Map
50import qualified Data.ByteString.Char8 as BS
52import qualified Data.ByteString.Char8 as BS
51−import qualified Data.ByteString.Internal as BS
52import Data.Dynamic
53import Data.Dynamic
53import Data.Maybe
54import Data.Maybe
54import Data.Map.Strict (Map)
55import Data.Map.Strict (Map)
55−import Data.List.Extra
56+import Data.List.Extra (partition, takeEnd)
56import qualified Data.Set as Set
57import qualified Data.Set as Set
57import qualified Data.Text as T
58import qualified Data.Text as T
59+import Data.Traversable (for)
58import Data.Tuple.Extra
60import Data.Tuple.Extra
59import Data.Unique
61import Data.Unique
60import Development.IDE.Core.Debouncer
62import Development.IDE.Core.Debouncer
61import Development.IDE.Core.PositionMapping
63import Development.IDE.Core.PositionMapping
62import Development.IDE.Types.Logger hiding (Priority)
64import Development.IDE.Types.Logger hiding (Priority)
63−import Foreign.Ptr
64−import Foreign.Storable
65−import GHC.Fingerprint
66import Language.Haskell.LSP.Diagnostics
65import Language.Haskell.LSP.Diagnostics
67import qualified Data.SortedList as SL
66import qualified Data.SortedList as SL
68import Development.IDE.Types.Diagnostics
67import Development.IDE.Types.Diagnostics
69import Development.IDE.Types.Location
68import Development.IDE.Types.Location
70import Development.IDE.Types.Options
69import Development.IDE.Types.Options
70+import Control.Concurrent.Async
71import Control.Concurrent.Extra
71import Control.Concurrent.Extra
72−import Control.Exception
72+import Control.Exception.Extra
73import Control.DeepSeq
73import Control.DeepSeq
74import System.Time.Extra
74import System.Time.Extra
75import Data.Typeable
75import Data.Typeable
@@ -93,12 +93,17 @@ data ShakeExtras = ShakeExtras
93 ,globals :: Var (HMap.HashMap TypeRep Dynamic)
93 ,globals :: Var (HMap.HashMap TypeRep Dynamic)
94 ,state :: Var Values
94 ,state :: Var Values
95 ,diagnostics :: Var DiagnosticStore
95 ,diagnostics :: Var DiagnosticStore
96+ ,hiddenDiagnostics :: Var DiagnosticStore
96− ,publishedDiagnostics :: Var (Map NormalizedUri [Diagnostic])
97+ ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])
97 -- ^ This represents the set of diagnostics that we have published.
98 -- ^ This represents the set of diagnostics that we have published.
98 -- Due to debouncing not every change might get published.
99 -- Due to debouncing not every change might get published.
99− ,positionMapping :: Var (Map NormalizedUri (Map TextDocumentVersion PositionMapping))
100+ ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))
100 -- ^ Map from a text document version to a PositionMapping that describes how to map
101 -- ^ Map from a text document version to a PositionMapping that describes how to map
101 -- positions in a version of that document to positions in the latest version
102 -- positions in a version of that document to positions in the latest version
103+ -- First mapping is delta from previous version and second one is an
104+ -- accumlation of all previous mappings.
105+ ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int)
106+ -- ^ How many rules are running for each file
102 }
107 }
103
108
104getShakeExtras :: Action ShakeExtras
109getShakeExtras :: Action ShakeExtras
@@ -111,22 +116,29 @@ getShakeExtrasRules = do
111 Just x <- getShakeExtraRules @ShakeExtras
116 Just x <- getShakeExtraRules @ShakeExtras
112 return x
117 return x
113
118
114−
115−
116class Typeable a => IsIdeGlobal a where
119class Typeable a => IsIdeGlobal a where
117
120
118addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
121addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
119−addIdeGlobal x@(typeOf -> ty) = do
122+addIdeGlobal x = do
123+ extras <- getShakeExtrasRules
124+ liftIO $ addIdeGlobalExtras extras x
125+
126+addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()
120− ShakeExtras{globals} <- getShakeExtrasRules
127+addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =
121 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
128 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
122− Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty
129+ Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty
123 Nothing -> return $! HMap.insert ty (toDyn x) mp
130 Nothing -> return $! HMap.insert ty (toDyn x) mp
124
131
125
132
126getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
133getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
127getIdeGlobalExtras ShakeExtras{globals} = do
134getIdeGlobalExtras ShakeExtras{globals} = do
135+ let typ = typeRep (Proxy :: Proxy a)
128− Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
136+ x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
129− return $ fromDyn x $ error "Serious error, corrupt globals"
137+ case x of
138+ Just x
139+ | Just x <- fromDynamic x -> pure x
140+ | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")"
141+ Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ
130
142
131getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
143getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
132getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
144getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
@@ -149,7 +161,7 @@ instance Eq Key where
149 | otherwise = False
161 | otherwise = False
150
162
151instance Hashable Key where
163instance Hashable Key where
152− hashWithSalt salt (Key key) = hashWithSalt salt key
164+ hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)
153
165
154-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,
166-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,
155-- and a value is in the Maybe. For operations that throw an error you
167-- and a value is in the Maybe. For operations that throw an error you
@@ -159,9 +171,6 @@ instance Hashable Key where
159-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh
171-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh
160-- errors but still failed.
172-- errors but still failed.
161--
173--
162−-- A rule on a file should only return diagnostics for that given file. It should
163−-- not propagate diagnostic errors through multiple phases.
164−type IdeResult v = ([FileDiagnostic], Maybe v)
165
174
166data Value v
175data Value v
167 = Succeeded TextDocumentVersion v
176 = Succeeded TextDocumentVersion v
@@ -196,14 +205,14 @@ valueVersion = \case
196 Failed -> Nothing
205 Failed -> Nothing
197
206
198mappingForVersion
207mappingForVersion
199− :: Map NormalizedUri (Map TextDocumentVersion PositionMapping)
208+ :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
200 -> NormalizedFilePath
209 -> NormalizedFilePath
201 -> TextDocumentVersion
210 -> TextDocumentVersion
202 -> PositionMapping
211 -> PositionMapping
203mappingForVersion allMappings file ver =
212mappingForVersion allMappings file ver =
204− fromMaybe idMapping $
213+ maybe zeroMapping snd $
205 Map.lookup ver =<<
214 Map.lookup ver =<<
206− Map.lookup (filePathToUri' file) allMappings
215+ HMap.lookup (filePathToUri' file) allMappings
207
216
208type IdeRule k v =
217type IdeRule k v =
209 ( Shake.RuleResult k ~ v
218 ( Shake.RuleResult k ~ v
@@ -225,15 +234,15 @@ data IdeState = IdeState
225
234
226
235
227-- This is debugging code that generates a series of profiles, if the Boolean is true
236-- This is debugging code that generates a series of profiles, if the Boolean is true
228−shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO [a]
237+shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO ([a], Maybe FilePath)
229shakeRunDatabaseProfile mbProfileDir shakeDb acts = do
238shakeRunDatabaseProfile mbProfileDir shakeDb acts = do
230 (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts
239 (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts
231− whenJust mbProfileDir $ \dir -> do
240+ proFile <- for mbProfileDir $ \dir -> do
232− count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)
241+ count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)
233− let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"
242+ let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"
234− shakeProfileDatabase shakeDb $ dir </> file
243+ shakeProfileDatabase shakeDb $ dir </> file
244+ return (dir </> file)
235− return res
245+ return (res, proFile)
236− where
237
246
238{-# NOINLINE profileStartTime #-}
247{-# NOINLINE profileStartTime #-}
239profileStartTime :: String
248profileStartTime :: String
@@ -253,6 +262,16 @@ setValues state key file val = modifyVar_ state $ \vals -> do
253 -- Force to make sure the old HashMap is not retained
262 -- Force to make sure the old HashMap is not retained
254 evaluate $ HMap.insert (file, Key key) (fmap toDyn val) vals
263 evaluate $ HMap.insert (file, Key key) (fmap toDyn val) vals
255
264
265+-- | Delete the value stored for a given ide build key
266+deleteValue
267+ :: (Typeable k, Hashable k, Eq k, Show k)
268+ => IdeState
269+ -> k
270+ -> NormalizedFilePath
271+ -> IO ()
272+deleteValue IdeState{shakeExtras = ShakeExtras{state}} key file = modifyVar_ state $ \vals ->
273+ evaluate $ HMap.delete (file, Key key) vals
274+
256-- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.
275-- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.
257getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
276getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
258getValues state key file = do
277getValues state key file = do
@@ -279,33 +298,40 @@ seqValue v b = case v of
279shakeOpen :: IO LSP.LspId
298shakeOpen :: IO LSP.LspId
280 -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
299 -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
281 -> Logger
300 -> Logger
301+ -> Debouncer NormalizedUri
282 -> Maybe FilePath
302 -> Maybe FilePath
283 -> IdeReportProgress
303 -> IdeReportProgress
284 -> ShakeOptions
304 -> ShakeOptions
285 -> Rules ()
305 -> Rules ()
286 -> IO IdeState
306 -> IO IdeState
287−shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do
307+shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) opts rules = do
308+ inProgress <- newVar HMap.empty
288 shakeExtras <- do
309 shakeExtras <- do
289 globals <- newVar HMap.empty
310 globals <- newVar HMap.empty
290 state <- newVar HMap.empty
311 state <- newVar HMap.empty
291 diagnostics <- newVar mempty
312 diagnostics <- newVar mempty
313+ hiddenDiagnostics <- newVar mempty
292 publishedDiagnostics <- newVar mempty
314 publishedDiagnostics <- newVar mempty
293− debouncer <- newDebouncer
294− positionMapping <- newVar Map.empty
315+ positionMapping <- newVar HMap.empty
295 pure ShakeExtras{..}
316 pure ShakeExtras{..}
296 (shakeDb, shakeClose) <-
317 (shakeDb, shakeClose) <-
297 shakeOpenDatabase
318 shakeOpenDatabase
298 opts
319 opts
299 { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts
320 { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts
321+ -- we don't actually use the progress value, but Shake conveniently spawns/kills this thread whenever
322+ -- we call into Shake, so abuse it for that purpose
300− , shakeProgress = if reportProgress then lspShakeProgress getLspId eventer else const (pure ())
323+ , shakeProgress = const $ if reportProgress then lspShakeProgress getLspId eventer inProgress else pure ()
301 }
324 }
302 rules
325 rules
303 shakeAbort <- newMVar $ return ()
326 shakeAbort <- newMVar $ return ()
304 shakeDb <- shakeDb
327 shakeDb <- shakeDb
305 return IdeState{..}
328 return IdeState{..}
306
329
307−lspShakeProgress :: IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> IO Progress -> IO ()
330+lspShakeProgress :: Hashable a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (HMap.HashMap a Int) -> IO ()
308−lspShakeProgress getLspId sendMsg prog = do
331+lspShakeProgress getLspId sendMsg inProgress = do
332+ -- first sleep a bit, so we only show progress messages if it's going to take
333+ -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
334+ sleep 0.1
309 lspId <- getLspId
335 lspId <- getLspId
310 u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique
336 u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique
311 sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest
337 sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest
@@ -333,9 +359,9 @@ lspShakeProgress getLspId sendMsg prog = do
333 sample = 0.1
359 sample = 0.1
334 loop id prev = do
360 loop id prev = do
335 sleep sample
361 sleep sample
336− p <- prog
362+ current <- readVar inProgress
337− let done = countSkipped p + countBuilt p
363+ let done = length $ filter (== 0) $ HMap.elems current
338− let todo = done + countUnknown p + countTodo p
364+ let todo = HMap.size current
339 let next = Just $ T.pack $ show done <> "/" <> show todo
365 let next = Just $ T.pack $ show done <> "/" <> show todo
340 when (next /= prev) $
366 when (next /= prev) $
341 sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification
367 sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification
@@ -361,11 +387,11 @@ shakeShut IdeState{..} = withMVar shakeAbort $ \stop -> do
361
387
362-- | This is a variant of withMVar where the first argument is run unmasked and if it throws
388-- | This is a variant of withMVar where the first argument is run unmasked and if it throws
363-- an exception, the previous value is restored while the second argument is executed masked.
389-- an exception, the previous value is restored while the second argument is executed masked.
364−withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
390+withMVar' :: MVar a -> (a -> IO ()) -> IO (a, c) -> IO c
365withMVar' var unmasked masked = mask $ \restore -> do
391withMVar' var unmasked masked = mask $ \restore -> do
366 a <- takeMVar var
392 a <- takeMVar var
367− b <- restore (unmasked a) `onException` putMVar var a
393+ restore (unmasked a) `onException` putMVar var a
368− (a', c) <- masked b
394+ (a', c) <- masked
369 putMVar var a'
395 putMVar var a'
370 pure c
396 pure c
371
397
@@ -377,29 +403,44 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =
377 (\stop -> do
403 (\stop -> do
378 (stopTime,_) <- duration stop
404 (stopTime,_) <- duration stop
379 logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
405 logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
380− bar <- newBarrier
406+ )
381− start <- offsetTime
382− pure (start, bar))
383 -- It is crucial to be masked here, otherwise we can get killed
407 -- It is crucial to be masked here, otherwise we can get killed
384 -- between spawning the new thread and updating shakeAbort.
408 -- between spawning the new thread and updating shakeAbort.
385 -- See https://github.com/digital-asset/ghcide/issues/79
409 -- See https://github.com/digital-asset/ghcide/issues/79
410+ (do
386− (\(start, bar) -> do
411+ start <- offsetTime
412+ aThread <- asyncWithUnmask $ \restore -> do
387− thread <- forkFinally (shakeRunDatabaseProfile shakeProfileDir shakeDb acts) $ \res -> do
413+ res <- try (restore $ shakeRunDatabaseProfile shakeProfileDir shakeDb acts)
388− runTime <- start
414+ runTime <- start
389− let res' = case res of
415+ let res' = case res of
390− Left e -> "exception: " <> displayException e
416+ Left e -> "exception: " <> displayException e
391− Right _ -> "completed"
417+ Right _ -> "completed"
418+ profile = case res of
419+ Right (_, Just fp) ->
420+ let link = case filePathToUri' $ toNormalizedFilePath' fp of
421+ NormalizedUri _ x -> x
422+ in ", profile saved at " <> T.unpack link
423+ _ -> ""
392− logDebug logger $ T.pack $
424+ let logMsg = logDebug logger $ T.pack $
393− "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ ")"
425+ "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ profile ++ ")"
394− signalBarrier bar res
426+ return (fst <$> res, logMsg)
395− -- important: we send an async exception to the thread, then wait for it to die, before continuing
427+ let wrapUp (res, _) = do
396− pure (killThread thread >> void (waitBarrier bar), either throwIO return =<< waitBarrier bar))
428+ either (throwIO @SomeException) return res
429+ _ <- async $ do
430+ (_, logMsg) <- wait aThread
431+ logMsg
432+ pure (cancel aThread, wrapUp =<< wait aThread))
397
433
398getDiagnostics :: IdeState -> IO [FileDiagnostic]
434getDiagnostics :: IdeState -> IO [FileDiagnostic]
399getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
435getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
400 val <- readVar diagnostics
436 val <- readVar diagnostics
401 return $ getAllDiagnostics val
437 return $ getAllDiagnostics val
402
438
439+getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic]
440+getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do
441+ val <- readVar hiddenDiagnostics
442+ return $ getAllDiagnostics val
443+
403-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
444-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
404unsafeClearDiagnostics :: IdeState -> IO ()
445unsafeClearDiagnostics :: IdeState -> IO ()
405unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
446unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
@@ -408,15 +449,16 @@ unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
408-- | Clear the results for all files that do not match the given predicate.
449-- | Clear the results for all files that do not match the given predicate.
409garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
450garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
410garbageCollect keep = do
451garbageCollect keep = do
411− ShakeExtras{state, diagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras
452+ ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras
412 liftIO $
453 liftIO $
413 do newState <- modifyVar state $ \values -> do
454 do newState <- modifyVar state $ \values -> do
414 values <- evaluate $ HMap.filterWithKey (\(file, _) _ -> keep file) values
455 values <- evaluate $ HMap.filterWithKey (\(file, _) _ -> keep file) values
415 return $! dupe values
456 return $! dupe values
416 modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags
457 modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags
458+ modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags
417− modifyVar_ publishedDiagnostics $ \diags -> return $! Map.filterWithKey (\uri _ -> keep (fromUri uri)) diags
459+ modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags
418 let versionsForFile =
460 let versionsForFile =
419− Map.fromListWith Set.union $
461+ HMap.fromListWith Set.union $
420 mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
462 mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
421 HMap.toList newState
463 HMap.toList newState
422 modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings
464 modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings
@@ -434,25 +476,25 @@ useWithStale :: IdeRule k v
434useWithStale key file = head <$> usesWithStale key [file]
476useWithStale key file = head <$> usesWithStale key [file]
435
477
436useNoFile :: IdeRule k v => k -> Action (Maybe v)
478useNoFile :: IdeRule k v => k -> Action (Maybe v)
437−useNoFile key = use key ""
479+useNoFile key = use key emptyFilePath
438
480
439use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
481use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
440use_ key file = head <$> uses_ key [file]
482use_ key file = head <$> uses_ key [file]
441
483
442useNoFile_ :: IdeRule k v => k -> Action v
484useNoFile_ :: IdeRule k v => k -> Action v
443−useNoFile_ key = use_ key ""
485+useNoFile_ key = use_ key emptyFilePath
444
486
445uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
487uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
446uses_ key files = do
488uses_ key files = do
447 res <- uses key files
489 res <- uses key files
448 case sequence res of
490 case sequence res of
449− Nothing -> liftIO $ throwIO BadDependency
491+ Nothing -> liftIO $ throwIO $ BadDependency (show key)
450 Just v -> return v
492 Just v -> return v
451
493
452
494
453-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
495-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
454-- which short-circuits the rest of the action
496-- which short-circuits the rest of the action
455−data BadDependency = BadDependency deriving Show
497+data BadDependency = BadDependency String deriving Show
456instance Exception BadDependency
498instance Exception BadDependency
457
499
458isBadDependency :: SomeException -> Bool
500isBadDependency :: SomeException -> Bool
@@ -471,12 +513,10 @@ instance Show k => Show (Q k) where
471
513
472-- | Invariant: the 'v' must be in normal form (fully evaluated).
514-- | Invariant: the 'v' must be in normal form (fully evaluated).
473-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database
515-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database
474−-- Note (MK) I am not sure why we need the ShakeValue here, maybe we
475−-- can just remove it?
476−data A v = A (Value v) ShakeValue
516+newtype A v = A (Value v)
477 deriving Show
517 deriving Show
478
518
479−instance NFData (A v) where rnf (A v x) = v `seq` rnf x
519+instance NFData (A v) where rnf (A v) = v `seq` ()
480
520
481-- In the Shake database we only store one type of key/result pairs,
521-- In the Shake database we only store one type of key/result pairs,
482-- namely Q (question) / A (answer).
522-- namely Q (question) / A (answer).
@@ -486,59 +526,70 @@ type instance RuleResult (Q k) = A (RuleResult k)
486-- | Return up2date results. Stale results will be ignored.
526-- | Return up2date results. Stale results will be ignored.
487uses :: IdeRule k v
527uses :: IdeRule k v
488 => k -> [NormalizedFilePath] -> Action [Maybe v]
528 => k -> [NormalizedFilePath] -> Action [Maybe v]
489−uses key files = map (\(A value _) -> currentValue value) <$> apply (map (Q . (key,)) files)
529+uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files)
490
530
491-- | Return the last computed result which might be stale.
531-- | Return the last computed result which might be stale.
492usesWithStale :: IdeRule k v
532usesWithStale :: IdeRule k v
493 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
533 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
494usesWithStale key files = do
534usesWithStale key files = do
495− values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
535+ values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files)
496− mapM (uncurry lastValue) (zip files values)
536+ zipWithM lastValue files values
537+
538+
539+withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b
540+withProgress var file = actionBracket (f succ) (const $ f pred) . const
541+ -- This functions are deliberately eta-expanded to avoid space leaks.
542+ -- Do not remove the eta-expansion without profiling a session with at
543+ -- least 1000 modifications.
544+ where f shift = modifyVar_ var $ \x -> evaluate $ HMap.alter (\x -> Just $! shift (fromMaybe 0 x)) file x
545+
497
546
498defineEarlyCutoff
547defineEarlyCutoff
499 :: IdeRule k v
548 :: IdeRule k v
500 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
549 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
501 -> Rules ()
550 -> Rules ()
502defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do
551defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do
503− extras@ShakeExtras{state} <- getShakeExtras
552+ extras@ShakeExtras{state, inProgress} <- getShakeExtras
553+ -- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key
554+ (if show key == "GetFileExists" then id else withProgress inProgress file) $ do
504− val <- case old of
555+ val <- case old of
505− Just old | mode == RunDependenciesSame -> do
556+ Just old | mode == RunDependenciesSame -> do
506− v <- liftIO $ getValues state key file
557+ v <- liftIO $ getValues state key file
507− case v of
558+ case v of
508− -- No changes in the dependencies and we have
559+ -- No changes in the dependencies and we have
509− -- an existing result.
560+ -- an existing result.
510− Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)
561+ Just v -> return $ Just $ RunResult ChangedNothing old $ A v
511− _ -> return Nothing
562+ _ -> return Nothing
512− _ -> return Nothing
563+ _ -> return Nothing
513− case val of
564+ case val of
514− Just res -> return res
565+ Just res -> return res
515− Nothing -> do
566+ Nothing -> do
516− (bs, (diags, res)) <- actionCatch
567+ (bs, (diags, res)) <- actionCatch
517− (do v <- op key file; liftIO $ evaluate $ force $ v) $
568+ (do v <- op key file; liftIO $ evaluate $ force v) $
518− \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
569+ \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
519− modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file
570+ modTime <- liftIO $ (currentValue =<<) <$> getValues state GetModificationTime file
520− (bs, res) <- case res of
571+ (bs, res) <- case res of
521− Nothing -> do
572+ Nothing -> do
522− staleV <- liftIO $ getValues state key file
573+ staleV <- liftIO $ getValues state key file
523− pure $ case staleV of
574+ pure $ case staleV of
524− Nothing -> (toShakeValue ShakeResult bs, Failed)
575+ Nothing -> (toShakeValue ShakeResult bs, Failed)
525− Just v -> case v of
576+ Just v -> case v of
526− Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
577+ Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
527− Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
578+ Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
528− Failed -> (toShakeValue ShakeResult bs, Failed)
579+ Failed -> (toShakeValue ShakeResult bs, Failed)
529− Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
580+ Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
530− liftIO $ setValues state key file res
581+ liftIO $ setValues state key file res
531− updateFileDiagnostics file (Key key) extras $ map snd diags
582+ updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
532− let eq = case (bs, fmap decodeShakeValue old) of
583+ let eq = case (bs, fmap decodeShakeValue old) of
533− (ShakeResult a, Just (ShakeResult b)) -> a == b
584+ (ShakeResult a, Just (ShakeResult b)) -> a == b
534− (ShakeStale a, Just (ShakeStale b)) -> a == b
585+ (ShakeStale a, Just (ShakeStale b)) -> a == b
535− -- If we do not have a previous result
586+ -- If we do not have a previous result
536− -- or we got ShakeNoCutoff we always return False.
587+ -- or we got ShakeNoCutoff we always return False.
537− _ -> False
588+ _ -> False
538− return $ RunResult
589+ return $ RunResult
539− (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
590+ (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
540− (encodeShakeValue bs) $
591+ (encodeShakeValue bs) $
541− A res bs
592+ A res
542
593
543
594
544-- | Rule type, input file
595-- | Rule type, input file
@@ -589,7 +640,7 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $
589 case mbOld of
640 case mbOld of
590 Nothing -> do
641 Nothing -> do
591 (diags, mbHash) <- runAct
642 (diags, mbHash) <- runAct
592− updateFileDiagnostics file (Key key) extras $ map snd diags
643+ updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
593 pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash)
644 pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash)
594 Just old -> do
645 Just old -> do
595 current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "")
646 current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "")
@@ -600,27 +651,21 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $
600 pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current)
651 pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current)
601 else do
652 else do
602 (diags, mbHash) <- runAct
653 (diags, mbHash) <- runAct
603− updateFileDiagnostics file (Key key) extras $ map snd diags
654+ updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
604 let change
655 let change
605 | mbHash == Just old = ChangedRecomputeSame
656 | mbHash == Just old = ChangedRecomputeSame
606 | otherwise = ChangedRecomputeDiff
657 | otherwise = ChangedRecomputeDiff
607 pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)
658 pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)
608
659
609−fingerprintToBS :: Fingerprint -> BS.ByteString
610−fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do
611− ptr <- pure $ castPtr ptr
612− pokeElemOff ptr 0 a
613− pokeElemOff ptr 1 b
614−
615needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()
660needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()
616needOnDisk k file = do
661needOnDisk k file = do
617 successfull <- apply1 (QDisk k file)
662 successfull <- apply1 (QDisk k file)
618− liftIO $ unless successfull $ throwIO BadDependency
663+ liftIO $ unless successfull $ throwIO $ BadDependency (show k)
619
664
620needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()
665needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()
621needOnDisks k files = do
666needOnDisks k files = do
622 successfulls <- apply $ map (QDisk k) files
667 successfulls <- apply $ map (QDisk k) files
623− liftIO $ unless (and successfulls) $ throwIO BadDependency
668+ liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k)
624
669
625toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue
670toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue
626toShakeValue = maybe ShakeNoCutoff
671toShakeValue = maybe ShakeNoCutoff
@@ -656,29 +701,38 @@ updateFileDiagnostics ::
656 NormalizedFilePath
701 NormalizedFilePath
657 -> Key
702 -> Key
658 -> ShakeExtras
703 -> ShakeExtras
659− -> [Diagnostic] -- ^ current results
704+ -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
660 -> Action ()
705 -> Action ()
661−updateFileDiagnostics fp k ShakeExtras{diagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
706+updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
662− modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp
707+ modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp
708+ let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
663 mask_ $ do
709 mask_ $ do
664 -- Mask async exceptions to ensure that updated diagnostics are always
710 -- Mask async exceptions to ensure that updated diagnostics are always
665 -- published. Otherwise, we might never publish certain diagnostics if
711 -- published. Otherwise, we might never publish certain diagnostics if
666 -- an exception strikes between modifyVar but before
712 -- an exception strikes between modifyVar but before
667 -- publishDiagnosticsNotification.
713 -- publishDiagnosticsNotification.
668 newDiags <- modifyVar diagnostics $ \old -> do
714 newDiags <- modifyVar diagnostics $ \old -> do
669− let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime) (T.pack $ show k) current old
715+ let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
716+ (T.pack $ show k) (map snd currentShown) old
670 let newDiags = getFileDiagnostics fp newDiagsStore
717 let newDiags = getFileDiagnostics fp newDiagsStore
671 _ <- evaluate newDiagsStore
718 _ <- evaluate newDiagsStore
672 _ <- evaluate newDiags
719 _ <- evaluate newDiags
673− pure $! (newDiagsStore, newDiags)
720+ pure (newDiagsStore, newDiags)
721+ modifyVar_ hiddenDiagnostics $ \old -> do
722+ let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
723+ (T.pack $ show k) (map snd currentHidden) old
724+ let newDiags = getFileDiagnostics fp newDiagsStore
725+ _ <- evaluate newDiagsStore
726+ _ <- evaluate newDiags
727+ return newDiagsStore
674 let uri = filePathToUri' fp
728 let uri = filePathToUri' fp
675 let delay = if null newDiags then 0.1 else 0
729 let delay = if null newDiags then 0.1 else 0
676 registerEvent debouncer delay uri $ do
730 registerEvent debouncer delay uri $ do
677 mask_ $ modifyVar_ publishedDiagnostics $ \published -> do
731 mask_ $ modifyVar_ publishedDiagnostics $ \published -> do
678− let lastPublish = Map.findWithDefault [] uri published
732+ let lastPublish = HMap.lookupDefault [] uri published
679 when (lastPublish /= newDiags) $
733 when (lastPublish /= newDiags) $
680 eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags
734 eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags
681− pure $! Map.insert uri newDiags published
735+ pure $! HMap.insert uri newDiags published
682
736
683publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage
737publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage
684publishDiagnosticsNotification uri diags =
738publishDiagnosticsNotification uri diags =
@@ -689,7 +743,7 @@ publishDiagnosticsNotification uri diags =
689newtype Priority = Priority Double
743newtype Priority = Priority Double
690
744
691setPriority :: Priority -> Action ()
745setPriority :: Priority -> Action ()
692−setPriority (Priority p) = deprioritize p
746+setPriority (Priority p) = reschedule p
693
747
694sendEvent :: LSP.FromServerMessage -> Action ()
748sendEvent :: LSP.FromServerMessage -> Action ()
695sendEvent e = do
749sendEvent e = do
@@ -714,19 +768,22 @@ instance Binary GetModificationTime
714-- | Get the modification time of a file.
768-- | Get the modification time of a file.
715type instance RuleResult GetModificationTime = FileVersion
769type instance RuleResult GetModificationTime = FileVersion
716
770
717−-- | We store the modification time as a ByteString since we need
771+data FileVersion
718−-- a ByteString anyway for Shake and we do not care about how times
772+ = VFSVersion !Int
719−-- are represented.
720−data FileVersion = VFSVersion Int | ModificationTime BS.ByteString
773+ | ModificationTime
774+ !Int -- ^ Large unit (platform dependent, do not make assumptions)
775+ !Int -- ^ Small unit (platform dependent, do not make assumptions)
721 deriving (Show, Generic)
776 deriving (Show, Generic)
722
777
723instance NFData FileVersion
778instance NFData FileVersion
724
779
725vfsVersion :: FileVersion -> Maybe Int
780vfsVersion :: FileVersion -> Maybe Int
726vfsVersion (VFSVersion i) = Just i
781vfsVersion (VFSVersion i) = Just i
727−vfsVersion (ModificationTime _) = Nothing
782+vfsVersion ModificationTime{} = Nothing
728−
729
783
784+modificationTime :: FileVersion -> Maybe (Int, Int)
785+modificationTime VFSVersion{} = Nothing
786+modificationTime (ModificationTime large small) = Just (large, small)
730
787
731getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
788getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
732getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
789getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
@@ -751,7 +808,7 @@ getAllDiagnostics ::
751 DiagnosticStore ->
808 DiagnosticStore ->
752 [FileDiagnostic]
809 [FileDiagnostic]
753getAllDiagnostics =
810getAllDiagnostics =
754− concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList
811+ concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList
755
812
756getFileDiagnostics ::
813getFileDiagnostics ::
757 NormalizedFilePath ->
814 NormalizedFilePath ->
@@ -759,29 +816,34 @@ getFileDiagnostics ::
759 [LSP.Diagnostic]
816 [LSP.Diagnostic]
760getFileDiagnostics fp ds =
817getFileDiagnostics fp ds =
761 maybe [] getDiagnosticsFromStore $
818 maybe [] getDiagnosticsFromStore $
762− Map.lookup (filePathToUri' fp) ds
819+ HMap.lookup (filePathToUri' fp) ds
763
820
764filterDiagnostics ::
821filterDiagnostics ::
765 (NormalizedFilePath -> Bool) ->
822 (NormalizedFilePath -> Bool) ->
766 DiagnosticStore ->
823 DiagnosticStore ->
767 DiagnosticStore
824 DiagnosticStore
768filterDiagnostics keep =
825filterDiagnostics keep =
769− Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)
826+ HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri)
770
827
771filterVersionMap
828filterVersionMap
772− :: Map NormalizedUri (Set.Set TextDocumentVersion)
829+ :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)
773− -> Map NormalizedUri (Map TextDocumentVersion a)
830+ -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
774− -> Map NormalizedUri (Map TextDocumentVersion a)
831+ -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
775filterVersionMap =
832filterVersionMap =
776− Map.merge Map.dropMissing Map.dropMissing $
777− Map.zipWithMatched $ \_ versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
833+ HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
778
834
779updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
835updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
780−updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do
836+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do
781 modifyVar_ positionMapping $ \allMappings -> do
837 modifyVar_ positionMapping $ \allMappings -> do
782 let uri = toNormalizedUri _uri
838 let uri = toNormalizedUri _uri
783− let mappingForUri = Map.findWithDefault Map.empty uri allMappings
839+ let mappingForUri = HMap.lookupDefault Map.empty uri allMappings
784− let updatedMapping =
840+ let (_, updatedMapping) =
785− Map.insert _version idMapping $
841+ -- Very important to use mapAccum here so that the tails of
786− Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri
842+ -- each mapping can be shared, otherwise quadratic space is
843+ -- used which is evident in long running sessions.
844+ Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))
845+ zeroMapping
846+ (Map.insert _version (shared_change, zeroMapping) mappingForUri)
787− pure $! Map.insert uri updatedMapping allMappings
847+ pure $! HMap.insert uri updatedMapping allMappings
848+ where
849+ shared_change = mkDelta changes
src/Development/IDE/GHC/CPP.hs+34−3
@@ -19,7 +19,8 @@
19--
19--
20-----------------------------------------------------------------------------
20-----------------------------------------------------------------------------
21
21
22−module Development.IDE.GHC.CPP(doCpp) where
22+module Development.IDE.GHC.CPP(doCpp, addOptP)
23+where
23
24
24import Development.IDE.GHC.Compat
25import Development.IDE.GHC.Compat
25import Packages
26import Packages
@@ -28,9 +29,15 @@ import Module
28import DynFlags
29import DynFlags
29import Panic
30import Panic
30import FileCleanup
31import FileCleanup
31−#if MIN_GHC_API_VERSION(8,8,0)
32+#if MIN_GHC_API_VERSION(8,8,2)
33+import LlvmCodeGen (llvmVersionList)
34+#elif MIN_GHC_API_VERSION(8,8,0)
32import LlvmCodeGen (LlvmVersion (..))
35import LlvmCodeGen (LlvmVersion (..))
33#endif
36#endif
37+#if MIN_GHC_API_VERSION (8,10,0)
38+import Fingerprint
39+import ToolSettings
40+#endif
34
41
35import System.Directory
42import System.Directory
36import System.FilePath
43import System.FilePath
@@ -57,7 +64,11 @@ doCpp dflags raw input_fn output_fn = do
57 let verbFlags = getVerbFlags dflags
64 let verbFlags = getVerbFlags dflags
58
65
59 let cpp_prog args | raw = SysTools.runCpp dflags args
66 let cpp_prog args | raw = SysTools.runCpp dflags args
67+#if MIN_GHC_API_VERSION(8,10,0)
68+ | otherwise = SysTools.runCc Nothing
69+#else
60 | otherwise = SysTools.runCc
70 | otherwise = SysTools.runCc
71+#endif
61 dflags (SysTools.Option "-E" : args)
72 dflags (SysTools.Option "-E" : args)
62
73
63 let target_defs =
74 let target_defs =
@@ -137,7 +148,11 @@ getBackendDefs :: DynFlags -> IO [String]
137getBackendDefs dflags | hscTarget dflags == HscLlvm = do
148getBackendDefs dflags | hscTarget dflags == HscLlvm = do
138 llvmVer <- figureLlvmVersion dflags
149 llvmVer <- figureLlvmVersion dflags
139 return $ case llvmVer of
150 return $ case llvmVer of
140−#if MIN_GHC_API_VERSION(8,8,0)
151+#if MIN_GHC_API_VERSION(8,8,2)
152+ Just v
153+ | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ]
154+ | m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ]
155+#elif MIN_GHC_API_VERSION(8,8,0)
141 Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]
156 Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]
142 Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
157 Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
143#else
158#else
@@ -152,6 +167,22 @@ getBackendDefs dflags | hscTarget dflags == HscLlvm = do
152getBackendDefs _ =
167getBackendDefs _ =
153 return []
168 return []
154
169
170+addOptP :: String -> DynFlags -> DynFlags
171+#if MIN_GHC_API_VERSION (8,10,0)
172+addOptP f = alterToolSettings $ \s -> s
173+ { toolSettings_opt_P = f : toolSettings_opt_P s
174+ , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)
175+ }
176+ where
177+ fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss
178+ alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }
179+#else
180+addOptP opt = onSettings (onOptP (opt:))
181+ where
182+ onSettings f x = x{settings = f $ settings x}
183+ onOptP f x = x{sOpt_P = f $ sOpt_P x}
184+#endif
185+
155-- ---------------------------------------------------------------------------
186-- ---------------------------------------------------------------------------
156-- Macros (cribbed from Cabal)
187-- Macros (cribbed from Cabal)
157
188
src/Development/IDE/GHC/Compat.hs+251−27
@@ -2,62 +2,106 @@
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4{-# LANGUAGE CPP #-}
4{-# LANGUAGE CPP #-}
5+{-# LANGUAGE PatternSynonyms #-}
5#include "ghc-api-version.h"
6#include "ghc-api-version.h"
6
7
7-- | Attempt at hiding the GHC version differences we can.
8-- | Attempt at hiding the GHC version differences we can.
8module Development.IDE.GHC.Compat(
9module Development.IDE.GHC.Compat(
10+ getHeaderImports,
9 HieFileResult(..),
11 HieFileResult(..),
10− HieFile(..),
12+ HieFile,
13+ hieExportNames,
14+ hie_module,
11 mkHieFile,
15 mkHieFile,
12 writeHieFile,
16 writeHieFile,
13 readHieFile,
17 readHieFile,
18+ supportsHieFiles,
19+ setDefaultHieDir,
20+ dontWriteHieFiles,
21+#if !MIN_GHC_API_VERSION(8,8,0)
22+ ml_hie_file,
23+#endif
14 hPutStringBuffer,
24 hPutStringBuffer,
15 includePathsGlobal,
25 includePathsGlobal,
16 includePathsQuote,
26 includePathsQuote,
17 addIncludePathsQuote,
27 addIncludePathsQuote,
18− ghcEnumerateExtensions
28+ getModuleHash,
29+ getPackageName,
30+ pattern DerivD,
31+ pattern ForD,
32+ pattern InstD,
33+ pattern TyClD,
34+ pattern ValD,
35+ pattern ClassOpSig,
36+ pattern IEThingAll,
37+ pattern IEThingWith,
38+ GHC.ModLocation,
39+ Module.addBootSuffix,
40+ pattern ModLocation,
41+ getConArgs,
42+
43+ module GHC
19 ) where
44 ) where
20
45
21import StringBuffer
46import StringBuffer
22import DynFlags
47import DynFlags
23−import GHC.LanguageExtensions.Type
48+import FieldLabel
49+import Fingerprint (Fingerprint)
50+import qualified Module
51+import Packages
24
52
53+import qualified GHC
54+import GHC hiding (
55+ ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation
25−#if MIN_GHC_API_VERSION(8,8,0)
56+#if MIN_GHC_API_VERSION(8,6,0)
26−import Data.List.Extra (enumerate)
57+ , getConArgs
58+#endif
59+ )
60+import qualified HeaderInfo as Hdr
61+import Avail
62+import ErrUtils (ErrorMessages)
63+import FastString (FastString)
64+
65+#if MIN_GHC_API_VERSION(8,10,0)
66+import HscTypes (mi_mod_hash)
27#endif
67#endif
28
68
29#if MIN_GHC_API_VERSION(8,8,0)
69#if MIN_GHC_API_VERSION(8,8,0)
30−import HieAst
70+import Control.Applicative ((<|>))
71+import Development.IDE.GHC.HieAst (mkHieFile)
31import HieBin
72import HieBin
32import HieTypes
73import HieTypes
74+
75+supportsHieFiles :: Bool
76+supportsHieFiles = True
77+
78+hieExportNames :: HieFile -> [(SrcSpan, Name)]
79+hieExportNames = nameListFromAvails . hie_exports
80+
33#else
81#else
82+
83+#if MIN_GHC_API_VERSION(8,6,0)
34−import GHC
84+import BinIface
85+import Data.IORef
86+import IfaceEnv
87+#endif
88+
89+import Binary
90+import Control.Exception (catch)
91+import Data.ByteString (ByteString)
35−import GhcPlugins
92+import GhcPlugins hiding (ModLocation)
36import NameCache
93import NameCache
37−import Avail
38import TcRnTypes
94import TcRnTypes
39import System.IO
95import System.IO
40import Foreign.ForeignPtr
96import Foreign.ForeignPtr
97+import MkIface
41
98
42
99
43−#if !MIN_GHC_API_VERSION(8,8,0)
44hPutStringBuffer :: Handle -> StringBuffer -> IO ()
100hPutStringBuffer :: Handle -> StringBuffer -> IO ()
45hPutStringBuffer hdl (StringBuffer buf len cur)
101hPutStringBuffer hdl (StringBuffer buf len cur)
46 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->
102 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->
47 hPutBuf hdl ptr len
103 hPutBuf hdl ptr len
48−#endif
49
104
50−mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile
51−mkHieFile _ _ _ = return (HieFile () [])
52−
53−writeHieFile :: FilePath -> HieFile -> IO ()
54−writeHieFile _ _ = return ()
55−
56−readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())
57−readHieFile _ _ = return (HieFileResult (HieFile () []), ())
58−
59−data HieFile = HieFile {hie_module :: (), hie_exports :: [AvailInfo]}
60−data HieFileResult = HieFileResult { hie_file_result :: HieFile }
61#endif
105#endif
62
106
63#if !MIN_GHC_API_VERSION(8,6,0)
107#if !MIN_GHC_API_VERSION(8,6,0)
@@ -75,11 +119,191 @@ addIncludePathsQuote path x = x{includePaths = f $ includePaths x}
75addIncludePathsQuote path x = x{includePaths = path : includePaths x}
119addIncludePathsQuote path x = x{includePaths = path : includePaths x}
76#endif
120#endif
77
121
78−ghcEnumerateExtensions :: [Extension]
122+pattern DerivD :: DerivDecl p -> HsDecl p
123+pattern DerivD x <-
124+#if MIN_GHC_API_VERSION(8,6,0)
125+ GHC.DerivD _ x
126+#else
127+ GHC.DerivD x
128+#endif
129+
130+pattern ForD :: ForeignDecl p -> HsDecl p
131+pattern ForD x <-
132+#if MIN_GHC_API_VERSION(8,6,0)
133+ GHC.ForD _ x
134+#else
135+ GHC.ForD x
136+#endif
137+
138+pattern ValD :: HsBind p -> HsDecl p
139+pattern ValD x <-
140+#if MIN_GHC_API_VERSION(8,6,0)
141+ GHC.ValD _ x
142+#else
143+ GHC.ValD x
144+#endif
145+
146+pattern InstD :: InstDecl p -> HsDecl p
147+pattern InstD x <-
148+#if MIN_GHC_API_VERSION(8,6,0)
149+ GHC.InstD _ x
150+#else
151+ GHC.InstD x
152+#endif
153+
154+pattern TyClD :: TyClDecl p -> HsDecl p
155+pattern TyClD x <-
156+#if MIN_GHC_API_VERSION(8,6,0)
157+ GHC.TyClD _ x
158+#else
159+ GHC.TyClD x
160+#endif
161+
162+pattern ClassOpSig :: Bool -> [Located (IdP pass)] -> LHsSigType pass -> Sig pass
163+pattern ClassOpSig a b c <-
164+#if MIN_GHC_API_VERSION(8,6,0)
165+ GHC.ClassOpSig _ a b c
166+#else
167+ GHC.ClassOpSig a b c
168+#endif
169+
170+pattern IEThingWith :: LIEWrappedName (IdP pass) -> IEWildcard -> [LIEWrappedName (IdP pass)] -> [Located (FieldLbl (IdP pass))] -> IE pass
171+pattern IEThingWith a b c d <-
172+#if MIN_GHC_API_VERSION(8,6,0)
173+ GHC.IEThingWith _ a b c d
174+#else
175+ GHC.IEThingWith a b c d
176+#endif
177+
178+pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation
179+pattern ModLocation a b c <-
79#if MIN_GHC_API_VERSION(8,8,0)
180#if MIN_GHC_API_VERSION(8,8,0)
80−ghcEnumerateExtensions = enumerate
181+ GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c ""
81−#elif MIN_GHC_API_VERSION(8,6,0)
82−ghcEnumerateExtensions = [Cpp .. StarIsType]
83#else
182#else
84−ghcEnumerateExtensions = [Cpp .. EmptyDataDeriving]
183+ GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c
85#endif
184#endif
185+
186+pattern IEThingAll :: LIEWrappedName (IdP pass) -> IE pass
187+pattern IEThingAll a <-
188+#if MIN_GHC_API_VERSION(8,6,0)
189+ GHC.IEThingAll _ a
190+#else
191+ GHC.IEThingAll a
192+#endif
193+
194+setDefaultHieDir :: FilePath -> DynFlags -> DynFlags
195+setDefaultHieDir _f d =
196+#if MIN_GHC_API_VERSION(8,8,0)
197+ d { hieDir = hieDir d <|> Just _f}
198+#else
199+ d
200+#endif
201+
202+dontWriteHieFiles :: DynFlags -> DynFlags
203+dontWriteHieFiles d =
204+#if MIN_GHC_API_VERSION(8,8,0)
205+ gopt_unset d Opt_WriteHie
206+#else
207+ d
208+#endif
209+
210+nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)]
211+nameListFromAvails as =
212+ map (\n -> (nameSrcSpan n, n)) (concatMap availNames as)
213+
214+#if !MIN_GHC_API_VERSION(8,8,0)
215+-- Reimplementations of functions for HIE files for GHC 8.6
216+
217+mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> ByteString -> Hsc HieFile
218+mkHieFile ms ts _ _ = return (HieFile (ms_mod ms) es)
219+ where
220+ es = nameListFromAvails (mkIfaceExports (tcg_exports ts))
221+
222+ml_hie_file :: GHC.ModLocation -> FilePath
223+ml_hie_file ml = ml_hi_file ml ++ ".hie"
224+
225+data HieFile = HieFile {hie_module :: Module, hie_exports :: [(SrcSpan, Name)]}
226+
227+hieExportNames :: HieFile -> [(SrcSpan, Name)]
228+hieExportNames = hie_exports
229+
230+instance Binary HieFile where
231+ put_ bh (HieFile m es) = do
232+ put_ bh m
233+ put_ bh es
234+
235+ get bh = do
236+ mod <- get bh
237+ es <- get bh
238+ return (HieFile mod es)
239+
240+data HieFileResult = HieFileResult { hie_file_result :: HieFile }
241+
242+writeHieFile :: FilePath -> HieFile -> IO ()
243+readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())
244+supportsHieFiles :: Bool
245+
246+#if MIN_GHC_API_VERSION(8,6,0)
247+
248+writeHieFile fp hie = do
249+ bh <- openBinMem (1024 * 1024)
250+ putWithUserData (const $ return ()) bh hie
251+ writeBinMem bh fp
252+
253+readHieFile nc fp = do
254+ bh <- readBinMem fp
255+ nc' <- newIORef nc
256+ hie_file <- getWithUserData (NCU (atomicModifyIORef' nc')) bh
257+ return (HieFileResult hie_file, ())
258+
259+supportsHieFiles = True
260+
261+#else
262+
263+supportsHieFiles = False
264+
265+writeHieFile _ _ = return ()
266+
267+readHieFile _ _ = return undefined
268+
269+#endif
270+
271+#endif
272+
273+getHeaderImports
274+ :: DynFlags
275+ -> StringBuffer
276+ -> FilePath
277+ -> FilePath
278+ -> IO
279+ ( Either
280+ ErrorMessages
281+ ( [(Maybe FastString, Located ModuleName)]
282+ , [(Maybe FastString, Located ModuleName)]
283+ , Located ModuleName
284+ )
285+ )
286+#if MIN_GHC_API_VERSION(8,8,0)
287+getHeaderImports = Hdr.getImports
288+#else
289+getHeaderImports a b c d =
290+ catch (Right <$> Hdr.getImports a b c d)
291+ (return . Left . srcErrorMessages)
292+#endif
293+
294+getModuleHash :: ModIface -> Fingerprint
295+#if MIN_GHC_API_VERSION(8,10,0)
296+getModuleHash = mi_mod_hash . mi_final_exts
297+#else
298+getModuleHash = mi_mod_hash
299+#endif
300+
301+getConArgs :: ConDecl pass -> HsConDeclDetails pass
302+#if MIN_GHC_API_VERSION(8,6,0)
303+getConArgs = GHC.getConArgs
304+#else
305+getConArgs = GHC.getConDetails
306+#endif
307+
308+getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName
309+getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i))
src/Development/IDE/GHC/Error.hs+37−4
@@ -9,12 +9,19 @@ module Development.IDE.GHC.Error
9 , diagFromStrings
9 , diagFromStrings
10 , diagFromGhcException
10 , diagFromGhcException
11 , catchSrcErrors
11 , catchSrcErrors
12+ , mergeDiagnostics
12
13
13 -- * utilities working with spans
14 -- * utilities working with spans
14 , srcSpanToLocation
15 , srcSpanToLocation
16+ , srcSpanToRange
15 , srcSpanToFilename
17 , srcSpanToFilename
16 , zeroSpan
18 , zeroSpan
17 , realSpan
19 , realSpan
20+ , isInsideSrcSpan
21+ , noSpan
22+
23+ -- * utilities working with severities
24+ , toDSeverity
18 ) where
25 ) where
19
26
20import Development.IDE.Types.Diagnostics as D
27import Development.IDE.Types.Diagnostics as D
@@ -30,11 +37,12 @@ import Panic
30import ErrUtils
37import ErrUtils
31import SrcLoc
38import SrcLoc
32import qualified Outputable as Out
39import qualified Outputable as Out
40+import Exception (ExceptionMonad)
33
41
34
42
35
43
36diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
44diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
37−diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,)
45+diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename loc,ShowDiag,)
38 Diagnostic
46 Diagnostic
39 { _range = srcSpanToRange loc
47 { _range = srcSpanToRange loc
40 , _severity = Just sev
48 , _severity = Just sev
@@ -42,18 +50,39 @@ diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename
42 , _message = msg
50 , _message = msg
43 , _code = Nothing
51 , _code = Nothing
44 , _relatedInformation = Nothing
52 , _relatedInformation = Nothing
53+ , _tags = Nothing
45 }
54 }
46
55
47-- | Produce a GHC-style error from a source span and a message.
56-- | Produce a GHC-style error from a source span and a message.
48diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]
57diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]
49diagFromErrMsg diagSource dflags e =
58diagFromErrMsg diagSource dflags e =
50− [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $ ErrUtils.pprLocErrMsg e
59+ [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $
60+ ErrUtils.formatErrDoc dflags $ ErrUtils.errMsgDoc e
51 | Just sev <- [toDSeverity $ errMsgSeverity e]]
61 | Just sev <- [toDSeverity $ errMsgSeverity e]]
52
62
53
63
54diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
64diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
55diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList
65diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList
56
66
67+-- | Merges two sorted lists of diagnostics, removing duplicates.
68+-- Assumes all the diagnostics are for the same file.
69+mergeDiagnostics :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
70+mergeDiagnostics aa [] = aa
71+mergeDiagnostics [] bb = bb
72+mergeDiagnostics (a@(_,_,ad@Diagnostic{_range = ar}):aa) (b@(_,_,bd@Diagnostic{_range=br}):bb)
73+ | ar < br
74+ = a : mergeDiagnostics aa (b:bb)
75+ | br < ar
76+ = b : mergeDiagnostics (a:aa) bb
77+ | _severity ad == _severity bd
78+ && _source ad == _source bd
79+ && _message ad == _message bd
80+ && _code ad == _code bd
81+ && _relatedInformation ad == _relatedInformation bd
82+ && _tags ad == _tags bd
83+ = a : mergeDiagnostics aa bb
84+ | otherwise
85+ = a : b : mergeDiagnostics aa bb
57
86
58-- | Convert a GHC SrcSpan to a DAML compiler Range
87-- | Convert a GHC SrcSpan to a DAML compiler Range
59srcSpanToRange :: SrcSpan -> Range
88srcSpanToRange :: SrcSpan -> Range
@@ -74,7 +103,11 @@ srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real
74srcSpanToLocation :: SrcSpan -> Location
103srcSpanToLocation :: SrcSpan -> Location
75srcSpanToLocation src =
104srcSpanToLocation src =
76 -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code
105 -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code
77− Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath $ srcSpanToFilename src) (srcSpanToRange src)
106+ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ srcSpanToFilename src) (srcSpanToRange src)
107+
108+isInsideSrcSpan :: Position -> SrcSpan -> Bool
109+p `isInsideSrcSpan` r = sp <= p && p <= ep
110+ where Range sp ep = srcSpanToRange r
78
111
79-- | Convert a GHC severity to a DAML compiler Severity. Severities below
112-- | Convert a GHC severity to a DAML compiler Severity. Severities below
80-- "Warning" level are dropped (returning Nothing).
113-- "Warning" level are dropped (returning Nothing).
@@ -117,7 +150,7 @@ realSpan = \case
117
150
118-- | Run something in a Ghc monad and catch the errors (SourceErrors and
151-- | Run something in a Ghc monad and catch the errors (SourceErrors and
119-- compiler-internal exceptions like Panic or InstallationError).
152-- compiler-internal exceptions like Panic or InstallationError).
120−catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)
153+catchSrcErrors :: (HasDynFlags m, ExceptionMonad m) => T.Text -> m a -> m (Either [FileDiagnostic] a)
121catchSrcErrors fromWhere ghcM = do
154catchSrcErrors fromWhere ghcM = do
122 dflags <- getDynFlags
155 dflags <- getDynFlags
123 handleGhcException (ghcExceptionToDiagnostics dflags) $
156 handleGhcException (ghcExceptionToDiagnostics dflags) $
src/Development/IDE/GHC/Orphans.hs+10−3
@@ -1,8 +1,10 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4+{-# LANGUAGE CPP #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
5{-# OPTIONS_GHC -Wno-orphans #-}
6{-# OPTIONS_GHC -Wno-orphans #-}
7+#include "ghc-api-version.h"
6
8
7-- | Orphan instances for GHC.
9-- | Orphan instances for GHC.
8-- Note that the 'NFData' instances may not be law abiding.
10-- Note that the 'NFData' instances may not be law abiding.
@@ -31,7 +33,7 @@ instance NFData Linkable where rnf = rwhnf
31instance Show InstalledUnitId where
33instance Show InstalledUnitId where
32 show = installedUnitIdString
34 show = installedUnitIdString
33
35
34−instance NFData InstalledUnitId where rnf = rwhnf
36+instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS
35
37
36instance NFData SB.StringBuffer where rnf = rwhnf
38instance NFData SB.StringBuffer where rnf = rwhnf
37
39
@@ -40,8 +42,8 @@ instance Show Module where
40
42
41instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint
43instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint
42
44
43−instance NFData (GenLocated SrcSpan ModuleName) where
45+instance (NFData l, NFData e) => NFData (GenLocated l e) where
44− rnf = rwhnf
46+ rnf (L l e) = rnf l `seq` rnf e
45
47
46instance Show ModSummary where
48instance Show ModSummary where
47 show = show . ms_mod
49 show = show . ms_mod
@@ -52,6 +54,11 @@ instance Show ParsedModule where
52instance NFData ModSummary where
54instance NFData ModSummary where
53 rnf = rwhnf
55 rnf = rwhnf
54
56
57+#if !MIN_GHC_API_VERSION(8,10,0)
58+instance NFData FastString where
59+ rnf = rwhnf
60+#endif
61+
55instance NFData ParsedModule where
62instance NFData ParsedModule where
56 rnf = rwhnf
63 rnf = rwhnf
57
64
src/Development/IDE/GHC/Util.hs+151−70
@@ -1,65 +1,83 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4−{-# OPTIONS_GHC -Wno-missing-fields #-} -- to enable prettyPrint
4+-- | General utility functions, mostly focused around GHC operations.
5−{-# LANGUAGE CPP #-}
6−#include "ghc-api-version.h"
7−
8−-- | GHC utility functions. Importantly, code using our GHC should never:
9−--
10−-- * Call runGhc, use runGhcFast instead. It's faster and doesn't require config we don't have.
11−--
12−-- * Call setSessionDynFlags, use modifyDynFlags instead. It's faster and avoids loading packages.
13module Development.IDE.GHC.Util(
5module Development.IDE.GHC.Util(
14− lookupPackageConfig,
6+ -- * HcsEnv and environment
7+ HscEnvEq(GhcVersionMismatch, compileTime, runTime), hscEnv, newHscEnvEq,
15 modifyDynFlags,
8 modifyDynFlags,
16− fakeDynFlags,
9+ evalGhcEnv,
17− prettyPrint,
18 runGhcEnv,
10 runGhcEnv,
11+ deps,
12+ -- * GHC wrappers
13+ prettyPrint,
14+ printRdrName,
15+ printName,
16+ ParseResult(..), runParser,
17+ lookupPackageConfig,
19 textToStringBuffer,
18 textToStringBuffer,
19+ stringBufferToByteString,
20 moduleImportPath,
20 moduleImportPath,
21− HscEnvEq, hscEnv, newHscEnvEq,
21+ cgGutsToCoreModule,
22+ fingerprintToBS,
23+ fingerprintFromStringBuffer,
24+ -- * General utilities
22 readFileUtf8,
25 readFileUtf8,
23− hDuplicateTo,
26+ hDuplicateTo',
24− cgGutsToCoreModule
27+ setDefaultHieDir,
28+ dontWriteHieFiles
25 ) where
29 ) where
26
30
27−import Config
28import Control.Concurrent
31import Control.Concurrent
29import Data.List.Extra
32import Data.List.Extra
33+import Data.ByteString.Internal (ByteString(..))
30import Data.Maybe
34import Data.Maybe
31import Data.Typeable
35import Data.Typeable
32−#if MIN_GHC_API_VERSION(8,6,0)
36+import qualified Data.ByteString.Internal as BS
33import Fingerprint
37import Fingerprint
34−#endif
35−import GHC
36import GhcMonad
38import GhcMonad
37−import GhcPlugins hiding (Unique)
38−import Data.IORef
39import Control.Exception
39import Control.Exception
40+import Data.IORef
41+import Data.Version (showVersion, Version)
40import FileCleanup
42import FileCleanup
43+import Foreign.Ptr
44+import Foreign.ForeignPtr
45+import Foreign.Storable
41import GHC.IO.BufferedIO (BufferedIO)
46import GHC.IO.BufferedIO (BufferedIO)
42import GHC.IO.Device as IODevice
47import GHC.IO.Device as IODevice
43import GHC.IO.Encoding
48import GHC.IO.Encoding
44import GHC.IO.Exception
49import GHC.IO.Exception
45import GHC.IO.Handle.Types
50import GHC.IO.Handle.Types
46import GHC.IO.Handle.Internals
51import GHC.IO.Handle.Internals
47−import Platform
48import Data.Unique
52import Data.Unique
49import Development.Shake.Classes
53import Development.Shake.Classes
50import qualified Data.Text as T
54import qualified Data.Text as T
51import qualified Data.Text.Encoding as T
55import qualified Data.Text.Encoding as T
52import qualified Data.Text.Encoding.Error as T
56import qualified Data.Text.Encoding.Error as T
53import qualified Data.ByteString as BS
57import qualified Data.ByteString as BS
58+import Lexer
54import StringBuffer
59import StringBuffer
55import System.FilePath
60import System.FilePath
61+import HscTypes (cg_binds, md_types, cg_module, ModDetails, CgGuts, ic_dflags, hsc_IC, HscEnv(hsc_dflags))
62+import PackageConfig (PackageConfig)
63+import Outputable (showSDocUnsafe, ppr, showSDoc, Outputable)
64+import Packages (getPackageConfigMap, lookupPackage')
65+import SrcLoc (mkRealSrcLoc)
66+import FastString (mkFastString)
67+import DynFlags (emptyFilesToClean, unsafeGlobalDynFlags)
68+import Module (moduleNameSlashes, InstalledUnitId)
69+import OccName (parenSymOcc)
70+import RdrName (nameRdrName, rdrNameOcc)
56
71
72+import Development.IDE.GHC.Compat as GHC
57import Development.IDE.Types.Location
73import Development.IDE.Types.Location
58
74
59
75
60----------------------------------------------------------------------
76----------------------------------------------------------------------
61-- GHC setup
77-- GHC setup
62
78
79+-- | Used to modify dyn flags in preference to calling 'setSessionDynFlags',
80+-- since that function also reloads packages (which is very slow).
63modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()
81modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()
64modifyDynFlags f = do
82modifyDynFlags f = do
65 newFlags <- f <$> getSessionDynFlags
83 newFlags <- f <$> getSessionDynFlags
@@ -68,6 +86,7 @@ modifyDynFlags f = do
68 modifySession $ \h ->
86 modifySession $ \h ->
69 h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} }
87 h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} }
70
88
89+-- | Given a 'UnitId' try and find the associated 'PackageConfig' in the environment.
71lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig
90lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig
72lookupPackageConfig unitId env =
91lookupPackageConfig unitId env =
73 lookupPackage' False pkgConfigMap unitId
92 lookupPackage' False pkgConfigMap unitId
@@ -78,86 +97,134 @@ lookupPackageConfig unitId env =
78 getPackageConfigMap $ hsc_dflags env
97 getPackageConfigMap $ hsc_dflags env
79
98
80
99
81−-- would be nice to do this more efficiently...
100+-- | Convert from the @text@ package to the @GHC@ 'StringBuffer'.
101+-- Currently implemented somewhat inefficiently (if it ever comes up in a profile).
82textToStringBuffer :: T.Text -> StringBuffer
102textToStringBuffer :: T.Text -> StringBuffer
83textToStringBuffer = stringToStringBuffer . T.unpack
103textToStringBuffer = stringToStringBuffer . T.unpack
84
104
105+runParser :: DynFlags -> String -> P a -> ParseResult a
106+runParser flags str parser = unP parser parseState
107+ where
108+ filename = "<interactive>"
109+ location = mkRealSrcLoc (mkFastString filename) 1 1
110+ buffer = stringToStringBuffer str
111+ parseState = mkPState flags buffer location
112+
113+stringBufferToByteString :: StringBuffer -> ByteString
114+stringBufferToByteString StringBuffer{..} = PS buf cur len
85
115
116+-- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.
86prettyPrint :: Outputable a => a -> String
117prettyPrint :: Outputable a => a -> String
87−prettyPrint = showSDoc fakeDynFlags . ppr
118+prettyPrint = showSDoc unsafeGlobalDynFlags . ppr
119+
120+-- | Pretty print a 'RdrName' wrapping operators in parens
121+printRdrName :: RdrName -> String
122+printRdrName name = showSDocUnsafe $ parenSymOcc rn (ppr rn)
123+ where
124+ rn = rdrNameOcc name
88
125
126+-- | Pretty print a 'Name' wrapping operators in parens
127+printName :: Name -> String
128+printName = printRdrName . nameRdrName
129+
130+-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required
131+-- pieces, but designed to be more efficient than a standard 'runGhc'.
132+evalGhcEnv :: HscEnv -> Ghc b -> IO b
133+evalGhcEnv env act = snd <$> runGhcEnv env act
134+
135+-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required
136+-- pieces, but designed to be more efficient than a standard 'runGhc'.
89−runGhcEnv :: HscEnv -> Ghc a -> IO a
137+runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a)
90runGhcEnv env act = do
138runGhcEnv env act = do
91 filesToClean <- newIORef emptyFilesToClean
139 filesToClean <- newIORef emptyFilesToClean
92 dirsToClean <- newIORef mempty
140 dirsToClean <- newIORef mempty
93 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}
141 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}
94 ref <- newIORef env{hsc_dflags=dflags}
142 ref <- newIORef env{hsc_dflags=dflags}
95− unGhc act (Session ref) `finally` do
143+ res <- unGhc act (Session ref) `finally` do
96 cleanTempFiles dflags
144 cleanTempFiles dflags
97 cleanTempDirs dflags
145 cleanTempDirs dflags
146+ (,res) <$> readIORef ref
98
147
99−-- Fake DynFlags which are mostly undefined, but define enough to do a
148+-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.
100−-- little bit.
149+-- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory
101−fakeDynFlags :: DynFlags
150+-- @\/usr\/Test@ should be on the include path to find sibling modules.
102−fakeDynFlags = defaultDynFlags settings mempty
103− where
104− settings = Settings
105− { sTargetPlatform = platform
106− , sPlatformConstants = platformConstants
107− , sProgramName = "ghc"
108− , sProjectVersion = cProjectVersion
109−#if MIN_GHC_API_VERSION(8,6,0)
110− , sOpt_P_fingerprint = fingerprint0
111−#endif
112− }
113− platform = Platform
114− { platformWordSize=8
115− , platformOS=OSUnknown
116− , platformUnregisterised=True
117− }
118− platformConstants = PlatformConstants
119− { pc_DYNAMIC_BY_DEFAULT=False
120− , pc_WORD_SIZE=8
121− }
122−
123−moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath
151+moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath
124-- The call to takeDirectory is required since DAML does not require that
152-- The call to takeDirectory is required since DAML does not require that
125-- the file name matches the module name in the last component.
153-- the file name matches the module name in the last component.
126-- Once that has changed we can get rid of this.
154-- Once that has changed we can get rid of this.
127−moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm
155+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn
128 -- This happens for single-component modules since takeDirectory "A" == "."
156 -- This happens for single-component modules since takeDirectory "A" == "."
129 | modDir == "." = Just pathDir
157 | modDir == "." = Just pathDir
130 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir
158 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir
131 where
159 where
132− ms = GHC.pm_mod_summary pm
133− mod' = GHC.ms_mod ms
134 -- A for module A.B
160 -- A for module A.B
135 modDir =
161 modDir =
136 takeDirectory $
162 takeDirectory $
137− fromNormalizedFilePath $ toNormalizedFilePath $
163+ fromNormalizedFilePath $ toNormalizedFilePath' $
138− moduleNameSlashes $ GHC.moduleName mod'
164+ moduleNameSlashes mn
139
165
140−-- | An HscEnv with equality.
166+-- | An 'HscEnv' with equality. Two values are considered equal
167+-- if they are created with the same call to 'newHscEnvEq'.
168+data HscEnvEq
141−data HscEnvEq = HscEnvEq Unique HscEnv
169+ = HscEnvEq !Unique !HscEnv
170+ [(InstalledUnitId, DynFlags)] -- In memory components for this HscEnv
171+ -- This is only used at the moment for the import dirs in
172+ -- the DynFlags
173+ | GhcVersionMismatch { compileTime :: !Version
174+ , runTime :: !Version
175+ }
142
176
177+-- | Unwrap an 'HsEnvEq'.
143hscEnv :: HscEnvEq -> HscEnv
178hscEnv :: HscEnvEq -> HscEnv
179+hscEnv = either error id . hscEnv'
180+
181+hscEnv' :: HscEnvEq -> Either String HscEnv
144−hscEnv (HscEnvEq _ x) = x
182+hscEnv' (HscEnvEq _ x _) = Right x
183+hscEnv' GhcVersionMismatch{..} = Left $
184+ unwords
185+ ["ghcide compiled against GHC"
186+ ,showVersion compileTime
187+ ,"but currently using"
188+ ,showVersion runTime
189+ ,". This is unsupported, ghcide must be compiled with the same GHC version as the project."
190+ ]
191+
192+deps :: HscEnvEq -> [(InstalledUnitId, DynFlags)]
193+deps (HscEnvEq _ _ u) = u
194+deps GhcVersionMismatch{} = []
145
195
196+-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
146−newHscEnvEq :: HscEnv -> IO HscEnvEq
197+newHscEnvEq :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
147−newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e
198+newHscEnvEq e uids = do u <- newUnique; return $ HscEnvEq u e uids
148
199
149instance Show HscEnvEq where
200instance Show HscEnvEq where
150− show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)
201+ show (HscEnvEq a _ _) = "HscEnvEq " ++ show (hashUnique a)
202+ show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)
151
203
152instance Eq HscEnvEq where
204instance Eq HscEnvEq where
153− HscEnvEq a _ == HscEnvEq b _ = a == b
205+ HscEnvEq a _ _ == HscEnvEq b _ _ = a == b
206+ GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d
207+ _ == _ = False
154
208
155instance NFData HscEnvEq where
209instance NFData HscEnvEq where
156− rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()
210+ rnf (HscEnvEq a b c) = rnf (hashUnique a) `seq` b `seq` c `seq` ()
211+ rnf GhcVersionMismatch{} = rnf runTime
157
212
213+instance Hashable HscEnvEq where
214+ hashWithSalt s (HscEnvEq a _b _c) = hashWithSalt s a
215+ hashWithSalt salt GhcVersionMismatch{..} = hashWithSalt salt (compileTime, runTime)
216+
217+-- Fake instance needed to persuade Shake to accept this type as a key.
218+-- No harm done as ghcide never persists these keys currently
219+instance Binary HscEnvEq where
220+ put _ = error "not really"
221+ get = error "not really"
222+
223+-- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error.
158readFileUtf8 :: FilePath -> IO T.Text
224readFileUtf8 :: FilePath -> IO T.Text
159readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f
225readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f
160
226
227+-- | Convert from a 'CgGuts' to a 'CoreModule'.
161cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule
228cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule
162cgGutsToCoreModule safeMode guts modDetails = CoreModule
229cgGutsToCoreModule safeMode guts modDetails = CoreModule
163 (cg_module guts)
230 (cg_module guts)
@@ -165,10 +232,24 @@ cgGutsToCoreModule safeMode guts modDetails = CoreModule
165 (cg_binds guts)
232 (cg_binds guts)
166 safeMode
233 safeMode
167
234
235+-- | Convert a 'Fingerprint' to a 'ByteString' by copying the byte across.
236+-- Will produce an 8 byte unreadable ByteString.
237+fingerprintToBS :: Fingerprint -> BS.ByteString
238+fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do
239+ ptr <- pure $ castPtr ptr
240+ pokeElemOff ptr 0 a
241+ pokeElemOff ptr 1 b
242+
243+-- | Take the 'Fingerprint' of a 'StringBuffer'.
244+fingerprintFromStringBuffer :: StringBuffer -> IO Fingerprint
245+fingerprintFromStringBuffer (StringBuffer buf len cur) =
246+ withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len
247+
248+
168−-- This is a slightly modified version of hDuplicateTo in GHC.
249+-- | A slightly modified version of 'hDuplicateTo' from GHC.
169−-- See the inline comment for more details.
250+-- Importantly, it avoids the bug listed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2318.
170−hDuplicateTo :: Handle -> Handle -> IO ()
251+hDuplicateTo' :: Handle -> Handle -> IO ()
171−hDuplicateTo h1@(FileHandle path m1) h2@(FileHandle _ m2) = do
252+hDuplicateTo' h1@(FileHandle path m1) h2@(FileHandle _ m2) = do
172 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
253 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
173 -- The implementation in base has this call to hClose_help.
254 -- The implementation in base has this call to hClose_help.
174 -- _ <- hClose_help h2_
255 -- _ <- hClose_help h2_
@@ -181,7 +262,7 @@ hDuplicateTo h1@(FileHandle path m1) h2@(FileHandle _ m2) = do
181 -- if it happens just in the right moment.
262 -- if it happens just in the right moment.
182 withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do
263 withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do
183 dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer)
264 dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer)
184−hDuplicateTo h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2) = do
265+hDuplicateTo' h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2) = do
185 withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
266 withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
186 _ <- hClose_help w2_
267 _ <- hClose_help w2_
187 withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do
268 withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do
@@ -190,7 +271,7 @@ hDuplicateTo h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2) = do
190 _ <- hClose_help r2_
271 _ <- hClose_help r2_
191 withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do
272 withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do
192 dupHandleTo path h1 (Just w1) r2_ r1_ Nothing
273 dupHandleTo path h1 (Just w1) r2_ r1_ Nothing
193−hDuplicateTo h1 _ =
274+hDuplicateTo' h1 _ =
194 ioe_dupHandlesNotCompatible h1
275 ioe_dupHandlesNotCompatible h1
195
276
196-- | This is copied unmodified from GHC since it is not exposed.
277-- | This is copied unmodified from GHC since it is not exposed.
src/Development/IDE/GHC/WithDynFlags.hsnew file+30
@@ -0,0 +1,30 @@
1+module Development.IDE.GHC.WithDynFlags
2+( WithDynFlags
3+, evalWithDynFlags
4+) where
5+
6+import Control.Monad.Trans.Reader (ask, ReaderT(..))
7+import GHC (DynFlags)
8+import Control.Monad.IO.Class (MonadIO)
9+import Exception (ExceptionMonad(..))
10+import Control.Monad.Trans.Class (MonadTrans(..))
11+import GhcPlugins (HasDynFlags(..))
12+
13+-- | A monad transformer implementing the 'HasDynFlags' effect
14+newtype WithDynFlags m a = WithDynFlags {withDynFlags :: ReaderT DynFlags m a}
15+ deriving (Applicative, Functor, Monad, MonadIO, MonadTrans)
16+
17+evalWithDynFlags :: DynFlags -> WithDynFlags m a -> m a
18+evalWithDynFlags dflags = flip runReaderT dflags . withDynFlags
19+
20+instance Monad m => HasDynFlags (WithDynFlags m) where
21+ getDynFlags = WithDynFlags ask
22+
23+instance ExceptionMonad m => ExceptionMonad (WithDynFlags m) where
24+ gmask f = WithDynFlags $ ReaderT $ \env ->
25+ gmask $ \restore ->
26+ let restore' = lift . restore . flip runReaderT env . withDynFlags
27+ in runReaderT (withDynFlags $ f restore') env
28+
29+ gcatch (WithDynFlags act) handle = WithDynFlags $ ReaderT $ \env ->
30+ gcatch (runReaderT act env) (flip runReaderT env . withDynFlags . handle)
src/Development/IDE/Import/DependencyInformation.hs+121−34
@@ -9,26 +9,33 @@ module Development.IDE.Import.DependencyInformation
9 , ModuleParseError(..)
9 , ModuleParseError(..)
10 , TransitiveDependencies(..)
10 , TransitiveDependencies(..)
11 , FilePathId(..)
11 , FilePathId(..)
12+ , NamedModuleDep(..)
12
13
13 , PathIdMap
14 , PathIdMap
14 , emptyPathIdMap
15 , emptyPathIdMap
15 , getPathId
16 , getPathId
17+ , lookupPathToId
16 , insertImport
18 , insertImport
17 , pathToId
19 , pathToId
18 , idToPath
20 , idToPath
19 , reachableModules
21 , reachableModules
20−
21 , processDependencyInformation
22 , processDependencyInformation
22 , transitiveDeps
23 , transitiveDeps
24+
25+ , BootIdMap
26+ , insertBootId
23 ) where
27 ) where
24
28
25import Control.DeepSeq
29import Control.DeepSeq
26import Data.Bifunctor
30import Data.Bifunctor
27import Data.Coerce
31import Data.Coerce
28import Data.List
32import Data.List
33+import Data.Tuple.Extra hiding (first, second)
29import Development.IDE.GHC.Orphans()
34import Development.IDE.GHC.Orphans()
30import Data.Either
35import Data.Either
31import Data.Graph
36import Data.Graph
37+import Data.HashMap.Strict (HashMap)
38+import qualified Data.HashMap.Strict as HMS
32import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
39import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
33import qualified Data.List.NonEmpty as NonEmpty
40import qualified Data.List.NonEmpty as NonEmpty
34import Data.IntMap (IntMap)
41import Data.IntMap (IntMap)
@@ -36,16 +43,14 @@ import qualified Data.IntMap.Strict as IntMap
36import qualified Data.IntMap.Lazy as IntMapLazy
43import qualified Data.IntMap.Lazy as IntMapLazy
37import Data.IntSet (IntSet)
44import Data.IntSet (IntSet)
38import qualified Data.IntSet as IntSet
45import qualified Data.IntSet as IntSet
39−import Data.Map (Map)
40−import qualified Data.Map.Strict as MS
41import Data.Maybe
46import Data.Maybe
42import Data.Set (Set)
47import Data.Set (Set)
43import qualified Data.Set as Set
48import qualified Data.Set as Set
44−import Data.Tuple.Extra (fst3)
45import GHC.Generics (Generic)
49import GHC.Generics (Generic)
46
50
47import Development.IDE.Types.Diagnostics
51import Development.IDE.Types.Diagnostics
48import Development.IDE.Types.Location
52import Development.IDE.Types.Location
53+import Development.IDE.Import.FindImports (ArtifactsLocation(..))
49
54
50import GHC
55import GHC
51import Module
56import Module
@@ -57,69 +62,100 @@ data ModuleImports = ModuleImports
57 -- that module on disk (if we found it)
62 -- that module on disk (if we found it)
58 , packageImports :: !(Set InstalledUnitId)
63 , packageImports :: !(Set InstalledUnitId)
59 -- ^ Transitive package dependencies unioned for all imports.
64 -- ^ Transitive package dependencies unioned for all imports.
60− }
65+ } deriving Show
61
66
62−-- | For processing dependency information, we need lots of maps and sets
67+-- | For processing dependency information, we need lots of maps and sets of
63−-- of filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet
68+-- filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet
64−-- instead and only convert at the edges
69+-- instead and only convert at the edges.
65−-- and
66newtype FilePathId = FilePathId { getFilePathId :: Int }
70newtype FilePathId = FilePathId { getFilePathId :: Int }
67 deriving (Show, NFData, Eq, Ord)
71 deriving (Show, NFData, Eq, Ord)
68
72
73+-- | Map from 'FilePathId'
74+type FilePathIdMap = IntMap
75+
76+-- | Set of 'FilePathId's
77+type FilePathIdSet = IntSet
78+
69data PathIdMap = PathIdMap
79data PathIdMap = PathIdMap
70− { idToPathMap :: !(IntMap NormalizedFilePath)
80+ { idToPathMap :: !(FilePathIdMap ArtifactsLocation)
71− , pathToIdMap :: !(Map NormalizedFilePath FilePathId)
81+ , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)
72 }
82 }
73 deriving (Show, Generic)
83 deriving (Show, Generic)
74
84
75instance NFData PathIdMap
85instance NFData PathIdMap
76
86
77emptyPathIdMap :: PathIdMap
87emptyPathIdMap :: PathIdMap
78−emptyPathIdMap = PathIdMap IntMap.empty MS.empty
88+emptyPathIdMap = PathIdMap IntMap.empty HMS.empty
79
89
80−getPathId :: NormalizedFilePath -> PathIdMap -> (FilePathId, PathIdMap)
90+getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap)
81getPathId path m@PathIdMap{..} =
91getPathId path m@PathIdMap{..} =
82− case MS.lookup path pathToIdMap of
92+ case HMS.lookup (artifactFilePath path) pathToIdMap of
83 Nothing ->
93 Nothing ->
84− let !newId = FilePathId $ MS.size pathToIdMap
94+ let !newId = FilePathId $ HMS.size pathToIdMap
85 in (newId, insertPathId path newId m)
95 in (newId, insertPathId path newId m)
86 Just id -> (id, m)
96 Just id -> (id, m)
87
97
88−insertPathId :: NormalizedFilePath -> FilePathId -> PathIdMap -> PathIdMap
98+insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap
89insertPathId path id PathIdMap{..} =
99insertPathId path id PathIdMap{..} =
90− PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (MS.insert path id pathToIdMap)
100+ PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert (artifactFilePath path) id pathToIdMap)
91
101
92insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation
102insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation
93insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }
103insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }
94
104
95pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId
105pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId
96−pathToId PathIdMap{pathToIdMap} path = pathToIdMap MS.! path
106+pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path
107+
108+lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId
109+lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap
97
110
98idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath
111idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath
112+idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId
113+
114+idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation
99−idToPath PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id
115+idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id
116+
117+type BootIdMap = FilePathIdMap FilePathId
118+
119+insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap
120+insertBootId k = IntMap.insert (getFilePathId k)
100
121
101-- | Unprocessed results that we find by following imports recursively.
122-- | Unprocessed results that we find by following imports recursively.
102data RawDependencyInformation = RawDependencyInformation
123data RawDependencyInformation = RawDependencyInformation
103− { rawImports :: !(IntMap (Either ModuleParseError ModuleImports))
124+ { rawImports :: !(FilePathIdMap (Either ModuleParseError ModuleImports))
104 , rawPathIdMap :: !PathIdMap
125 , rawPathIdMap :: !PathIdMap
105− }
126+ -- The rawBootMap maps the FilePathId of a hs-boot file to its
106−
127+ -- corresponding hs file. It is used when topologically sorting as we
128+ -- need to add edges between .hs-boot and .hs so that the .hs files
129+ -- appear later in the sort.
130+ , rawBootMap :: !BootIdMap
131+ } deriving Show
132+
107−pkgDependencies :: RawDependencyInformation -> IntMap (Set InstalledUnitId)
133+pkgDependencies :: RawDependencyInformation -> FilePathIdMap (Set InstalledUnitId)
108pkgDependencies RawDependencyInformation{..} =
134pkgDependencies RawDependencyInformation{..} =
109 IntMap.map (either (const Set.empty) packageImports) rawImports
135 IntMap.map (either (const Set.empty) packageImports) rawImports
110
136
111data DependencyInformation =
137data DependencyInformation =
112 DependencyInformation
138 DependencyInformation
113− { depErrorNodes :: !(IntMap (NonEmpty NodeError))
139+ { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError))
114 -- ^ Nodes that cannot be processed correctly.
140 -- ^ Nodes that cannot be processed correctly.
141+ , depModuleNames :: !(FilePathIdMap ShowableModuleName)
115− , depModuleDeps :: !(IntMap IntSet)
142+ , depModuleDeps :: !(FilePathIdMap FilePathIdSet)
116 -- ^ For a non-error node, this contains the set of module immediate dependencies
143 -- ^ For a non-error node, this contains the set of module immediate dependencies
117 -- in the same package.
144 -- in the same package.
118− , depPkgDeps :: !(IntMap (Set InstalledUnitId))
145+ , depPkgDeps :: !(FilePathIdMap (Set InstalledUnitId))
119 -- ^ For a non-error node, this contains the set of immediate pkg deps.
146 -- ^ For a non-error node, this contains the set of immediate pkg deps.
120 , depPathIdMap :: !PathIdMap
147 , depPathIdMap :: !PathIdMap
148+ -- ^ Map from FilePath to FilePathId
149+ , depBootMap :: !BootIdMap
150+ -- ^ Map from hs-boot file to the corresponding hs file
121 } deriving (Show, Generic)
151 } deriving (Show, Generic)
122
152
153+newtype ShowableModuleName =
154+ ShowableModuleName {showableModuleName :: ModuleName}
155+ deriving NFData
156+
157+instance Show ShowableModuleName where show = moduleNameString . showableModuleName
158+
123reachableModules :: DependencyInformation -> [NormalizedFilePath]
159reachableModules :: DependencyInformation -> [NormalizedFilePath]
124reachableModules DependencyInformation{..} =
160reachableModules DependencyInformation{..} =
125 map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps
161 map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps
@@ -186,23 +222,32 @@ processDependencyInformation rawDepInfo@RawDependencyInformation{..} =
186 DependencyInformation
222 DependencyInformation
187 { depErrorNodes = IntMap.fromList errorNodes
223 { depErrorNodes = IntMap.fromList errorNodes
188 , depModuleDeps = moduleDeps
224 , depModuleDeps = moduleDeps
225+ , depModuleNames = IntMap.fromList $ coerce moduleNames
189 , depPkgDeps = pkgDependencies rawDepInfo
226 , depPkgDeps = pkgDependencies rawDepInfo
190 , depPathIdMap = rawPathIdMap
227 , depPathIdMap = rawPathIdMap
228+ , depBootMap = rawBootMap
191 }
229 }
192 where resultGraph = buildResultGraph rawImports
230 where resultGraph = buildResultGraph rawImports
193 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph
231 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph
232+ moduleNames :: [(FilePathId, ModuleName)]
233+ moduleNames =
234+ [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports]
194 successEdges :: [(FilePathId, FilePathId, [FilePathId])]
235 successEdges :: [(FilePathId, FilePathId, [FilePathId])]
195 successEdges =
236 successEdges =
237+ map
196− map (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports)) successNodes
238+ (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports))
239+ successNodes
197 moduleDeps =
240 moduleDeps =
241+ IntMap.fromList $
198− IntMap.fromList $ map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs)) successEdges
242+ map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs))
243+ successEdges
199
244
200-- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:
245-- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:
201-- 1. Mark each node that is part of an import cycle as an error node.
246-- 1. Mark each node that is part of an import cycle as an error node.
202-- 2. Mark each node that has a parse error as an error node.
247-- 2. Mark each node that has a parse error as an error node.
203-- 3. Mark each node whose immediate children could not be located as an error.
248-- 3. Mark each node whose immediate children could not be located as an error.
204-- 4. Recursively propagate errors to parents if they are not already error nodes.
249-- 4. Recursively propagate errors to parents if they are not already error nodes.
205−buildResultGraph :: IntMap (Either ModuleParseError ModuleImports) -> IntMap NodeResult
250+buildResultGraph :: FilePathIdMap (Either ModuleParseError ModuleImports) -> FilePathIdMap NodeResult
206buildResultGraph g = propagatedErrors
251buildResultGraph g = propagatedErrors
207 where
252 where
208 sccs = stronglyConnComp (graphEdges g)
253 sccs = stronglyConnComp (graphEdges g)
@@ -249,7 +294,7 @@ buildResultGraph g = propagatedErrors
249 Right ModuleImports{moduleImports} ->
294 Right ModuleImports{moduleImports} ->
250 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports
295 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports
251
296
252−graphEdges :: IntMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]
297+graphEdges :: FilePathIdMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]
253graphEdges g =
298graphEdges g =
254 map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g
299 map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g
255 where deps :: Either e ModuleImports -> [FilePathId]
300 where deps :: Either e ModuleImports -> [FilePathId]
@@ -261,29 +306,71 @@ partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest
261partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest
306partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest
262partitionSCC [] = ([], [])
307partitionSCC [] = ([], [])
263
308
309+
264transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
310transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
265transitiveDeps DependencyInformation{..} file = do
311transitiveDeps DependencyInformation{..} file = do
266 let !fileId = pathToId depPathIdMap file
312 let !fileId = pathToId depPathIdMap file
267 reachableVs <-
313 reachableVs <-
314+ -- Delete the starting node
268 IntSet.delete (getFilePathId fileId) .
315 IntSet.delete (getFilePathId fileId) .
269 IntSet.fromList . map (fst3 . fromVertex) .
316 IntSet.fromList . map (fst3 . fromVertex) .
270 reachable g <$> toVertex (getFilePathId fileId)
317 reachable g <$> toVertex (getFilePathId fileId)
318+ let transitiveModuleDepIds =
271− let transitiveModuleDepIds = filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs
319+ filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs
272 let transitivePkgDeps =
320 let transitivePkgDeps =
273 Set.toList $ Set.unions $
321 Set.toList $ Set.unions $
274 map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $
322 map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $
275 getFilePathId fileId : transitiveModuleDepIds
323 getFilePathId fileId : transitiveModuleDepIds
324+ let transitiveModuleDeps =
276− let transitiveModuleDeps = map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds
325+ map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds
326+ let transitiveNamedModuleDeps =
327+ [ NamedModuleDep (idToPath depPathIdMap (FilePathId fid)) mn artifactModLocation
328+ | (fid, ShowableModuleName mn) <- IntMap.toList depModuleNames
329+ , let ArtifactsLocation{artifactModLocation} = idToPathMap depPathIdMap IntMap.! fid
330+ ]
277 pure TransitiveDependencies {..}
331 pure TransitiveDependencies {..}
332+ where
333+ (g, fromVertex, toVertex) = graphFromEdges edges
278− where (g, fromVertex, toVertex) = graphFromEdges (map (\(f, fs) -> (f, f, IntSet.toList fs)) $ IntMap.toList depModuleDeps)
334+ edges = map (\(f, fs) -> (f, f, IntSet.toList fs ++ boot_edge f)) $ IntMap.toList depModuleDeps
335+
336+ -- Need to add an edge between the .hs and .hs-boot file if it exists
337+ -- so the .hs file gets loaded after the .hs-boot file and the right
338+ -- stuff ends up in the HPT. If you don't have this check then GHC will
339+ -- fail to work with ghcide.
340+ boot_edge f = [getFilePathId f' | Just f' <- [IntMap.lookup f depBootMap]]
341+
279− vs = topSort g
342+ vs = topSort g
280
343
281data TransitiveDependencies = TransitiveDependencies
344data TransitiveDependencies = TransitiveDependencies
282 { transitiveModuleDeps :: [NormalizedFilePath]
345 { transitiveModuleDeps :: [NormalizedFilePath]
283 -- ^ Transitive module dependencies in topological order.
346 -- ^ Transitive module dependencies in topological order.
284 -- The module itself is not included.
347 -- The module itself is not included.
348+ , transitiveNamedModuleDeps :: [NamedModuleDep]
349+ -- ^ Transitive module dependencies in topological order.
350+ -- The module itself is not included.
285 , transitivePkgDeps :: [InstalledUnitId]
351 , transitivePkgDeps :: [InstalledUnitId]
286 -- ^ Transitive pkg dependencies in unspecified order.
352 -- ^ Transitive pkg dependencies in unspecified order.
287 } deriving (Eq, Show, Generic)
353 } deriving (Eq, Show, Generic)
288
354
289instance NFData TransitiveDependencies
355instance NFData TransitiveDependencies
356+
357+data NamedModuleDep = NamedModuleDep {
358+ nmdFilePath :: !NormalizedFilePath,
359+ nmdModuleName :: !ModuleName,
360+ nmdModLocation :: !ModLocation
361+ }
362+ deriving Generic
363+
364+instance Eq NamedModuleDep where
365+ a == b = nmdFilePath a == nmdFilePath b
366+
367+instance NFData NamedModuleDep where
368+ rnf NamedModuleDep{..} =
369+ rnf nmdFilePath `seq`
370+ rnf nmdModuleName `seq`
371+ -- 'ModLocation' lacks an 'NFData' instance
372+ rwhnf nmdModLocation
373+
374+instance Show NamedModuleDep where
375+ show NamedModuleDep{..} = show nmdFilePath
376+
src/Development/IDE/Import/FindImports.hs+63−17
@@ -7,16 +7,19 @@
7module Development.IDE.Import.FindImports
7module Development.IDE.Import.FindImports
8 ( locateModule
8 ( locateModule
9 , Import(..)
9 , Import(..)
10+ , ArtifactsLocation(..)
11+ , modSummaryToArtifactsLocation
12+ , isBootLocation
13+ , mkImportDirs
10 ) where
14 ) where
11
15
12import Development.IDE.GHC.Error as ErrUtils
16import Development.IDE.GHC.Error as ErrUtils
13import Development.IDE.GHC.Orphans()
17import Development.IDE.GHC.Orphans()
14import Development.IDE.Types.Diagnostics
18import Development.IDE.Types.Diagnostics
15import Development.IDE.Types.Location
19import Development.IDE.Types.Location
20+import Development.IDE.GHC.Compat
16-- GHC imports
21-- GHC imports
17−import DynFlags
18import FastString
22import FastString
19−import GHC
20import qualified Module as M
23import qualified Module as M
21import Packages
24import Packages
22import Outputable (showSDoc, ppr, pprPanic)
25import Outputable (showSDoc, ppr, pprPanic)
@@ -27,64 +30,107 @@ import Control.DeepSeq
27import Control.Monad.Extra
30import Control.Monad.Extra
28import Control.Monad.IO.Class
31import Control.Monad.IO.Class
29import System.FilePath
32import System.FilePath
33+import DriverPhases
34+import Data.Maybe
30
35
31data Import
36data Import
32− = FileImport !NormalizedFilePath
37+ = FileImport !ArtifactsLocation
33 | PackageImport !M.InstalledUnitId
38 | PackageImport !M.InstalledUnitId
34 deriving (Show)
39 deriving (Show)
35
40
41+data ArtifactsLocation = ArtifactsLocation
42+ { artifactFilePath :: !NormalizedFilePath
43+ , artifactModLocation :: !ModLocation
44+ , artifactIsSource :: !Bool -- ^ True if a module is a source input
45+ }
46+ deriving (Show)
47+
48+instance NFData ArtifactsLocation where
49+ rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource
50+
51+isBootLocation :: ArtifactsLocation -> Bool
52+isBootLocation = not . artifactIsSource
53+
36instance NFData Import where
54instance NFData Import where
37 rnf (FileImport x) = rnf x
55 rnf (FileImport x) = rnf x
38 rnf (PackageImport x) = rnf x
56 rnf (PackageImport x) = rnf x
39
57
58+modSummaryToArtifactsLocation :: NormalizedFilePath -> ModSummary -> ArtifactsLocation
59+modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location ms) (isSource (ms_hsc_src ms))
60+ where
61+ isSource HsSrcFile = True
62+ isSource _ = False
63+
40
64
41-- | locate a module in the file system. Where we go from *daml to Haskell
65-- | locate a module in the file system. Where we go from *daml to Haskell
42locateModuleFile :: MonadIO m
66locateModuleFile :: MonadIO m
43− => DynFlags
67+ => [[FilePath]]
44 -> [String]
68 -> [String]
45 -> (NormalizedFilePath -> m Bool)
69 -> (NormalizedFilePath -> m Bool)
46 -> Bool
70 -> Bool
47 -> ModuleName
71 -> ModuleName
48 -> m (Maybe NormalizedFilePath)
72 -> m (Maybe NormalizedFilePath)
49−locateModuleFile dflags exts doesExist isSource modName = do
73+locateModuleFile import_dirss exts doesExist isSource modName = do
50− let candidates =
74+ let candidates import_dirs =
51− [ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)
75+ [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)
52− | prefix <- importPaths dflags, ext <- exts]
76+ | prefix <- import_dirs , ext <- exts]
53− findM doesExist candidates
77+ findM doesExist (concatMap candidates import_dirss)
54 where
78 where
55 maybeBoot ext
79 maybeBoot ext
56 | isSource = ext ++ "-boot"
80 | isSource = ext ++ "-boot"
57 | otherwise = ext
81 | otherwise = ext
58
82
83+-- | This function is used to map a package name to a set of import paths.
84+-- It only returns Just for unit-ids which are possible to import into the
85+-- current module. In particular, it will return Nothing for 'main' components
86+-- as they can never be imported into another package.
87+mkImportDirs :: DynFlags -> (M.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath])
88+mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i
89+
59-- | locate a module in either the file system or the package database. Where we go from *daml to
90-- | locate a module in either the file system or the package database. Where we go from *daml to
60-- Haskell
91-- Haskell
61locateModule
92locateModule
62 :: MonadIO m
93 :: MonadIO m
63 => DynFlags
94 => DynFlags
95+ -> [(M.InstalledUnitId, DynFlags)] -- Sets import directories to look in
64 -> [String]
96 -> [String]
65 -> (NormalizedFilePath -> m Bool)
97 -> (NormalizedFilePath -> m Bool)
66 -> Located ModuleName
98 -> Located ModuleName
67 -> Maybe FastString
99 -> Maybe FastString
68 -> Bool
100 -> Bool
69 -> m (Either [FileDiagnostic] Import)
101 -> m (Either [FileDiagnostic] Import)
70−locateModule dflags exts doesExist modName mbPkgName isSource = do
102+locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do
71 case mbPkgName of
103 case mbPkgName of
72 -- "this" means that we should only look in the current package
104 -- "this" means that we should only look in the current package
73 Just "this" -> do
105 Just "this" -> do
74− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName
106+ lookupLocal [importPaths dflags]
75− case mbFile of
76− Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []
77− Just file -> return $ Right $ FileImport file
78 -- if a package name is given we only go look for a package
107 -- if a package name is given we only go look for a package
108+ Just pkgName
109+ | Just dirs <- lookup (PackageName pkgName) import_paths
110+ -> lookupLocal [dirs]
79− Just _pkgName -> lookupInPackageDB dflags
111+ | otherwise -> lookupInPackageDB dflags
80 Nothing -> do
112 Nothing -> do
81 -- first try to find the module as a file. If we can't find it try to find it in the package
113 -- first try to find the module as a file. If we can't find it try to find it in the package
82 -- database.
114 -- database.
115+ -- Here the importPaths for the current modules are added to the front of the import paths from the other components.
116+ -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in
117+ -- each component will end up being found in the wrong place and cause a multi-cradle match failure.
83− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName
118+ mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts doesExist isSource $ unLoc modName
84 case mbFile of
119 case mbFile of
85 Nothing -> lookupInPackageDB dflags
120 Nothing -> lookupInPackageDB dflags
86− Just file -> return $ Right $ FileImport file
121+ Just file -> toModLocation file
87 where
122 where
123+ import_paths = mapMaybe (mkImportDirs dflags) comp_info
124+ toModLocation file = liftIO $ do
125+ loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)
126+ return $ Right $ FileImport $ ArtifactsLocation file loc (not isSource)
127+
128+ lookupLocal dirs = do
129+ mbFile <- locateModuleFile dirs exts doesExist isSource $ unLoc modName
130+ case mbFile of
131+ Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []
132+ Just file -> toModLocation file
133+
88 lookupInPackageDB dfs =
134 lookupInPackageDB dfs =
89 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of
135 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of
90 LookupFound _m pkgConfig -> return $ Right $ PackageImport $ unitId pkgConfig
136 LookupFound _m pkgConfig -> return $ Right $ PackageImport $ unitId pkgConfig
src/Development/IDE/LSP/CodeAction.hsdeleted−285
@@ -1,285 +0,0 @@
1−-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2−-- SPDX-License-Identifier: Apache-2.0
3−
4−{-# LANGUAGE DuplicateRecordFields #-}
5−{-# LANGUAGE CPP #-}
6−#include "ghc-api-version.h"
7−
8−-- | Go to the definition of a variable.
9−module Development.IDE.LSP.CodeAction
10− ( setHandlersCodeAction
11− , setHandlersCodeLens
12− ) where
13−
14−import Language.Haskell.LSP.Types
15−import Development.IDE.GHC.Compat
16−import Development.IDE.Core.Rules
17−import Development.IDE.Core.Shake
18−import Development.IDE.LSP.Server
19−import Development.IDE.Types.Location
20−import qualified Data.HashMap.Strict as Map
21−import qualified Data.HashSet as Set
22−import qualified Language.Haskell.LSP.Core as LSP
23−import Language.Haskell.LSP.VFS
24−import Language.Haskell.LSP.Messages
25−import qualified Data.Rope.UTF16 as Rope
26−import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))
27−import Data.Char
28−import Data.Maybe
29−import Data.List.Extra
30−import qualified Data.Text as T
31−
32−-- | Generate code actions.
33−codeAction
34− :: LSP.LspFuncs ()
35− -> IdeState
36− -> CodeActionParams
37− -> IO (List CAResult)
38−codeAction lsp _ CodeActionParams{_textDocument=TextDocumentIdentifier uri,_context=CodeActionContext{_diagnostics=List xs}} = do
39− -- disable logging as its quite verbose
40− -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg
41− contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
42− let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
43− pure $ List
44− [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
45− | x <- xs, (title, tedit) <- suggestAction text x
46− , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
47− ]
48−
49−-- | Generate code lenses.
50−codeLens
51− :: LSP.LspFuncs ()
52− -> IdeState
53− -> CodeLensParams
54− -> IO (List CodeLens)
55−codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
56− diag <- getDiagnostics ideState
57− case uriToFilePath' uri of
58− Just (toNormalizedFilePath -> filePath) -> do
59− pure $ List
60− [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing
61− | (dFile, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag
62− , dFile == filePath
63− , (title, tedit) <- suggestTopLevelBinding False dDiag
64− , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
65− ]
66− Nothing -> pure $ List []
67−
68−-- | Generate code lenses.
69−executeAddSignatureCommand
70− :: LSP.LspFuncs ()
71− -> IdeState
72− -> ExecuteCommandParams
73− -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
74−executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
75− | _command == "typesignature.add"
76− , Just (List [edit]) <- _arguments
77− , Success wedit <- fromJSON edit
78− = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
79− | otherwise
80− = return (Null, Nothing)
81−
82−suggestAction :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
83−suggestAction contents diag@Diagnostic{_range=_range@Range{..},..}
84−
85−-- File.hs:16:1: warning:
86−-- The import of `Data.List' is redundant
87−-- except perhaps to import instances from `Data.List'
88−-- To import instances alone, use: import Data.List()
89− | "The import of " `T.isInfixOf` _message
90− || "The qualified import of " `T.isInfixOf` _message
91− , " is redundant" `T.isInfixOf` _message
92− = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]
93−
94−-- File.hs:52:41: error:
95−-- * Variable not in scope:
96−-- suggestAcion :: Maybe T.Text -> Range -> Range
97−-- * Perhaps you meant ‘suggestAction’ (line 83)
98−-- File.hs:94:37: error:
99−-- Not in scope: ‘T.isPrfixOf’
100−-- Perhaps you meant one of these:
101−-- ‘T.isPrefixOf’ (imported from Data.Text),
102−-- ‘T.isInfixOf’ (imported from Data.Text),
103−-- ‘T.isSuffixOf’ (imported from Data.Text)
104−-- Module ‘Data.Text’ does not export ‘isPrfixOf’.
105− | renameSuggestions@(_:_) <- extractRenamableTerms _message
106− = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]
107−
108−-- Foo.hs:3:8: error:
109−-- * Found type wildcard `_' standing for `p -> p1 -> p'
110−
111− | "Found type wildcard" `T.isInfixOf` _message
112− , " standing for " `T.isInfixOf` _message
113− , typeSignature <- extractWildCardTypeSignature _message
114− = [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]
115−
116−-- File.hs:22:8: error:
117−-- Illegal lambda-case (use -XLambdaCase)
118−-- File.hs:22:6: error:
119−-- Illegal view pattern: x -> foo
120−-- Use ViewPatterns to enable view patterns
121−-- File.hs:26:8: error:
122−-- Illegal `..' in record pattern
123−-- Use RecordWildCards to permit this
124−-- File.hs:53:28: error:
125−-- Illegal tuple section: use TupleSections
126−-- File.hs:238:29: error:
127−-- * Can't make a derived instance of `Data FSATrace':
128−-- You need DeriveDataTypeable to derive an instance for this class
129−-- * In the data declaration for `FSATrace'
130−-- C:\Neil\shake\src\Development\Shake\Command.hs:515:31: error:
131−-- * Illegal equational constraint a ~ ()
132−-- (Use GADTs or TypeFamilies to permit this)
133−-- * In the context: a ~ ()
134−-- While checking an instance declaration
135−-- In the instance declaration for `Unit (m a)'
136− | exts@(_:_) <- filter (`Set.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message
137− = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts]
138−
139−-- src/Development/IDE/Core/Compile.hs:58:1: error:
140−-- Could not find module ‘Data.Cha’
141−-- Perhaps you meant Data.Char (from base-4.12.0.0)
142− | "Could not find module" `T.isInfixOf` _message
143− , "Perhaps you meant" `T.isInfixOf` _message = let
144− findSuggestedModules = map (head . T.words) . drop 2 . T.lines
145− proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])
146− in map proposeModule $ nubOrd $ findSuggestedModules _message
147−
148−-- ...Development/IDE/LSP/CodeAction.hs:103:9: warning:
149−-- * Found hole: _ :: Int -> String
150−-- * In the expression: _
151−-- In the expression: _ a
152−-- In an equation for ‘foo’: foo a = _ a
153−-- * Relevant bindings include
154−-- a :: Int
155−-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:5)
156−-- foo :: Int -> String
157−-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)
158−-- Valid hole fits include
159−-- foo :: Int -> String
160−-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)
161−-- show :: forall a. Show a => a -> String
162−-- with show @Int
163−-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37
164−-- (and originally defined in ‘GHC.Show’))
165−-- mempty :: forall a. Monoid a => a
166−-- with mempty @(Int -> String)
167−-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37
168−-- (and originally defined in ‘GHC.Base’)) (lsp-ui)
169−
170− | topOfHoleFitsMarker `T.isInfixOf` _message = let
171− findSuggestedHoleFits :: T.Text -> [T.Text]
172− findSuggestedHoleFits = extractFitNames . selectLinesWithFits . dropPreceding . T.lines
173− proposeHoleFit name = ("replace hole `" <> holeName <> "` with " <> name, [TextEdit _range name])
174− holeName = T.strip $ last $ T.splitOn ":" $ head . T.splitOn "::" $ head $ filter ("Found hole" `T.isInfixOf`) $ T.lines _message
175− dropPreceding = dropWhile (not . (topOfHoleFitsMarker `T.isInfixOf`))
176− selectLinesWithFits = filter ("::" `T.isInfixOf`)
177− extractFitNames = map (T.strip . head . T.splitOn " :: ")
178− in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message
179−
180− | tlb@[_] <- suggestTopLevelBinding True diag = tlb
181−
182−suggestAction _ _ = []
183−
184−suggestTopLevelBinding :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
185−suggestTopLevelBinding isQuickFix Diagnostic{_range=_range@Range{..},..}
186− | "Top-level binding with no type signature" `T.isInfixOf` _message = let
187− filterNewlines = T.concat . T.lines
188− unifySpaces = T.unwords . T.words
189− signature = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
190− startOfLine = Position (_line _start) 0
191− beforeLine = Range startOfLine startOfLine
192− title = if isQuickFix then "add signature: " <> signature else signature
193− action = TextEdit beforeLine $ signature <> "\n"
194− in [(title, [action])]
195−suggestTopLevelBinding _ _ = []
196−
197−topOfHoleFitsMarker :: T.Text
198−topOfHoleFitsMarker =
199−#if MIN_GHC_API_VERSION(8,6,0)
200− "Valid hole fits include"
201−#else
202− "Valid substitutions include"
203−#endif
204−
205−mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit
206−mkRenameEdit contents range name =
207− if fromMaybe False maybeIsInfixFunction
208− then TextEdit range ("`" <> name <> "`")
209− else TextEdit range name
210− where
211− maybeIsInfixFunction = do
212− curr <- textInRange range <$> contents
213− pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr
214−
215−extractWildCardTypeSignature :: T.Text -> T.Text
216−extractWildCardTypeSignature =
217− -- inferring when parens are actually needed around the type signature would
218− -- require understanding both the precedence of the context of the _ and of
219− -- the signature itself. Inserting them unconditionally is ugly but safe.
220− ("(" `T.append`) . (`T.append` ")") .
221− T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') .
222− snd . T.breakOnEnd "standing for "
223−
224−extractRenamableTerms :: T.Text -> [T.Text]
225−extractRenamableTerms msg
226− -- Account for both "Variable not in scope" and "Not in scope"
227− | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg
228− | otherwise = []
229− where
230− extractSuggestions = map getEnclosed
231− . concatMap singleSuggestions
232− . filter isKnownSymbol
233− . T.lines
234− singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited
235− isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t
236− getEnclosed = T.dropWhile (== '‘')
237− . T.dropWhileEnd (== '’')
238− . T.dropAround (\c -> c /= '‘' && c /= '’')
239−
240−-- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace
241−-- between the end of the range and the next newline), extend the range to take up the whole line.
242−extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range
243−extendToWholeLineIfPossible contents range@Range{..} =
244− let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents
245− extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line
246− in if extend then Range _start (Position (_line _end + 1) 0) else range
247−
248−-- | All the GHC extensions
249−ghcExtensions :: Set.HashSet T.Text
250−ghcExtensions = Set.fromList $ map (T.pack . show) ghcEnumerateExtensions
251−
252−splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)
253−splitTextAtPosition (Position row col) x
254− | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x
255− , (preCol, postCol) <- T.splitAt col mid
256− = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)
257− | otherwise = (x, T.empty)
258−
259−textInRange :: Range -> T.Text -> T.Text
260−textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =
261− case compare startRow endRow of
262− LT ->
263− let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine
264− (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of
265− [] -> ("", [])
266− firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)
267− maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines
268− in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)
269− EQ ->
270− let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)
271− in T.take (endCol - startCol) (T.drop startCol line)
272− GT -> ""
273− where
274− linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)
275−
276−setHandlersCodeAction :: PartialHandlers
277−setHandlersCodeAction = PartialHandlers $ \WithMessage{..} x -> return x{
278− LSP.codeActionHandler = withResponse RspCodeAction codeAction
279− }
280−
281−setHandlersCodeLens :: PartialHandlers
282−setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
283− LSP.codeLensHandler = withResponse RspCodeLens codeLens,
284− LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
285− }
src/Development/IDE/LSP/Definition.hsdeleted−43
@@ -1,43 +0,0 @@
1−-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2−-- SPDX-License-Identifier: Apache-2.0
3−
4−
5−-- | Go to the definition of a variable.
6−module Development.IDE.LSP.Definition
7− ( setHandlersDefinition
8− ) where
9−
10−import Language.Haskell.LSP.Types
11−import Development.IDE.Types.Location
12−
13−import Development.IDE.Types.Logger
14−import Development.IDE.Core.Rules
15−import Development.IDE.Core.Service
16−import Development.IDE.LSP.Server
17−import qualified Language.Haskell.LSP.Core as LSP
18−import Language.Haskell.LSP.Messages
19−
20−import qualified Data.Text as T
21−
22−-- | Go to the definition of a variable.
23−gotoDefinition
24− :: IdeState
25− -> TextDocumentPositionParams
26− -> IO LocationResponseParams
27−gotoDefinition ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do
28− mbResult <- case uriToFilePath' uri of
29− Just path -> do
30− logInfo (ideLogger ide) $
31− "Definition request at position " <> T.pack (showPosition pos) <>
32− " in file: " <> T.pack path
33− runAction ide $ getDefinition (toNormalizedFilePath path) pos
34− Nothing -> pure Nothing
35− pure $ case mbResult of
36− Nothing -> MultiLoc []
37− Just loc -> SingleLoc loc
38−
39−
40−setHandlersDefinition :: PartialHandlers
41−setHandlersDefinition = PartialHandlers $ \WithMessage{..} x -> return x{
42− LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition
43− }
src/Development/IDE/LSP/Hover.hsdeleted−47
@@ -1,47 +0,0 @@
1−-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2−-- SPDX-License-Identifier: Apache-2.0
3−
4−
5−-- | Display information on hover.
6−module Development.IDE.LSP.Hover
7− ( setHandlersHover
8− ) where
9−
10−import Language.Haskell.LSP.Types
11−import Development.IDE.Types.Location
12−import Development.IDE.Core.Service
13−import Development.IDE.LSP.Server
14−import Development.IDE.Types.Logger
15−import qualified Language.Haskell.LSP.Core as LSP
16−import Language.Haskell.LSP.Messages
17−
18−import qualified Data.Text as T
19−
20−import Development.IDE.Core.Rules
21−
22−-- | Display information on hover.
23−onHover
24− :: IdeState
25− -> TextDocumentPositionParams
26− -> IO (Maybe Hover)
27−onHover ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do
28− mbResult <- case uriToFilePath' uri of
29− Just (toNormalizedFilePath -> filePath) -> do
30− logInfo (ideLogger ide) $
31− "Hover request at position " <> T.pack (showPosition pos) <>
32− " in file: " <> T.pack (fromNormalizedFilePath filePath)
33− runAction ide $ getAtPoint filePath pos
34− Nothing -> pure Nothing
35−
36− case mbResult of
37− Just (mbRange, contents) ->
38− pure $ Just $ Hover
39− (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents)
40− mbRange
41−
42− Nothing -> pure Nothing
43−
44−setHandlersHover :: PartialHandlers
45−setHandlersHover = PartialHandlers $ \WithMessage{..} x -> return x{
46− LSP.hoverHandler = withResponse RspHover $ const onHover
47− }
src/Development/IDE/LSP/HoverDefinition.hsnew file+62
@@ -0,0 +1,62 @@
1+-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2+-- SPDX-License-Identifier: Apache-2.0
3+
4+
5+-- | Display information on hover.
6+module Development.IDE.LSP.HoverDefinition
7+ ( setHandlersHover
8+ , setHandlersDefinition
9+ -- * For haskell-language-server
10+ , hover
11+ , gotoDefinition
12+ ) where
13+
14+import Development.IDE.Core.Rules
15+import Development.IDE.Core.Service
16+import Development.IDE.LSP.Server
17+import Development.IDE.Types.Location
18+import Development.IDE.Types.Logger
19+import Development.Shake
20+import qualified Language.Haskell.LSP.Core as LSP
21+import Language.Haskell.LSP.Messages
22+import Language.Haskell.LSP.Types
23+
24+import qualified Data.Text as T
25+
26+gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)
27+hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))
28+gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc
29+hover = request "Hover" getAtPoint Nothing foundHover
30+
31+foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover
32+foundHover (mbRange, contents) =
33+ Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange
34+
35+setHandlersDefinition, setHandlersHover :: PartialHandlers c
36+setHandlersDefinition = PartialHandlers $ \WithMessage{..} x ->
37+ return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition}
38+setHandlersHover = PartialHandlers $ \WithMessage{..} x ->
39+ return x{LSP.hoverHandler = withResponse RspHover $ const hover}
40+
41+-- | Respond to and log a hover or go-to-definition request
42+request
43+ :: T.Text
44+ -> (NormalizedFilePath -> Position -> Action (Maybe a))
45+ -> b
46+ -> (a -> b)
47+ -> IdeState
48+ -> TextDocumentPositionParams
49+ -> IO (Either ResponseError b)
50+request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do
51+ mbResult <- case uriToFilePath' uri of
52+ Just path -> logAndRunRequest label getResults ide pos path
53+ Nothing -> pure Nothing
54+ pure $ Right $ maybe notFound found mbResult
55+
56+logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b
57+logAndRunRequest label getResults ide pos path = do
58+ let filePath = toNormalizedFilePath' path
59+ logInfo (ideLogger ide) $
60+ label <> " request at position " <> T.pack (showPosition pos) <>
61+ " in file: " <> T.pack path
62+ runAction ide $ getResults filePath pos
src/Development/IDE/LSP/LanguageServer.hs+58−32
@@ -28,27 +28,30 @@ import GHC.IO.Handle (hDuplicate)
28import System.IO
28import System.IO
29import Control.Monad.Extra
29import Control.Monad.Extra
30
30
31−import Development.IDE.LSP.Definition
31+import Development.IDE.Core.IdeConfiguration
32−import Development.IDE.LSP.Hover
32+import Development.IDE.Core.Shake
33−import Development.IDE.LSP.CodeAction
33+import Development.IDE.LSP.HoverDefinition
34import Development.IDE.LSP.Notifications
34import Development.IDE.LSP.Notifications
35−import Development.IDE.Core.Service
35+import Development.IDE.LSP.Outline
36import Development.IDE.Types.Logger
36import Development.IDE.Types.Logger
37import Development.IDE.Core.FileStore
37import Development.IDE.Core.FileStore
38import Language.Haskell.LSP.Core (LspFuncs(..))
38import Language.Haskell.LSP.Core (LspFuncs(..))
39import Language.Haskell.LSP.Messages
39import Language.Haskell.LSP.Messages
40
40
41runLanguageServer
41runLanguageServer
42+ :: forall config. (Show config)
42− :: LSP.Options
43+ => LSP.Options
43− -> PartialHandlers
44+ -> PartialHandlers config
45+ -> (InitializeRequest -> Either T.Text config)
46+ -> (DidChangeConfigurationNotification -> Either T.Text config)
44 -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)
47 -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)
45 -> IO ()
48 -> IO ()
46−runLanguageServer options userHandlers getIdeState = do
49+runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do
47 -- Move stdout to another file descriptor and duplicate stderr
50 -- Move stdout to another file descriptor and duplicate stderr
48 -- to stdout. This guards against stray prints from corrupting the JSON-RPC
51 -- to stdout. This guards against stray prints from corrupting the JSON-RPC
49 -- message stream.
52 -- message stream.
50 newStdout <- hDuplicate stdout
53 newStdout <- hDuplicate stdout
51− stderr `Ghcide.hDuplicateTo` stdout
54+ stderr `Ghcide.hDuplicateTo'` stdout
52 hSetBuffering stderr NoBuffering
55 hSetBuffering stderr NoBuffering
53 hSetBuffering stdout NoBuffering
56 hSetBuffering stdout NoBuffering
54
57
@@ -60,7 +63,7 @@ runLanguageServer options userHandlers getIdeState = do
60
63
61 -- Send everything over a channel, since you need to wait until after initialise before
64 -- Send everything over a channel, since you need to wait until after initialise before
62 -- LspFuncs is available
65 -- LspFuncs is available
63− clientMsgChan :: Chan Message <- newChan
66+ clientMsgChan :: Chan (Message config) <- newChan
64
67
65 -- These barriers are signaled when the threads reading from these chans exit.
68 -- These barriers are signaled when the threads reading from these chans exit.
66 -- This should not happen but if it does, we will make sure that the whole server
69 -- This should not happen but if it does, we will make sure that the whole server
@@ -79,6 +82,7 @@ runLanguageServer options userHandlers getIdeState = do
79 let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do
82 let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do
80 atomically $ modifyTVar pendingRequests (Set.insert _id)
83 atomically $ modifyTVar pendingRequests (Set.insert _id)
81 writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f
84 writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f
85+ let withInitialize f = Just $ \r -> writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x)
82 let cancelRequest reqId = atomically $ do
86 let cancelRequest reqId = atomically $ do
83 queued <- readTVar pendingRequests
87 queued <- readTVar pendingRequests
84 -- We want to avoid that the list of cancelled requests
88 -- We want to avoid that the list of cancelled requests
@@ -95,19 +99,20 @@ runLanguageServer options userHandlers getIdeState = do
95 cancelled <- readTVar cancelledRequests
99 cancelled <- readTVar cancelledRequests
96 unless (reqId `Set.member` cancelled) retry
100 unless (reqId `Set.member` cancelled) retry
97 let PartialHandlers parts =
101 let PartialHandlers parts =
102+ initializeRequestHandler <>
98 setHandlersIgnore <> -- least important
103 setHandlersIgnore <> -- least important
99 setHandlersDefinition <> setHandlersHover <>
104 setHandlersDefinition <> setHandlersHover <>
100− setHandlersCodeAction <> setHandlersCodeLens <> -- useful features someone may override
105+ setHandlersOutline <>
101 userHandlers <>
106 userHandlers <>
102 setHandlersNotifications <> -- absolutely critical, join them with user notifications
107 setHandlersNotifications <> -- absolutely critical, join them with user notifications
103 cancelHandler cancelRequest
108 cancelHandler cancelRequest
104 -- Cancel requests are special since they need to be handled
109 -- Cancel requests are special since they need to be handled
105 -- out of order to be useful. Existing handlers are run afterwards.
110 -- out of order to be useful. Existing handlers are run afterwards.
106− handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def
111+ handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def
107
112
108 let initializeCallbacks = LSP.InitializeCallbacks
113 let initializeCallbacks = LSP.InitializeCallbacks
109− { LSP.onInitialConfiguration = const $ Right ()
114+ { LSP.onInitialConfiguration = onInitialConfig
110− , LSP.onConfigurationChange = const $ Right ()
115+ , LSP.onConfigurationChange = onConfigChange
111 , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan
116 , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan
112 }
117 }
113
118
@@ -122,9 +127,11 @@ runLanguageServer options userHandlers getIdeState = do
122 , void $ waitBarrier clientMsgBarrier
127 , void $ waitBarrier clientMsgBarrier
123 ]
128 ]
124 where
129 where
125− handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs () -> IO (Maybe err)
130+ handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan (Message config) -> LSP.LspFuncs config -> IO (Maybe err)
126 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
131 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
132+
127 ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities
133 ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities
134+
128 _ <- flip forkFinally (const exitClientMsg) $ forever $ do
135 _ <- flip forkFinally (const exitClientMsg) $ forever $ do
129 msg <- readChan clientMsgChan
136 msg <- readChan clientMsgChan
130 case msg of
137 case msg of
@@ -135,17 +142,25 @@ runLanguageServer options userHandlers getIdeState = do
135 "Message: " ++ show x ++ "\n" ++
142 "Message: " ++ show x ++ "\n" ++
136 "Exception: " ++ show e
143 "Exception: " ++ show e
137 Response x@RequestMessage{_id, _params} wrap act ->
144 Response x@RequestMessage{_id, _params} wrap act ->
138− checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
145+ checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
146+ \case
139− \res -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
147+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)
148+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)
140 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->
149 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->
141 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
150 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
142 \(res, newReq) -> do
151 \(res, newReq) -> do
143− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
152+ case res of
144− case newReq of
153+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)
145− Nothing -> return ()
154+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)
146− Just (rm, newReqParams) -> do
155+ whenJust newReq $ \(rm, newReqParams) -> do
147 reqId <- getNextReqId
156 reqId <- getNextReqId
148 sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams
157 sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams
158+ InitialParams x@RequestMessage{_id, _params} act -> do
159+ catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
160+ logError (ideLogger ide) $ T.pack $
161+ "Unexpected exception on InitializeRequest handler, please report!\n" ++
162+ "Message: " ++ show x ++ "\n" ++
163+ "Exception: " ++ show e
149 pure Nothing
164 pure Nothing
150
165
151 checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =
166 checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =
@@ -160,28 +175,39 @@ runLanguageServer options userHandlers getIdeState = do
160 Left () -> do
175 Left () -> do
161 logDebug (ideLogger ide) $ T.pack $
176 logDebug (ideLogger ide) $ T.pack $
162 "Cancelled request " <> show _id
177 "Cancelled request " <> show _id
163− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
178+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left
164− Just $ ResponseError RequestCancelled "" Nothing
179+ $ ResponseError RequestCancelled "" Nothing
165 Right res -> k res
180 Right res -> k res
166 ) $ \(e :: SomeException) -> do
181 ) $ \(e :: SomeException) -> do
167 logError (ideLogger ide) $ T.pack $
182 logError (ideLogger ide) $ T.pack $
168 "Unexpected exception on request, please report!\n" ++
183 "Unexpected exception on request, please report!\n" ++
169 "Message: " ++ show msg ++ "\n" ++
184 "Message: " ++ show msg ++ "\n" ++
170 "Exception: " ++ show e
185 "Exception: " ++ show e
171− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
186+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left
172− Just $ ResponseError InternalError (T.pack $ show e) Nothing
187+ $ ResponseError InternalError (T.pack $ show e) Nothing
173
188
189+initializeRequestHandler :: PartialHandlers config
190+initializeRequestHandler = PartialHandlers $ \WithMessage{..} x -> return x{
191+ LSP.initializeRequestHandler = withInitialize initHandler
192+ }
193+
194+initHandler
195+ :: LSP.LspFuncs c
196+ -> IdeState
197+ -> InitializeParams
198+ -> IO ()
199+initHandler _ ide params = registerIdeConfiguration (shakeExtras ide) (parseConfiguration params)
174
200
175-- | Things that get sent to us, but we don't deal with.
201-- | Things that get sent to us, but we don't deal with.
176-- Set them to avoid a warning in VS Code output.
202-- Set them to avoid a warning in VS Code output.
177−setHandlersIgnore :: PartialHandlers
203+setHandlersIgnore :: PartialHandlers config
178setHandlersIgnore = PartialHandlers $ \_ x -> return x
204setHandlersIgnore = PartialHandlers $ \_ x -> return x
179 {LSP.initializedHandler = none
205 {LSP.initializedHandler = none
180 ,LSP.responseHandler = none
206 ,LSP.responseHandler = none
181 }
207 }
182 where none = Just $ const $ return ()
208 where none = Just $ const $ return ()
183
209
184−cancelHandler :: (LspId -> IO ()) -> PartialHandlers
210+cancelHandler :: (LspId -> IO ()) -> PartialHandlers config
185cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
211cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
186 {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do
212 {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do
187 cancelRequest _id
213 cancelRequest _id
@@ -191,18 +217,18 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
191
217
192-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
218-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
193-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
219-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
194−data Message
220+data Message c
195− = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO resp)
221+ = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp))
196 -- | Used for cases in which we need to send not only a response,
222 -- | Used for cases in which we need to send not only a response,
197 -- but also an additional request to the client.
223 -- but also an additional request to the client.
198 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
224 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
199− | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams)))
225+ | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
200− | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ())
226+ | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())
201−
227+ -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler.
228+ | InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
202
229
203modifyOptions :: LSP.Options -> LSP.Options
230modifyOptions :: LSP.Options -> LSP.Options
204modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS
231modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS
205− , LSP.executeCommandCommands = Just ["typesignature.add"]
206 }
232 }
207 where
233 where
208 tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}
234 tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}
src/Development/IDE/LSP/Notifications.hs+39−13
@@ -2,32 +2,37 @@
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4{-# LANGUAGE DuplicateRecordFields #-}
4{-# LANGUAGE DuplicateRecordFields #-}
5−{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE RankNTypes #-}
6
6
7module Development.IDE.LSP.Notifications
7module Development.IDE.LSP.Notifications
8 ( setHandlersNotifications
8 ( setHandlersNotifications
9 ) where
9 ) where
10
10
11−import Language.Haskell.LSP.Types
12import Development.IDE.LSP.Server
11import Development.IDE.LSP.Server
13−import qualified Language.Haskell.LSP.Core as LSP
12+import qualified Language.Haskell.LSP.Core as LSP
13+import Language.Haskell.LSP.Types
14−import qualified Language.Haskell.LSP.Types as LSP
14+import qualified Language.Haskell.LSP.Types as LSP
15
15
16−import Development.IDE.Types.Logger
16+import Development.IDE.Core.IdeConfiguration
17−import Development.IDE.Core.Service
17+import Development.IDE.Core.Service
18−import Development.IDE.Types.Location
18+import Development.IDE.Types.Location
19+import Development.IDE.Types.Logger
19
20
20−import Control.Monad.Extra
21+import Control.Monad.Extra
22+import Data.Foldable as F
23+import Data.Maybe
21−import qualified Data.Set as S
24+import qualified Data.HashSet as S
25+import qualified Data.Text as Text
22
26
23−import Development.IDE.Core.FileStore
27+import Development.IDE.Core.FileStore (setSomethingModified)
28+import Development.IDE.Core.FileExists (modifyFileExists)
24−import Development.IDE.Core.OfInterest
29+import Development.IDE.Core.OfInterest
25
30
26
31
27whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
32whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
28−whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath
33+whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'
29
34
30−setHandlersNotifications :: PartialHandlers
35+setHandlersNotifications :: PartialHandlers c
31setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
36setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
32 {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $
37 {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $
33 \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do
38 \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do
@@ -52,4 +57,25 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
52 whenUriFile _uri $ \file -> do
57 whenUriFile _uri $ \file -> do
53 modifyFilesOfInterest ide (S.delete file)
58 modifyFilesOfInterest ide (S.delete file)
54 logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri
59 logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri
60+ ,LSP.didChangeWatchedFilesNotificationHandler = withNotification (LSP.didChangeWatchedFilesNotificationHandler x) $
61+ \_ ide (DidChangeWatchedFilesParams fileEvents) -> do
62+ let events =
63+ mapMaybe
64+ (\(FileEvent uri ev) ->
65+ (, ev /= FcDeleted) . toNormalizedFilePath'
66+ <$> LSP.uriToFilePath uri
67+ )
68+ ( F.toList fileEvents )
69+ let msg = Text.pack $ show events
70+ logInfo (ideLogger ide) $ "Files created or deleted: " <> msg
71+ modifyFileExists ide events
72+ setSomethingModified ide
73+
74+ ,LSP.didChangeWorkspaceFoldersNotificationHandler = withNotification (LSP.didChangeWorkspaceFoldersNotificationHandler x) $
75+ \_ ide (DidChangeWorkspaceFoldersParams events) -> do
76+ let add = S.union
77+ substract = flip S.difference
78+ modifyWorkspaceFolders ide
79+ $ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events))
80+ . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events))
55 }
81 }
src/Development/IDE/LSP/Outline.hsnew file+234
@@ -0,0 +1,234 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DuplicateRecordFields #-}
3+#include "ghc-api-version.h"
4+
5+module Development.IDE.LSP.Outline
6+ ( setHandlersOutline
7+ -- * For haskell-language-server
8+ , moduleOutline
9+ )
10+where
11+
12+import qualified Language.Haskell.LSP.Core as LSP
13+import Language.Haskell.LSP.Messages
14+import Language.Haskell.LSP.Types
15+import Data.Functor
16+import Data.Generics
17+import Data.Maybe
18+import Data.Text ( Text
19+ , pack
20+ )
21+import qualified Data.Text as T
22+import Development.IDE.Core.Rules
23+import Development.IDE.Core.Shake
24+import Development.IDE.GHC.Compat
25+import Development.IDE.GHC.Error ( srcSpanToRange )
26+import Development.IDE.LSP.Server
27+import Development.IDE.Types.Location
28+import Outputable ( Outputable
29+ , ppr
30+ , showSDocUnsafe
31+ )
32+
33+setHandlersOutline :: PartialHandlers c
34+setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x
35+ { LSP.documentSymbolHandler = withResponse RspDocumentSymbols moduleOutline
36+ }
37+
38+moduleOutline
39+ :: LSP.LspFuncs c -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)
40+moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }
41+ = case uriToFilePath uri of
42+ Just (toNormalizedFilePath' -> fp) -> do
43+ mb_decls <- runAction ideState $ use GetParsedModule fp
44+ pure $ Right $ case mb_decls of
45+ Nothing -> DSDocumentSymbols (List [])
46+ Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } }
47+ -> let
48+ declSymbols = mapMaybe documentSymbolForDecl hsmodDecls
49+ moduleSymbol = hsmodName <&> \(L l m) ->
50+ (defDocumentSymbol l :: DocumentSymbol)
51+ { _name = pprText m
52+ , _kind = SkFile
53+ , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0
54+ }
55+ importSymbols = maybe [] pure $
56+ documentSymbolForImportSummary
57+ (mapMaybe documentSymbolForImport hsmodImports)
58+ allSymbols = case moduleSymbol of
59+ Nothing -> importSymbols <> declSymbols
60+ Just x ->
61+ [ x { _children = Just (List (importSymbols <> declSymbols))
62+ }
63+ ]
64+ in
65+ DSDocumentSymbols (List allSymbols)
66+
67+
68+ Nothing -> pure $ Right $ DSDocumentSymbols (List [])
69+
70+documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol
71+documentSymbolForDecl (L l (TyClD FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))
72+ = Just (defDocumentSymbol l :: DocumentSymbol)
73+ { _name = showRdrName n
74+ <> (case pprText fdTyVars of
75+ "" -> ""
76+ t -> " " <> t
77+ )
78+ , _detail = Just $ pprText fdInfo
79+ , _kind = SkClass
80+ }
81+documentSymbolForDecl (L l (TyClD ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars }))
82+ = Just (defDocumentSymbol l :: DocumentSymbol)
83+ { _name = showRdrName name
84+ <> (case pprText tcdTyVars of
85+ "" -> ""
86+ t -> " " <> t
87+ )
88+ , _kind = SkClass
89+ , _detail = Just "class"
90+ , _children =
91+ Just $ List
92+ [ (defDocumentSymbol l :: DocumentSymbol)
93+ { _name = showRdrName n
94+ , _kind = SkMethod
95+ , _selectionRange = srcSpanToRange l'
96+ }
97+ | L l (ClassOpSig False names _) <- tcdSigs
98+ , L l' n <- names
99+ ]
100+ }
101+documentSymbolForDecl (L l (TyClD DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } }))
102+ = Just (defDocumentSymbol l :: DocumentSymbol)
103+ { _name = showRdrName name
104+ , _kind = SkStruct
105+ , _children =
106+ Just $ List
107+ [ (defDocumentSymbol l :: DocumentSymbol)
108+ { _name = showRdrName n
109+ , _kind = SkConstructor
110+ , _selectionRange = srcSpanToRange l'
111+ , _children = conArgRecordFields (getConArgs x)
112+ }
113+ | L l x <- dd_cons
114+ , L l' n <- getConNames x
115+ ]
116+ }
117+ where
118+ -- | Extract the record fields of a constructor
119+ conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List
120+ [ (defDocumentSymbol l :: DocumentSymbol)
121+ { _name = showRdrName n
122+ , _kind = SkField
123+ }
124+ | L _ cdf <- lcdfs
125+ , L l n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf
126+ ]
127+ conArgRecordFields _ = Nothing
128+documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just
129+ (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n
130+ , _kind = SkTypeParameter
131+ , _selectionRange = srcSpanToRange l'
132+ }
133+documentSymbolForDecl (L l (InstD ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))
134+ = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty
135+ , _kind = SkInterface
136+ }
137+documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))
138+ = Just (defDocumentSymbol l :: DocumentSymbol)
139+ { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords
140+ (map pprText feqn_pats)
141+ , _kind = SkInterface
142+ }
143+documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))
144+ = Just (defDocumentSymbol l :: DocumentSymbol)
145+ { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords
146+ (map pprText feqn_pats)
147+ , _kind = SkInterface
148+ }
149+documentSymbolForDecl (L l (DerivD DerivDecl { deriv_type })) =
150+ gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) ->
151+ (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs)
152+ name
153+ , _kind = SkInterface
154+ }
155+documentSymbolForDecl (L l (ValD FunBind{fun_id = L _ name})) = Just
156+ (defDocumentSymbol l :: DocumentSymbol)
157+ { _name = showRdrName name
158+ , _kind = SkFunction
159+ }
160+documentSymbolForDecl (L l (ValD PatBind{pat_lhs})) = Just
161+ (defDocumentSymbol l :: DocumentSymbol)
162+ { _name = pprText pat_lhs
163+ , _kind = SkFunction
164+ }
165+
166+documentSymbolForDecl (L l (ForD x)) = Just
167+ (defDocumentSymbol l :: DocumentSymbol)
168+ { _name = case x of
169+ ForeignImport{} -> name
170+ ForeignExport{} -> name
171+#if MIN_GHC_API_VERSION(8,6,0)
172+ XForeignDecl{} -> "?"
173+#endif
174+ , _kind = SkObject
175+ , _detail = case x of
176+ ForeignImport{} -> Just "import"
177+ ForeignExport{} -> Just "export"
178+#if MIN_GHC_API_VERSION(8,6,0)
179+ XForeignDecl{} -> Nothing
180+#endif
181+ }
182+ where name = showRdrName $ unLoc $ fd_name x
183+
184+documentSymbolForDecl _ = Nothing
185+
186+-- | Wrap the Document imports into a hierarchical outline for
187+-- a better overview of symbols in scope.
188+-- If there are no imports, then no hierarchy will be created.
189+documentSymbolForImportSummary :: [DocumentSymbol] -> Maybe DocumentSymbol
190+documentSymbolForImportSummary [] = Nothing
191+documentSymbolForImportSummary importSymbols =
192+ let
193+ -- safe because if we have no ranges then we don't take this branch
194+ mergeRanges xs = Range (minimum $ map _start xs) (maximum $ map _end xs)
195+ importRange = mergeRanges $ map (_range :: DocumentSymbol -> Range) importSymbols
196+ in
197+ Just (defDocumentSymbol empty :: DocumentSymbol)
198+ { _name = "imports"
199+ , _kind = SkModule
200+ , _children = Just (List importSymbols)
201+ , _range = importRange
202+ , _selectionRange = importRange
203+ }
204+
205+documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol
206+documentSymbolForImport (L l ImportDecl { ideclName, ideclQualified }) = Just
207+ (defDocumentSymbol l :: DocumentSymbol)
208+ { _name = "import " <> pprText ideclName
209+ , _kind = SkModule
210+#if MIN_GHC_API_VERSION(8,10,0)
211+ , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" }
212+#else
213+ , _detail = if ideclQualified then Just "qualified" else Nothing
214+#endif
215+ }
216+#if MIN_GHC_API_VERSION(8,6,0)
217+documentSymbolForImport (L _ XImportDecl {}) = Nothing
218+#endif
219+
220+defDocumentSymbol :: SrcSpan -> DocumentSymbol
221+defDocumentSymbol l = DocumentSymbol { .. } where
222+ _detail = Nothing
223+ _deprecated = Nothing
224+ _name = ""
225+ _kind = SkUnknown 0
226+ _range = srcSpanToRange l
227+ _selectionRange = srcSpanToRange l
228+ _children = Nothing
229+
230+showRdrName :: RdrName -> Text
231+showRdrName = pprText
232+
233+pprText :: Outputable a => a -> Text
234+pprText = pack . showSDocUnsafe . ppr
src/Development/IDE/LSP/Server.hs+11−10
@@ -16,31 +16,32 @@ import qualified Language.Haskell.LSP.Core as LSP
16import qualified Language.Haskell.LSP.Messages as LSP
16import qualified Language.Haskell.LSP.Messages as LSP
17import Development.IDE.Core.Service
17import Development.IDE.Core.Service
18
18
19−
20−data WithMessage = WithMessage
19+data WithMessage c = WithMessage
21 {withResponse :: forall m req resp . (Show m, Show req) =>
20 {withResponse :: forall m req resp . (Show m, Show req) =>
22 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
21 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
23− (LSP.LspFuncs () -> IdeState -> req -> IO resp) -> -- actual work
22+ (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work
24 Maybe (LSP.Handler (RequestMessage m req resp))
23 Maybe (LSP.Handler (RequestMessage m req resp))
25 ,withNotification :: forall m req . (Show m, Show req) =>
24 ,withNotification :: forall m req . (Show m, Show req) =>
26 Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler
25 Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler
27− (LSP.LspFuncs () -> IdeState -> req -> IO ()) -> -- actual work
26+ (LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work
28 Maybe (LSP.Handler (NotificationMessage m req))
27 Maybe (LSP.Handler (NotificationMessage m req))
29− ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
28+ ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody .
30 (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
29 (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
31 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
30 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
32 (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req
31 (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req
33− (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work
32+ (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work
34 Maybe (LSP.Handler (RequestMessage m req resp))
33 Maybe (LSP.Handler (RequestMessage m req resp))
34+ , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
35+ -> Maybe (LSP.Handler InitializeRequest)
35 }
36 }
36
37
37−newtype PartialHandlers = PartialHandlers (WithMessage -> LSP.Handlers -> IO LSP.Handlers)
38+newtype PartialHandlers c = PartialHandlers (WithMessage c -> LSP.Handlers -> IO LSP.Handlers)
38
39
39−instance Default PartialHandlers where
40+instance Default (PartialHandlers c) where
40 def = PartialHandlers $ \_ x -> pure x
41 def = PartialHandlers $ \_ x -> pure x
41
42
42−instance Semigroup PartialHandlers where
43+instance Semigroup (PartialHandlers c) where
43 PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w
44 PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w
44
45
45−instance Monoid PartialHandlers where
46+instance Monoid (PartialHandlers c) where
46 mempty = def
47 mempty = def
src/Development/IDE/Plugin.hsnew file+60
@@ -0,0 +1,60 @@
1+
2+module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules,makeLspCommandId,getPid) where
3+
4+import Data.Default
5+import qualified Data.Text as T
6+import Development.Shake
7+import Development.IDE.LSP.Server
8+
9+import Language.Haskell.LSP.Types
10+import Development.IDE.Compat
11+import Development.IDE.Core.Rules
12+import qualified Language.Haskell.LSP.Core as LSP
13+import Language.Haskell.LSP.Messages
14+
15+
16+data Plugin c = Plugin
17+ {pluginRules :: Rules ()
18+ ,pluginHandler :: PartialHandlers c
19+ }
20+
21+instance Default (Plugin c) where
22+ def = Plugin mempty def
23+
24+instance Semigroup (Plugin c) where
25+ Plugin x1 y1 <> Plugin x2 y2 = Plugin (x1<>x2) (y1<>y2)
26+
27+instance Monoid (Plugin c) where
28+ mempty = def
29+
30+
31+codeActionPlugin :: (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c
32+codeActionPlugin = codeActionPluginWithRules mempty
33+
34+codeActionPluginWithRules :: Rules () -> (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c
35+codeActionPluginWithRules rr f = Plugin rr $ PartialHandlers $ \WithMessage{..} x -> return x{
36+ LSP.codeActionHandler = withResponse RspCodeAction g
37+ }
38+ where
39+ g lsp state (CodeActionParams a b c _) = fmap List <$> f lsp state a b c
40+
41+-- | Prefix to uniquely identify commands sent to the client. This
42+-- has two parts
43+--
44+-- - A representation of the process id to make sure that a client has
45+-- unique commands if it is running multiple servers, since some
46+-- clients have a global command table and get confused otherwise.
47+--
48+-- - A string to identify ghcide, to ease integration into
49+-- haskell-language-server, which routes commands to plugins based
50+-- on that.
51+makeLspCommandId :: T.Text -> IO T.Text
52+makeLspCommandId command = do
53+ pid <- getPid
54+ return $ pid <> ":ghcide:" <> command
55+
56+-- | Get the operating system process id for the running server
57+-- instance. This should be the same for the lifetime of the instance,
58+-- and different from that of any other currently running instance.
59+getPid :: IO T.Text
60+getPid = T.pack . show <$> getProcessID
src/Development/IDE/Plugin/CodeAction.hsnew file+570
@@ -0,0 +1,570 @@
1+-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2+-- SPDX-License-Identifier: Apache-2.0
3+
4+{-# LANGUAGE DuplicateRecordFields #-}
5+{-# LANGUAGE CPP #-}
6+#include "ghc-api-version.h"
7+
8+-- | Go to the definition of a variable.
9+module Development.IDE.Plugin.CodeAction
10+ (
11+ plugin
12+
13+ -- * For haskell-language-server
14+ , codeAction
15+ , codeLens
16+ , rulePackageExports
17+ , executeAddSignatureCommand
18+ ) where
19+
20+import Language.Haskell.LSP.Types
21+import Control.Monad (join)
22+import Development.IDE.Plugin
23+import Development.IDE.GHC.Compat
24+import Development.IDE.Core.Rules
25+import Development.IDE.Core.RuleTypes
26+import Development.IDE.Core.Service
27+import Development.IDE.Core.Shake
28+import Development.IDE.GHC.Error
29+import Development.IDE.GHC.Util
30+import Development.IDE.LSP.Server
31+import Development.IDE.Plugin.CodeAction.PositionIndexed
32+import Development.IDE.Plugin.CodeAction.RuleTypes
33+import Development.IDE.Plugin.CodeAction.Rules
34+import Development.IDE.Types.Location
35+import Development.IDE.Types.Options
36+import Development.Shake (Rules)
37+import qualified Data.HashMap.Strict as Map
38+import qualified Language.Haskell.LSP.Core as LSP
39+import Language.Haskell.LSP.VFS
40+import Language.Haskell.LSP.Messages
41+import qualified Data.Rope.UTF16 as Rope
42+import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))
43+import Control.Monad.Trans.Maybe
44+import Data.Char
45+import Data.Maybe
46+import Data.List.Extra
47+import qualified Data.Text as T
48+import Data.Tuple.Extra ((&&&))
49+import HscTypes
50+import Parser
51+import Text.Regex.TDFA ((=~), (=~~))
52+import Text.Regex.TDFA.Text()
53+import Outputable (ppr, showSDocUnsafe)
54+import DynFlags (xFlags, FlagSpec(..))
55+import GHC.LanguageExtensions.Type (Extension)
56+
57+plugin :: Plugin c
58+plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens
59+
60+rules :: Rules ()
61+rules = rulePackageExports
62+
63+-- | Generate code actions.
64+codeAction
65+ :: LSP.LspFuncs c
66+ -> IdeState
67+ -> TextDocumentIdentifier
68+ -> Range
69+ -> CodeActionContext
70+ -> IO (Either ResponseError [CAResult])
71+codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do
72+ -- disable logging as its quite verbose
73+ -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg
74+ contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
75+ let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
76+ mbFile = toNormalizedFilePath' <$> uriToFilePath uri
77+ (ideOptions, parsedModule, join -> env) <- runAction state $
78+ (,,) <$> getIdeOptions
79+ <*> getParsedModule `traverse` mbFile
80+ <*> use GhcSession `traverse` mbFile
81+ pkgExports <- runAction state $ (useNoFile_ . PackageExports) `traverse` env
82+ let dflags = hsc_dflags . hscEnv <$> env
83+ pure $ Right
84+ [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
85+ | x <- xs, (title, tedit) <- suggestAction dflags (fromMaybe mempty pkgExports) ideOptions ( join parsedModule ) text x
86+ , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
87+ ]
88+
89+-- | Generate code lenses.
90+codeLens
91+ :: LSP.LspFuncs c
92+ -> IdeState
93+ -> CodeLensParams
94+ -> IO (Either ResponseError (List CodeLens))
95+codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
96+ commandId <- makeLspCommandId "typesignature.add"
97+ fmap (Right . List) $ case uriToFilePath' uri of
98+ Just (toNormalizedFilePath' -> filePath) -> do
99+ _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
100+ diag <- getDiagnostics ideState
101+ hDiag <- getHiddenDiagnostics ideState
102+ pure
103+ [ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing
104+ | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag
105+ , dFile == filePath
106+ , (title, tedit) <- suggestSignature False dDiag
107+ , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
108+ ]
109+ Nothing -> pure []
110+
111+-- | Execute the "typesignature.add" command.
112+executeAddSignatureCommand
113+ :: LSP.LspFuncs c
114+ -> IdeState
115+ -> ExecuteCommandParams
116+ -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
117+executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
118+ -- _command is prefixed with a process ID, because certain clients
119+ -- have a global command registry, and all commands must be
120+ -- unique. And there can be more than one ghcide instance running
121+ -- at a time against the same client.
122+ | T.isSuffixOf "typesignature.add" _command
123+ , Just (List [edit]) <- _arguments
124+ , Success wedit <- fromJSON edit
125+ = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
126+ | otherwise
127+ = return (Right Null, Nothing)
128+
129+suggestAction
130+ :: Maybe DynFlags
131+ -> PackageExportsMap
132+ -> IdeOptions
133+ -> Maybe ParsedModule
134+ -> Maybe T.Text
135+ -> Diagnostic
136+ -> [(T.Text, [TextEdit])]
137+suggestAction dflags packageExports ideOptions parsedModule text diag = concat
138+ [ suggestAddExtension diag
139+ , suggestExtendImport dflags text diag
140+ , suggestFillHole diag
141+ , suggestFillTypeWildcard diag
142+ , suggestFixConstructorImport text diag
143+ , suggestModuleTypo diag
144+ , suggestReplaceIdentifier text diag
145+ , suggestSignature True diag
146+ ] ++ concat
147+ [ suggestNewDefinition ideOptions pm text diag
148+ ++ suggestRemoveRedundantImport pm text diag
149+ ++ suggestNewImport packageExports pm diag
150+ | Just pm <- [parsedModule]]
151+
152+
153+suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
154+suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..}
155+-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant
156+ | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"
157+ , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports
158+ , Just c <- contents
159+ , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)
160+ , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)
161+ , not (null ranges')
162+ = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]
163+
164+-- File.hs:16:1: warning:
165+-- The import of `Data.List' is redundant
166+-- except perhaps to import instances from `Data.List'
167+-- To import instances alone, use: import Data.List()
168+ | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)
169+ = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]
170+ | otherwise = []
171+
172+suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
173+suggestReplaceIdentifier contents Diagnostic{_range=_range,..}
174+-- File.hs:52:41: error:
175+-- * Variable not in scope:
176+-- suggestAcion :: Maybe T.Text -> Range -> Range
177+-- * Perhaps you meant ‘suggestAction’ (line 83)
178+-- File.hs:94:37: error:
179+-- Not in scope: ‘T.isPrfixOf’
180+-- Perhaps you meant one of these:
181+-- ‘T.isPrefixOf’ (imported from Data.Text),
182+-- ‘T.isInfixOf’ (imported from Data.Text),
183+-- ‘T.isSuffixOf’ (imported from Data.Text)
184+-- Module ‘Data.Text’ does not export ‘isPrfixOf’.
185+ | renameSuggestions@(_:_) <- extractRenamableTerms _message
186+ = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]
187+ | otherwise = []
188+
189+suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
190+suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range}
191+-- * Variable not in scope:
192+-- suggestAcion :: Maybe T.Text -> Range -> Range
193+ | Just [name, typ] <- matchRegex message "Variable not in scope: ([^ ]+) :: ([^*•]+)"
194+ = newDefinitionAction ideOptions parsedModule _range name typ
195+ | Just [name, typ] <- matchRegex message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps"
196+ , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ
197+ = [(label, mkRenameEdit contents _range name : newDefinitionEdits)]
198+ | otherwise = []
199+ where
200+ message = unifySpaces _message
201+
202+newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])]
203+newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ
204+ | Range _ lastLineP : _ <-
205+ [ srcSpanToRange l
206+ | (L l _) <- hsmodDecls
207+ , _start `isInsideSrcSpan` l]
208+ , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0}
209+ = [ ("Define " <> sig
210+ , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = error \"not implemented\""])]
211+ )]
212+ | otherwise = []
213+ where
214+ colon = if optNewColonConvention then " : " else " :: "
215+ sig = name <> colon <> T.dropWhileEnd isSpace typ
216+ ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule
217+
218+
219+suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]
220+suggestFillTypeWildcard Diagnostic{_range=_range,..}
221+-- Foo.hs:3:8: error:
222+-- * Found type wildcard `_' standing for `p -> p1 -> p'
223+
224+ | "Found type wildcard" `T.isInfixOf` _message
225+ , " standing for " `T.isInfixOf` _message
226+ , typeSignature <- extractWildCardTypeSignature _message
227+ = [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]
228+ | otherwise = []
229+
230+suggestAddExtension :: Diagnostic -> [(T.Text, [TextEdit])]
231+suggestAddExtension Diagnostic{_range=_range,..}
232+-- File.hs:22:8: error:
233+-- Illegal lambda-case (use -XLambdaCase)
234+-- File.hs:22:6: error:
235+-- Illegal view pattern: x -> foo
236+-- Use ViewPatterns to enable view patterns
237+-- File.hs:26:8: error:
238+-- Illegal `..' in record pattern
239+-- Use RecordWildCards to permit this
240+-- File.hs:53:28: error:
241+-- Illegal tuple section: use TupleSections
242+-- File.hs:238:29: error:
243+-- * Can't make a derived instance of `Data FSATrace':
244+-- You need DeriveDataTypeable to derive an instance for this class
245+-- * In the data declaration for `FSATrace'
246+-- C:\Neil\shake\src\Development\Shake\Command.hs:515:31: error:
247+-- * Illegal equational constraint a ~ ()
248+-- (Use GADTs or TypeFamilies to permit this)
249+-- * In the context: a ~ ()
250+-- While checking an instance declaration
251+-- In the instance declaration for `Unit (m a)'
252+ | exts@(_:_) <- filter (`Map.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message
253+ = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts]
254+ | otherwise = []
255+
256+-- | All the GHC extensions
257+ghcExtensions :: Map.HashMap T.Text Extension
258+ghcExtensions = Map.fromList . map ( ( T.pack . flagSpecName ) &&& flagSpecFlag ) $ xFlags
259+
260+suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]
261+suggestModuleTypo Diagnostic{_range=_range,..}
262+-- src/Development/IDE/Core/Compile.hs:58:1: error:
263+-- Could not find module ‘Data.Cha’
264+-- Perhaps you meant Data.Char (from base-4.12.0.0)
265+ | "Could not find module" `T.isInfixOf` _message
266+ , "Perhaps you meant" `T.isInfixOf` _message = let
267+ findSuggestedModules = map (head . T.words) . drop 2 . T.lines
268+ proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])
269+ in map proposeModule $ nubOrd $ findSuggestedModules _message
270+ | otherwise = []
271+
272+suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])]
273+suggestFillHole Diagnostic{_range=_range,..}
274+-- ...Development/IDE/LSP/CodeAction.hs:103:9: warning:
275+-- * Found hole: _ :: Int -> String
276+-- * In the expression: _
277+-- In the expression: _ a
278+-- In an equation for ‘foo’: foo a = _ a
279+-- * Relevant bindings include
280+-- a :: Int
281+-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:5)
282+-- foo :: Int -> String
283+-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)
284+-- Valid hole fits include
285+-- foo :: Int -> String
286+-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)
287+-- show :: forall a. Show a => a -> String
288+-- with show @Int
289+-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37
290+-- (and originally defined in ‘GHC.Show’))
291+-- mempty :: forall a. Monoid a => a
292+-- with mempty @(Int -> String)
293+-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37
294+-- (and originally defined in ‘GHC.Base’)) (lsp-ui)
295+
296+ | topOfHoleFitsMarker `T.isInfixOf` _message = let
297+ findSuggestedHoleFits :: T.Text -> [T.Text]
298+ findSuggestedHoleFits = extractFitNames . selectLinesWithFits . dropPreceding . T.lines
299+ proposeHoleFit name = ("replace hole `" <> holeName <> "` with " <> name, [TextEdit _range name])
300+ holeName = T.strip $ last $ T.splitOn ":" $ head . T.splitOn "::" $ head $ filter ("Found hole" `T.isInfixOf`) $ T.lines _message
301+ dropPreceding = dropWhile (not . (topOfHoleFitsMarker `T.isInfixOf`))
302+ selectLinesWithFits = filter ("::" `T.isInfixOf`)
303+ extractFitNames = map (T.strip . head . T.splitOn " :: ")
304+ in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message
305+
306+ | otherwise = []
307+
308+suggestExtendImport :: Maybe DynFlags -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
309+suggestExtendImport (Just dflags) contents Diagnostic{_range=_range,..}
310+ | Just [binding, mod, srcspan] <-
311+ matchRegex _message
312+ "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$"
313+ , Just c <- contents
314+ , POk _ (L _ name) <- runParser dflags (T.unpack binding) parseIdentifier
315+ = let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of
316+ [s] -> let x = srcSpanToRange s
317+ in x{_end = (_end x){_character = succ (_character (_end x))}}
318+ _ -> error "bug in srcspan parser"
319+ importLine = textInRange range c
320+ in [("Add " <> binding <> " to the import list of " <> mod
321+ , [TextEdit range (addBindingToImportList (T.pack $ printRdrName name) importLine)])]
322+ | otherwise = []
323+suggestExtendImport Nothing _ _ = []
324+
325+suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
326+suggestFixConstructorImport _ Diagnostic{_range=_range,..}
327+ -- ‘Success’ is a data constructor of ‘Result’
328+ -- To import it use
329+ -- import Data.Aeson.Types( Result( Success ) )
330+ -- or
331+ -- import Data.Aeson.Types( Result(..) ) (lsp-ui)
332+ | Just [constructor, typ] <-
333+ matchRegex _message
334+ "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use"
335+ = let fixedImport = typ <> "(" <> constructor <> ")"
336+ in [("Fix import of " <> fixedImport, [TextEdit _range fixedImport])]
337+ | otherwise = []
338+
339+suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
340+suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
341+ | _message =~
342+ ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) = let
343+ signature = removeInitialForAll
344+ $ T.takeWhile (\x -> x/='*' && x/='•')
345+ $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
346+ startOfLine = Position (_line _start) startCharacter
347+ beforeLine = Range startOfLine startOfLine
348+ title = if isQuickFix then "add signature: " <> signature else signature
349+ action = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " "
350+ in [(title, [action])]
351+ where removeInitialForAll :: T.Text -> T.Text
352+ removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))
353+ | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))
354+ | otherwise = nm <> ty
355+ startCharacter
356+ | "Polymorphic local binding" `T.isPrefixOf` _message
357+ = _character _start
358+ | otherwise
359+ = 0
360+
361+suggestSignature _ _ = []
362+
363+-------------------------------------------------------------------------------------------------
364+
365+suggestNewImport :: PackageExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]
366+suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message}
367+ | msg <- unifySpaces _message
368+ , Just name <- extractNotInScopeName msg
369+ , Just insertLine <- case hsmodImports of
370+ [] -> case srcSpanStart $ getLoc (head hsmodDecls) of
371+ RealSrcLoc s -> Just $ srcLocLine s - 1
372+ _ -> Nothing
373+ _ -> case srcSpanEnd $ getLoc (last hsmodImports) of
374+ RealSrcLoc s -> Just $ srcLocLine s
375+ _ -> Nothing
376+ , insertPos <- Position insertLine 0
377+ , extendImportSuggestions <- matchRegex msg
378+ "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"
379+ = [(imp, [TextEdit (Range insertPos insertPos) (imp <> "\n")])
380+ | imp <- constructNewImportSuggestions packageExportsMap name extendImportSuggestions
381+ ]
382+suggestNewImport _ _ _ = []
383+
384+constructNewImportSuggestions
385+ :: PackageExportsMap -> NotInScope -> Maybe [T.Text] -> [T.Text]
386+constructNewImportSuggestions exportsMap thingMissing notTheseModules = nubOrd
387+ [ renderNewImport identInfo m
388+ | (identInfo, m) <- fromMaybe [] $ Map.lookup name exportsMap
389+ , canUseIdent thingMissing identInfo
390+ , m `notElem` fromMaybe [] notTheseModules
391+ ]
392+ where
393+ renderNewImport identInfo m
394+ | Just q <- qual = "import qualified " <> m <> " as " <> q
395+ | otherwise = "import " <> m <> " (" <> importWhat identInfo <> ")"
396+
397+ (qual, name) = case T.splitOn "." (notInScope thingMissing) of
398+ [n] -> (Nothing, n)
399+ segments -> (Just (T.concat $ init segments), last segments)
400+ importWhat IdentInfo {parent, rendered}
401+ | Just p <- parent = p <> "(" <> rendered <> ")"
402+ | otherwise = rendered
403+
404+canUseIdent :: NotInScope -> IdentInfo -> Bool
405+canUseIdent NotInScopeDataConstructor{} = isDatacon
406+canUseIdent _ = const True
407+
408+data NotInScope
409+ = NotInScopeDataConstructor T.Text
410+ | NotInScopeTypeConstructorOrClass T.Text
411+ | NotInScopeThing T.Text
412+ deriving Show
413+
414+notInScope :: NotInScope -> T.Text
415+notInScope (NotInScopeDataConstructor t) = t
416+notInScope (NotInScopeTypeConstructorOrClass t) = t
417+notInScope (NotInScopeThing t) = t
418+
419+extractNotInScopeName :: T.Text -> Maybe NotInScope
420+extractNotInScopeName x
421+ | Just [name] <- matchRegex x "Data constructor not in scope: ([^ ]+)"
422+ = Just $ NotInScopeDataConstructor name
423+ | Just [name] <- matchRegex x "Not in scope: data constructor [^‘]*‘([^’]*)’"
424+ = Just $ NotInScopeDataConstructor name
425+ | Just [name] <- matchRegex x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"
426+ = Just $ NotInScopeTypeConstructorOrClass name
427+ | Just [name] <- matchRegex x "ot in scope: \\(([^‘ ]+)\\)"
428+ = Just $ NotInScopeThing name
429+ | Just [name] <- matchRegex x "ot in scope: ([^‘ ]+)"
430+ = Just $ NotInScopeThing name
431+ | Just [name] <- matchRegex x "ot in scope:[^‘]*‘([^’]*)’"
432+ = Just $ NotInScopeThing name
433+ | otherwise
434+ = Nothing
435+
436+-------------------------------------------------------------------------------------------------
437+
438+topOfHoleFitsMarker :: T.Text
439+topOfHoleFitsMarker =
440+#if MIN_GHC_API_VERSION(8,6,0)
441+ "Valid hole fits include"
442+#else
443+ "Valid substitutions include"
444+#endif
445+
446+mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit
447+mkRenameEdit contents range name =
448+ if maybeIsInfixFunction == Just True
449+ then TextEdit range ("`" <> name <> "`")
450+ else TextEdit range name
451+ where
452+ maybeIsInfixFunction = do
453+ curr <- textInRange range <$> contents
454+ pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr
455+
456+extractWildCardTypeSignature :: T.Text -> T.Text
457+extractWildCardTypeSignature =
458+ -- inferring when parens are actually needed around the type signature would
459+ -- require understanding both the precedence of the context of the _ and of
460+ -- the signature itself. Inserting them unconditionally is ugly but safe.
461+ ("(" `T.append`) . (`T.append` ")") .
462+ T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') .
463+ snd . T.breakOnEnd "standing for "
464+
465+extractRenamableTerms :: T.Text -> [T.Text]
466+extractRenamableTerms msg
467+ -- Account for both "Variable not in scope" and "Not in scope"
468+ | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg
469+ | otherwise = []
470+ where
471+ extractSuggestions = map getEnclosed
472+ . concatMap singleSuggestions
473+ . filter isKnownSymbol
474+ . T.lines
475+ singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited
476+ isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t
477+ getEnclosed = T.dropWhile (== '‘')
478+ . T.dropWhileEnd (== '’')
479+ . T.dropAround (\c -> c /= '‘' && c /= '’')
480+
481+-- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace
482+-- between the end of the range and the next newline), extend the range to take up the whole line.
483+extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range
484+extendToWholeLineIfPossible contents range@Range{..} =
485+ let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents
486+ extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line
487+ in if extend then Range _start (Position (_line _end + 1) 0) else range
488+
489+splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)
490+splitTextAtPosition (Position row col) x
491+ | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x
492+ , (preCol, postCol) <- T.splitAt col mid
493+ = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)
494+ | otherwise = (x, T.empty)
495+
496+-- | Returns [start .. end[
497+textInRange :: Range -> T.Text -> T.Text
498+textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =
499+ case compare startRow endRow of
500+ LT ->
501+ let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine
502+ (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of
503+ [] -> ("", [])
504+ firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)
505+ maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines
506+ in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)
507+ EQ ->
508+ let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)
509+ in T.take (endCol - startCol) (T.drop startCol line)
510+ GT -> ""
511+ where
512+ linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)
513+
514+-- | Returns the ranges for a binding in an import declaration
515+rangesForBinding :: ImportDecl GhcPs -> String -> [Range]
516+rangesForBinding ImportDecl{ideclHiding = Just (False, L _ lies)} b =
517+ concatMap (map srcSpanToRange . rangesForBinding' b') lies
518+ where
519+ b' = wrapOperatorInParens (unqualify b)
520+
521+ wrapOperatorInParens x = if isAlpha (head x) then x else "(" <> x <> ")"
522+
523+ unqualify x = snd $ breakOnEnd "." x
524+
525+rangesForBinding _ _ = []
526+
527+rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]
528+rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]
529+rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]
530+rangesForBinding' b (L l (IEThingAll x)) | showSDocUnsafe (ppr x) == b = [l]
531+rangesForBinding' b (L l (IEThingWith thing _ inners labels))
532+ | showSDocUnsafe (ppr thing) == b = [l]
533+ | otherwise =
534+ [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] ++
535+ [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b]
536+rangesForBinding' _ _ = []
537+
538+-- | Extends an import list with a new binding.
539+-- Assumes an import statement of the form:
540+-- import (qualified) A (..) ..
541+-- Places the new binding first, preserving whitespace.
542+-- Copes with multi-line import lists
543+addBindingToImportList :: T.Text -> T.Text -> T.Text
544+addBindingToImportList binding importLine = case T.breakOn "(" importLine of
545+ (pre, T.uncons -> Just (_, rest)) ->
546+ case T.uncons (T.dropWhile isSpace rest) of
547+ Just (')', _) -> T.concat [pre, "(", binding, rest]
548+ _ -> T.concat [pre, "(", binding, ", ", rest]
549+ _ ->
550+ error
551+ $ "importLine does not have the expected structure: "
552+ <> T.unpack importLine
553+
554+-- | Returns Just (the submatches) for the first capture, or Nothing.
555+matchRegex :: T.Text -> T.Text -> Maybe [T.Text]
556+matchRegex message regex = case unifySpaces message =~~ regex of
557+ Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings
558+ Nothing -> Nothing
559+
560+setHandlersCodeLens :: PartialHandlers c
561+setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
562+ LSP.codeLensHandler = withResponse RspCodeLens codeLens,
563+ LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
564+ }
565+
566+filterNewlines :: T.Text -> T.Text
567+filterNewlines = T.concat . T.lines
568+
569+unifySpaces :: T.Text -> T.Text
570+unifySpaces = T.unwords . T.words
src/Development/IDE/Plugin/CodeAction/PositionIndexed.hsnew file+112
@@ -0,0 +1,112 @@
1+-- | Position indexed streams of characters
2+module Development.IDE.Plugin.CodeAction.PositionIndexed
3+ ( PositionIndexed
4+ , PositionIndexedString
5+ , indexedByPosition
6+ , indexedByPositionStartingFrom
7+ , extendAllToIncludeCommaIfPossible
8+ , mergeRanges
9+ )
10+where
11+
12+import Data.Char
13+import Data.List
14+import Language.Haskell.LSP.Types
15+
16+type PositionIndexed a = [(Position, a)]
17+
18+type PositionIndexedString = PositionIndexed Char
19+
20+-- | Add position indexing to a String.
21+--
22+-- > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡
23+-- > [ ((0,0),'h')
24+-- > , ((0,1),'e')
25+-- > , ((0,2),'y')
26+-- > , ((0,3),'\n')
27+-- > , ((1,0),' ')
28+-- > , ((1,1),'h')
29+-- > , ((1,2),'o')
30+-- > ]
31+indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString
32+indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where
33+ f (_, []) = Nothing
34+ f (p@(Position l _), '\n' : rest) =
35+ Just ((p, '\n'), (Position (l + 1) 0, rest))
36+ f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest))
37+
38+-- | Add position indexing to a String.
39+--
40+-- > indexedByPosition = indexedByPositionStartingFrom (Position 0 0)
41+indexedByPosition :: String -> PositionIndexedString
42+indexedByPosition = indexedByPositionStartingFrom (Position 0 0)
43+
44+-- | Returns a tuple (before, contents, after) if the range is present.
45+-- The range is present only if both its start and end positions are present
46+unconsRange
47+ :: Range
48+ -> PositionIndexed a
49+ -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a)
50+unconsRange Range {..} indexedString
51+ | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString
52+ , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest
53+ = Just (before, mid, after)
54+ | otherwise
55+ = Nothing
56+
57+-- | Strips out all the positions included in the range.
58+-- Returns 'Nothing' if the start or end of the range are not included in the input.
59+stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a)
60+stripRange r s = case unconsRange r s of
61+ Just (b, _, a) -> Just (b ++ a)
62+ Nothing -> Nothing
63+
64+-- | Returns the smallest possible set of disjoint ranges that is equivalent to the input.
65+-- Assumes input ranges are sorted on the start positions.
66+mergeRanges :: [Range] -> [Range]
67+mergeRanges (r : r' : rest)
68+ |
69+ -- r' is contained in r
70+ _end r > _end r' = mergeRanges (r : rest)
71+ |
72+ -- r and r' are overlapping
73+ _end r > _start r' = mergeRanges (r { _end = _end r' } : rest)
74+
75+ | otherwise = r : mergeRanges (r' : rest)
76+mergeRanges other = other
77+
78+-- | Returns a sorted list of ranges with extended selections including preceding or trailing commas
79+--
80+-- @
81+-- a, |b|, c ===> a|, b|, c
82+-- a, b, |c| ===> a, b|, c|
83+-- a, |b|, |c| ===> a|, b||, c|
84+-- @
85+extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]
86+extendAllToIncludeCommaIfPossible indexedString =
87+ mergeRanges . go indexedString . sortOn _start
88+ where
89+ go _ [] = []
90+ go input (r : rr)
91+ | r' : _ <- extendToIncludeCommaIfPossible input r
92+ , Just input' <- stripRange r' input
93+ = r' : go input' rr
94+ | otherwise
95+ = go input rr
96+
97+extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]
98+extendToIncludeCommaIfPossible indexedString range
99+ | Just (before, _, after) <- unconsRange range indexedString
100+ , after' <- dropWhile (isSpace . snd) after
101+ , before' <- dropWhile (isSpace . snd) (reverse before)
102+ =
103+ -- a, |b|, c ===> a|, b|, c
104+ [ range { _start = start' } | (start', ',') : _ <- [before'] ]
105+ ++
106+ -- a, |b|, c ===> a, |b, |c
107+ [ range { _end = end' }
108+ | (_, ',') : rest <- [after']
109+ , let (end', _) : _ = dropWhile (isSpace . snd) rest
110+ ]
111+ | otherwise
112+ = [range]
src/Development/IDE/Plugin/CodeAction/RuleTypes.hsnew file+61
@@ -0,0 +1,61 @@
1+{-# LANGUAGE TypeFamilies #-}
2+module Development.IDE.Plugin.CodeAction.RuleTypes
3+ (PackageExports(..), PackageExportsMap
4+ ,IdentInfo(..)
5+ ,mkIdentInfos
6+ ) where
7+
8+import Avail (AvailInfo(..))
9+import Data.Hashable (Hashable)
10+import Control.DeepSeq (NFData)
11+import Data.Binary (Binary)
12+import Data.Text (pack, Text)
13+import Development.IDE.GHC.Util
14+import Development.Shake (RuleResult)
15+import Data.HashMap.Strict (HashMap)
16+import Data.Typeable (Typeable)
17+import GHC.Generics (Generic)
18+import Name
19+import FieldLabel (flSelector)
20+
21+type Identifier = Text
22+type ModuleName = Text
23+
24+data IdentInfo = IdentInfo
25+ { name :: !Identifier
26+ , rendered :: Text
27+ , parent :: !(Maybe Text)
28+ , isDatacon :: !Bool
29+ }
30+ deriving (Eq, Generic, Show)
31+
32+instance NFData IdentInfo
33+
34+mkIdentInfos :: AvailInfo -> [IdentInfo]
35+mkIdentInfos (Avail n) =
36+ [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)]
37+mkIdentInfos (AvailTC parent (n:nn) flds)
38+ -- Following the GHC convention that parent == n if parent is exported
39+ | n == parent
40+ = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) True
41+ | n <- nn ++ map flSelector flds
42+ ] ++
43+ [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing False]
44+ where
45+ parentP = pack $ prettyPrint parent
46+
47+mkIdentInfos (AvailTC _ nn flds)
48+ = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing True
49+ | n <- nn ++ map flSelector flds
50+ ]
51+
52+-- Rule type for caching Package Exports
53+type instance RuleResult PackageExports = PackageExportsMap
54+type PackageExportsMap = HashMap Identifier [(IdentInfo,ModuleName)]
55+
56+newtype PackageExports = PackageExports HscEnvEq
57+ deriving (Eq, Show, Typeable, Generic)
58+
59+instance Hashable PackageExports
60+instance NFData PackageExports
61+instance Binary PackageExports
src/Development/IDE/Plugin/CodeAction/Rules.hsnew file+61
@@ -0,0 +1,61 @@
1+module Development.IDE.Plugin.CodeAction.Rules
2+ ( rulePackageExports
3+ )
4+where
5+
6+import Data.HashMap.Strict ( fromListWith )
7+import Data.Text ( Text
8+ , pack
9+ )
10+import Data.Traversable ( forM )
11+import Development.IDE.Core.Rules
12+import Development.IDE.GHC.Util
13+import Development.IDE.Plugin.CodeAction.RuleTypes
14+import Development.Shake
15+import GHC ( DynFlags(pkgState) )
16+import HscTypes ( IfaceExport
17+ , hsc_dflags
18+ , mi_exports
19+ )
20+import LoadIface
21+import Maybes
22+import Module ( Module(..)
23+ , ModuleName
24+ , moduleNameString
25+ )
26+import Packages ( explicitPackages
27+ , exposedModules
28+ , packageConfigId
29+ )
30+import TcRnMonad ( WhereFrom(ImportByUser)
31+ , initIfaceLoad
32+ )
33+
34+rulePackageExports :: Rules ()
35+rulePackageExports = defineNoFile $ \(PackageExports session) -> do
36+ let env = hscEnv session
37+ pkgst = pkgState (hsc_dflags env)
38+ depends = explicitPackages pkgst
39+ targets =
40+ [ (pkg, mn)
41+ | d <- depends
42+ , Just pkg <- [lookupPackageConfig d env]
43+ , (mn, _) <- exposedModules pkg
44+ ]
45+
46+ results <- forM targets $ \(pkg, mn) -> do
47+ modIface <- liftIO $ initIfaceLoad env $ loadInterface
48+ ""
49+ (Module (packageConfigId pkg) mn)
50+ (ImportByUser False)
51+ case modIface of
52+ Failed _err -> return mempty
53+ Succeeded mi -> do
54+ let avails = mi_exports mi
55+ return $ concatMap (unpackAvail mn) avails
56+ return $ fromListWith (++) $ concat results
57+
58+unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])]
59+unpackAvail mod =
60+ map (\id@IdentInfo {..} -> (name, [(id, pack $ moduleNameString mod)]))
61+ . mkIdentInfos
src/Development/IDE/Plugin/Completions.hsnew file+103
@@ -0,0 +1,103 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE TypeFamilies #-}
3+#include "ghc-api-version.h"
4+
5+module Development.IDE.Plugin.Completions(plugin) where
6+
7+import Control.Applicative
8+import Language.Haskell.LSP.Messages
9+import Language.Haskell.LSP.Types
10+import qualified Language.Haskell.LSP.Core as LSP
11+import qualified Language.Haskell.LSP.VFS as VFS
12+import Language.Haskell.LSP.Types.Capabilities
13+import Development.Shake.Classes
14+import Development.Shake
15+import GHC.Generics
16+
17+import Development.IDE.Plugin
18+import Development.IDE.Core.Service
19+import Development.IDE.Plugin.Completions.Logic
20+import Development.IDE.Types.Location
21+import Development.IDE.Core.PositionMapping
22+import Development.IDE.Core.RuleTypes
23+import Development.IDE.Core.Shake
24+import Development.IDE.GHC.Util
25+import Development.IDE.LSP.Server
26+
27+#if !MIN_GHC_API_VERSION(8,6,0) || defined(GHC_LIB)
28+import Data.Maybe
29+import Development.IDE.Import.DependencyInformation
30+#endif
31+
32+plugin :: Plugin c
33+plugin = Plugin produceCompletions setHandlersCompletion
34+
35+produceCompletions :: Rules ()
36+produceCompletions =
37+ define $ \ProduceCompletions file -> do
38+
39+-- When possible, rely on the haddocks embedded in our interface files
40+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'
41+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
42+ let parsedDeps = []
43+#else
44+ deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
45+ parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)
46+#endif
47+ tm <- fmap fst <$> useWithStale TypeCheck file
48+ packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file
49+ case (tm, packageState) of
50+ (Just tm', Just packageState') -> do
51+ cdata <- liftIO $ cacheDataProducer packageState'
52+ (tmrModule tm') parsedDeps
53+ return ([], Just cdata)
54+ _ -> return ([], Nothing)
55+
56+
57+-- | Produce completions info for a file
58+type instance RuleResult ProduceCompletions = CachedCompletions
59+
60+data ProduceCompletions = ProduceCompletions
61+ deriving (Eq, Show, Typeable, Generic)
62+instance Hashable ProduceCompletions
63+instance NFData ProduceCompletions
64+instance Binary ProduceCompletions
65+
66+
67+-- | Generate code actions.
68+getCompletionsLSP
69+ :: LSP.LspFuncs c
70+ -> IdeState
71+ -> CompletionParams
72+ -> IO (Either ResponseError CompletionResponseResult)
73+getCompletionsLSP lsp ide
74+ CompletionParams{_textDocument=TextDocumentIdentifier uri
75+ ,_position=position
76+ ,_context=completionContext} = do
77+ contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
78+ fmap Right $ case (contents, uriToFilePath' uri) of
79+ (Just cnts, Just path) -> do
80+ let npath = toNormalizedFilePath' path
81+ (ideOpts, compls) <- runAction ide $ do
82+ opts <- getIdeOptions
83+ compls <- useWithStale ProduceCompletions npath
84+ pm <- useWithStale GetParsedModule npath
85+ pure (opts, liftA2 (,) compls pm)
86+ case compls of
87+ Just ((cci', _), (pm, mapping)) -> do
88+ let !position' = fromCurrentPosition mapping position
89+ pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'
90+ case (pfix, completionContext) of
91+ (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
92+ -> return (Completions $ List [])
93+ (Just pfix', _) -> do
94+ let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing
95+ Completions . List <$> getCompletions ideOpts cci' pm pfix' fakeClientCapabilities (WithSnippets True)
96+ _ -> return (Completions $ List [])
97+ _ -> return (Completions $ List [])
98+ _ -> return (Completions $ List [])
99+
100+setHandlersCompletion :: PartialHandlers c
101+setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{
102+ LSP.completionHandler = withResponse RspCompletion getCompletionsLSP
103+ }
src/Development/IDE/Plugin/Completions/Logic.hsnew file+530
@@ -0,0 +1,530 @@
1+{-# LANGUAGE CPP #-}
2+#include "ghc-api-version.h"
3+-- Mostly taken from "haskell-ide-engine"
4+module Development.IDE.Plugin.Completions.Logic (
5+ CachedCompletions
6+, cacheDataProducer
7+, WithSnippets(..)
8+,getCompletions
9+) where
10+
11+import Control.Applicative
12+import Data.Char (isSpace, isUpper)
13+import Data.Generics
14+import Data.List.Extra as List hiding (stripPrefix)
15+import qualified Data.Map as Map
16+import Data.Maybe (fromMaybe, mapMaybe)
17+import qualified Data.Text as T
18+import qualified Text.Fuzzy as Fuzzy
19+
20+import GHC
21+import HscTypes
22+import Name
23+import RdrName
24+import TcRnTypes
25+import Type
26+import Var
27+import Packages
28+import DynFlags
29+#if MIN_GHC_API_VERSION(8,10,0)
30+import Predicate (isDictTy)
31+import GHC.Platform
32+import Pair
33+import Coercion
34+#endif
35+
36+import Language.Haskell.LSP.Types
37+import Language.Haskell.LSP.Types.Capabilities
38+import qualified Language.Haskell.LSP.VFS as VFS
39+import Development.IDE.Plugin.Completions.Types
40+import Development.IDE.Spans.Documentation
41+import Development.IDE.GHC.Error
42+import Development.IDE.Types.Options
43+import Development.IDE.Spans.Common
44+import Development.IDE.GHC.Util
45+
46+-- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs
47+
48+-- | A context of a declaration in the program
49+-- e.g. is the declaration a type declaration or a value declaration
50+-- Used for determining which code completions to show
51+-- TODO: expand this with more contexts like classes or instances for
52+-- smarter code completion
53+data Context = TypeContext
54+ | ValueContext
55+ | ModuleContext String -- ^ module context with module name
56+ | ImportContext String -- ^ import context with module name
57+ | ImportListContext String -- ^ import list context with module name
58+ | ImportHidingContext String -- ^ import hiding context with module name
59+ | ExportContext -- ^ List of exported identifiers from the current module
60+ deriving (Show, Eq)
61+
62+-- | Generates a map of where the context is a type and where the context is a value
63+-- i.e. where are the value decls and the type decls
64+getCContext :: Position -> ParsedModule -> Maybe Context
65+getCContext pos pm
66+ | Just (L r modName) <- moduleHeader
67+ , pos `isInsideSrcSpan` r
68+ = Just (ModuleContext (moduleNameString modName))
69+
70+ | Just (L r _) <- exportList
71+ , pos `isInsideSrcSpan` r
72+ = Just ExportContext
73+
74+ | Just ctx <- something (Nothing `mkQ` go `extQ` goInline) decl
75+ = Just ctx
76+
77+ | Just ctx <- something (Nothing `mkQ` importGo) imports
78+ = Just ctx
79+
80+ | otherwise
81+ = Nothing
82+
83+ where decl = hsmodDecls $ unLoc $ pm_parsed_source pm
84+ moduleHeader = hsmodName $ unLoc $ pm_parsed_source pm
85+ exportList = hsmodExports $ unLoc $ pm_parsed_source pm
86+ imports = hsmodImports $ unLoc $ pm_parsed_source pm
87+
88+ go :: LHsDecl GhcPs -> Maybe Context
89+ go (L r SigD {})
90+ | pos `isInsideSrcSpan` r = Just TypeContext
91+ | otherwise = Nothing
92+ go (L r GHC.ValD {})
93+ | pos `isInsideSrcSpan` r = Just ValueContext
94+ | otherwise = Nothing
95+ go _ = Nothing
96+
97+ goInline :: GHC.LHsType GhcPs -> Maybe Context
98+ goInline (GHC.L r _)
99+ | pos `isInsideSrcSpan` r = Just TypeContext
100+ goInline _ = Nothing
101+
102+ importGo :: GHC.LImportDecl GhcPs -> Maybe Context
103+ importGo (L r impDecl)
104+ | pos `isInsideSrcSpan` r
105+ = importInline importModuleName (ideclHiding impDecl)
106+ <|> Just (ImportContext importModuleName)
107+
108+ | otherwise = Nothing
109+ where importModuleName = moduleNameString $ unLoc $ ideclName impDecl
110+
111+ importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context
112+ importInline modName (Just (True, L r _))
113+ | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName
114+ | otherwise = Nothing
115+ importInline modName (Just (False, L r _))
116+ | pos `isInsideSrcSpan` r = Just $ ImportListContext modName
117+ | otherwise = Nothing
118+ importInline _ _ = Nothing
119+
120+occNameToComKind :: Maybe T.Text -> OccName -> CompletionItemKind
121+occNameToComKind ty oc
122+ | isVarOcc oc = case occNameString oc of
123+ i:_ | isUpper i -> CiConstructor
124+ _ -> CiFunction
125+ | isTcOcc oc = case ty of
126+ Just t
127+ | "Constraint" `T.isSuffixOf` t
128+ -> CiClass
129+ _ -> CiStruct
130+ | isDataOcc oc = CiConstructor
131+ | otherwise = CiVariable
132+
133+mkCompl :: IdeOptions -> CompItem -> CompletionItem
134+mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} =
135+ CompletionItem label kind (List []) ((colon <>) <$> typeText)
136+ (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')
137+ Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
138+ Nothing Nothing Nothing Nothing Nothing
139+ where kind = Just $ occNameToComKind typeText $ occName origName
140+ insertText = case isInfix of
141+ Nothing -> case getArgText <$> thingType of
142+ Nothing -> label
143+ Just argText -> label <> " " <> argText
144+ Just LeftSide -> label <> "`"
145+
146+ Just Surrounded -> label
147+ typeText
148+ | Just t <- thingType = Just . stripForall $ T.pack (showGhc t)
149+ | otherwise = Nothing
150+ docs' = ("*Defined in '" <> importedFrom <> "'*\n") : spanDocToMarkdown docs
151+ colon = if optNewColonConvention then ": " else ":: "
152+
153+stripForall :: T.Text -> T.Text
154+stripForall t
155+ | T.isPrefixOf "forall" t =
156+ -- We drop 2 to remove the '.' and the space after it
157+ T.drop 2 (T.dropWhile (/= '.') t)
158+ | otherwise = t
159+
160+getArgText :: Type -> T.Text
161+getArgText typ = argText
162+ where
163+ argTypes = getArgs typ
164+ argText :: T.Text
165+ argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes
166+ snippet :: Int -> Type -> T.Text
167+ snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"
168+ getArgs :: Type -> [Type]
169+ getArgs t
170+ | isPredTy t = []
171+ | isDictTy t = []
172+ | isForAllTy t = getArgs $ snd (splitForAllTys t)
173+ | isFunTy t =
174+ let (args, ret) = splitFunTys t
175+ in if isForAllTy ret
176+ then getArgs ret
177+ else Prelude.filter (not . isDictTy) args
178+ | isPiTy t = getArgs $ snd (splitPiTys t)
179+#if MIN_GHC_API_VERSION(8,10,0)
180+ | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t
181+ = getArgs t
182+#else
183+ | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t)
184+#endif
185+ | otherwise = []
186+
187+mkModCompl :: T.Text -> CompletionItem
188+mkModCompl label =
189+ CompletionItem label (Just CiModule) (List []) Nothing
190+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing
191+ Nothing Nothing Nothing Nothing Nothing
192+
193+mkImportCompl :: T.Text -> T.Text -> CompletionItem
194+mkImportCompl enteredQual label =
195+ CompletionItem m (Just CiModule) (List []) (Just label)
196+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing
197+ Nothing Nothing Nothing Nothing Nothing
198+ where
199+ m = fromMaybe "" (T.stripPrefix enteredQual label)
200+
201+mkExtCompl :: T.Text -> CompletionItem
202+mkExtCompl label =
203+ CompletionItem label (Just CiKeyword) (List []) Nothing
204+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing
205+ Nothing Nothing Nothing Nothing Nothing
206+
207+mkPragmaCompl :: T.Text -> T.Text -> CompletionItem
208+mkPragmaCompl label insertText =
209+ CompletionItem label (Just CiKeyword) (List []) Nothing
210+ Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
211+ Nothing Nothing Nothing Nothing Nothing
212+
213+cacheDataProducer :: HscEnv -> TypecheckedModule -> [ParsedModule] -> IO CachedCompletions
214+cacheDataProducer packageState tm deps = do
215+ let parsedMod = tm_parsed_module tm
216+ dflags = hsc_dflags packageState
217+ curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod
218+ Just (_,limports,_,_) = tm_renamed_source tm
219+
220+ iDeclToModName :: ImportDecl name -> ModuleName
221+ iDeclToModName = unLoc . ideclName
222+
223+ showModName :: ModuleName -> T.Text
224+ showModName = T.pack . moduleNameString
225+
226+ asNamespace :: ImportDecl name -> ModuleName
227+ asNamespace imp = maybe (iDeclToModName imp) GHC.unLoc (ideclAs imp)
228+ -- Full canonical names of imported modules
229+ importDeclerations = map unLoc limports
230+
231+ -- The list of all importable Modules from all packages
232+ moduleNames = map showModName (listVisibleModuleNames dflags)
233+
234+ -- The given namespaces for the imported modules (ie. full name, or alias if used)
235+ allModNamesAsNS = map (showModName . asNamespace) importDeclerations
236+
237+ typeEnv = tcg_type_env $ fst $ tm_internals_ tm
238+ rdrEnv = tcg_rdr_env $ fst $ tm_internals_ tm
239+ rdrElts = globalRdrEnvElts rdrEnv
240+
241+ foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b
242+ foldMapM f xs = foldr step return xs mempty where
243+ step x r z = f x >>= \y -> r $! z `mappend` y
244+
245+ getCompls :: [GlobalRdrElt] -> IO ([CompItem],QualCompls)
246+ getCompls = foldMapM getComplsForOne
247+
248+ getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls)
249+ getComplsForOne (GRE n _ True _) =
250+ case lookupTypeEnv typeEnv n of
251+ Just tt -> case safeTyThingId tt of
252+ Just var -> (\x -> ([x],mempty)) <$> varToCompl var
253+ Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n
254+ Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n
255+ getComplsForOne (GRE n _ False prov) =
256+ flip foldMapM (map is_decl prov) $ \spec -> do
257+ compItem <- toCompItem (is_mod spec) n
258+ let unqual
259+ | is_qual spec = []
260+ | otherwise = [compItem]
261+ qual
262+ | is_qual spec = Map.singleton asMod [compItem]
263+ | otherwise = Map.fromList [(asMod,[compItem]),(origMod,[compItem])]
264+ asMod = showModName (is_as spec)
265+ origMod = showModName (is_mod spec)
266+ return (unqual,QualCompls qual)
267+
268+ varToCompl :: Var -> IO CompItem
269+ varToCompl var = do
270+ let typ = Just $ varType var
271+ name = Var.varName var
272+ label = T.pack $ showGhc name
273+ docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) name
274+ return $ CI name (showModName curMod) typ label Nothing docs
275+
276+ toCompItem :: ModuleName -> Name -> IO CompItem
277+ toCompItem mn n = do
278+ docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) n
279+-- lookupName uses runInteractiveHsc, i.e., GHCi stuff which does not work with GHCi
280+-- and leads to fun errors like "Cannot continue after interface file error".
281+#ifdef GHC_LIB
282+ let ty = Right Nothing
283+#else
284+ ty <- evalGhcEnv packageState $ catchSrcErrors "completion" $ do
285+ name' <- lookupName n
286+ return $ name' >>= safeTyThingType
287+#endif
288+ return $ CI n (showModName mn) (either (const Nothing) id ty) (T.pack $ showGhc n) Nothing docs
289+
290+ (unquals,quals) <- getCompls rdrElts
291+
292+ return $ CC
293+ { allModNamesAsNS = allModNamesAsNS
294+ , unqualCompls = unquals
295+ , qualCompls = quals
296+ , importableModules = moduleNames
297+ }
298+
299+newtype WithSnippets = WithSnippets Bool
300+
301+toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem
302+toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x
303+ | with && supported = x
304+ | otherwise = x { _insertTextFormat = Just PlainText
305+ , _insertText = Nothing
306+ }
307+ where supported = Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)
308+
309+-- | Returns the cached completions for the given module and position.
310+getCompletions :: IdeOptions -> CachedCompletions -> ParsedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]
311+getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }
312+ pm prefixInfo caps withSnippets = do
313+ let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo
314+ enteredQual = if T.null prefixModule then "" else prefixModule <> "."
315+ fullPrefix = enteredQual <> prefixText
316+
317+ {- correct the position by moving 'foo :: Int -> String -> '
318+ ^
319+ to 'foo :: Int -> String -> '
320+ ^
321+ -}
322+ pos =
323+ let Position l c = VFS.cursorPos prefixInfo
324+ typeStuff = [isSpace, (`elem` (">-." :: String))]
325+ stripTypeStuff = T.dropWhileEnd (\x -> any (\f -> f x) typeStuff)
326+ -- if oldPos points to
327+ -- foo -> bar -> baz
328+ -- ^
329+ -- Then only take the line up to there, discard '-> bar -> baz'
330+ partialLine = T.take c fullLine
331+ -- drop characters used when writing incomplete type sigs
332+ -- like '-> '
333+ d = T.length fullLine - T.length (stripTypeStuff partialLine)
334+ in Position l (c - d)
335+
336+ filtModNameCompls =
337+ map mkModCompl
338+ $ mapMaybe (T.stripPrefix enteredQual)
339+ $ Fuzzy.simpleFilter fullPrefix allModNamesAsNS
340+
341+ filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False
342+ where
343+ isTypeCompl = isTcOcc . occName . origName
344+ -- completions specific to the current context
345+ ctxCompls' = case getCContext pos pm of
346+ Nothing -> compls
347+ Just TypeContext -> filter isTypeCompl compls
348+ Just ValueContext -> filter (not . isTypeCompl) compls
349+ Just _ -> filter (not . isTypeCompl) compls
350+ -- Add whether the text to insert has backticks
351+ ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'
352+
353+ infixCompls :: Maybe Backtick
354+ infixCompls = isUsedAsInfix fullLine prefixModule prefixText (VFS.cursorPos prefixInfo)
355+
356+ compls = if T.null prefixModule
357+ then unqualCompls
358+ else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls
359+
360+ filtListWith f list =
361+ [ f label
362+ | label <- Fuzzy.simpleFilter fullPrefix list
363+ , enteredQual `T.isPrefixOf` label
364+ ]
365+
366+ filtListWithSnippet f list suffix =
367+ [ toggleSnippets caps withSnippets (f label (snippet <> suffix))
368+ | (snippet, label) <- list
369+ , Fuzzy.test fullPrefix label
370+ ]
371+
372+ filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
373+ filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas
374+ filtOptsCompls = filtListWith mkExtCompl
375+ filtKeywordCompls
376+ | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)
377+ | otherwise = []
378+
379+ stripLeading :: Char -> String -> String
380+ stripLeading _ [] = []
381+ stripLeading c (s:ss)
382+ | s == c = ss
383+ | otherwise = s:ss
384+
385+ result
386+ | "import " `T.isPrefixOf` fullLine
387+ = filtImportCompls
388+ | "{-# language" `T.isPrefixOf` T.toLower fullLine
389+ = filtOptsCompls languagesAndExts
390+ | "{-# options_ghc" `T.isPrefixOf` T.toLower fullLine
391+ = filtOptsCompls (map (T.pack . stripLeading '-') $ flagsForCompletion False)
392+ | "{-# " `T.isPrefixOf` fullLine
393+ = filtPragmaCompls (pragmaSuffix fullLine)
394+ | otherwise
395+ = filtModNameCompls ++ map (toggleSnippets caps withSnippets
396+ . mkCompl ideOpts . stripAutoGenerated) filtCompls
397+ ++ filtKeywordCompls
398+
399+ return result
400+
401+-- The supported languages and extensions
402+languagesAndExts :: [T.Text]
403+#if MIN_GHC_API_VERSION(8,10,0)
404+languagesAndExts = map T.pack $ DynFlags.supportedLanguagesAndExtensions ( PlatformMini ArchUnknown OSUnknown )
405+#else
406+languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions
407+#endif
408+
409+-- ---------------------------------------------------------------------
410+-- helper functions for pragmas
411+-- ---------------------------------------------------------------------
412+
413+validPragmas :: [(T.Text, T.Text)]
414+validPragmas =
415+ [ ("LANGUAGE ${1:extension}" , "LANGUAGE")
416+ , ("OPTIONS_GHC -${1:option}" , "OPTIONS_GHC")
417+ , ("INLINE ${1:function}" , "INLINE")
418+ , ("NOINLINE ${1:function}" , "NOINLINE")
419+ , ("INLINABLE ${1:function}" , "INLINABLE")
420+ , ("WARNING ${1:message}" , "WARNING")
421+ , ("DEPRECATED ${1:message}" , "DEPRECATED")
422+ , ("ANN ${1:annotation}" , "ANN")
423+ , ("RULES" , "RULES")
424+ , ("SPECIALIZE ${1:function}" , "SPECIALIZE")
425+ , ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE")
426+ ]
427+
428+pragmaSuffix :: T.Text -> T.Text
429+pragmaSuffix fullLine
430+ | "}" `T.isSuffixOf` fullLine = mempty
431+ | otherwise = " #-}"
432+
433+-- ---------------------------------------------------------------------
434+-- helper functions for infix backticks
435+-- ---------------------------------------------------------------------
436+
437+hasTrailingBacktick :: T.Text -> Position -> Bool
438+hasTrailingBacktick line Position { _character }
439+ | T.length line > _character = (line `T.index` _character) == '`'
440+ | otherwise = False
441+
442+isUsedAsInfix :: T.Text -> T.Text -> T.Text -> Position -> Maybe Backtick
443+isUsedAsInfix line prefixMod prefixText pos
444+ | hasClosingBacktick && hasOpeningBacktick = Just Surrounded
445+ | hasOpeningBacktick = Just LeftSide
446+ | otherwise = Nothing
447+ where
448+ hasOpeningBacktick = openingBacktick line prefixMod prefixText pos
449+ hasClosingBacktick = hasTrailingBacktick line pos
450+
451+openingBacktick :: T.Text -> T.Text -> T.Text -> Position -> Bool
452+openingBacktick line prefixModule prefixText Position { _character }
453+ | backtickIndex < 0 = False
454+ | otherwise = (line `T.index` backtickIndex) == '`'
455+ where
456+ backtickIndex :: Int
457+ backtickIndex =
458+ let
459+ prefixLength = T.length prefixText
460+ moduleLength = if prefixModule == ""
461+ then 0
462+ else T.length prefixModule + 1 {- Because of "." -}
463+ in
464+ -- Points to the first letter of either the module or prefix text
465+ _character - (prefixLength + moduleLength) - 1
466+
467+
468+-- ---------------------------------------------------------------------
469+
470+-- | Under certain circumstance GHC generates some extra stuff that we
471+-- don't want in the autocompleted symbols
472+stripAutoGenerated :: CompItem -> CompItem
473+stripAutoGenerated ci =
474+ ci {label = stripPrefix (label ci)}
475+ {- When e.g. DuplicateRecordFields is enabled, compiler generates
476+ names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors
477+ https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation
478+ -}
479+
480+-- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace.
481+
482+stripPrefix :: T.Text -> T.Text
483+stripPrefix name = T.takeWhile (/=':') $ go prefixes
484+ where
485+ go [] = name
486+ go (p:ps)
487+ | T.isPrefixOf p name = T.drop (T.length p) name
488+ | otherwise = go ps
489+
490+-- | Prefixes that can occur in a GHC OccName
491+prefixes :: [T.Text]
492+prefixes =
493+ [
494+ -- long ones
495+ "$con2tag_"
496+ , "$tag2con_"
497+ , "$maxtag_"
498+
499+ -- four chars
500+ , "$sel:"
501+ , "$tc'"
502+
503+ -- three chars
504+ , "$dm"
505+ , "$co"
506+ , "$tc"
507+ , "$cp"
508+ , "$fx"
509+
510+ -- two chars
511+ , "$W"
512+ , "$w"
513+ , "$m"
514+ , "$b"
515+ , "$c"
516+ , "$d"
517+ , "$i"
518+ , "$s"
519+ , "$f"
520+ , "$r"
521+ , "C:"
522+ , "N:"
523+ , "D:"
524+ , "$p"
525+ , "$L"
526+ , "$f"
527+ , "$t"
528+ , "$c"
529+ , "$m"
530+ ]
src/Development/IDE/Plugin/Completions/Types.hsnew file+58
@@ -0,0 +1,58 @@
1+module Development.IDE.Plugin.Completions.Types (
2+ module Development.IDE.Plugin.Completions.Types
3+) where
4+
5+import Control.DeepSeq
6+import qualified Data.Map as Map
7+import qualified Data.Text as T
8+import GHC
9+
10+import Development.IDE.Spans.Common
11+
12+-- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs
13+
14+data Backtick = Surrounded | LeftSide deriving Show
15+data CompItem = CI
16+ { origName :: Name -- ^ Original name, such as Maybe, //, or find.
17+ , importedFrom :: T.Text -- ^ From where this item is imported from.
18+ , thingType :: Maybe Type -- ^ Available type information.
19+ , label :: T.Text -- ^ Label to display to the user.
20+ , isInfix :: Maybe Backtick -- ^ Did the completion happen
21+ -- in the context of an infix notation.
22+ , docs :: SpanDoc -- ^ Available documentation.
23+ }
24+instance Show CompItem where
25+ show CI { .. } = "CompItem { origName = \"" ++ showGhc origName ++ "\""
26+ ++ ", importedFrom = " ++ show importedFrom
27+ ++ ", thingType = " ++ show (fmap showGhc thingType)
28+ ++ ", label = " ++ show label
29+ ++ ", isInfix = " ++ show isInfix
30+ ++ ", docs = " ++ show docs
31+ ++ " } "
32+instance Eq CompItem where
33+ ci1 == ci2 = origName ci1 == origName ci2
34+instance Ord CompItem where
35+ compare ci1 ci2 = origName ci1 `compare` origName ci2
36+
37+-- Associates a module's qualifier with its members
38+newtype QualCompls
39+ = QualCompls { getQualCompls :: Map.Map T.Text [CompItem] }
40+ deriving Show
41+instance Semigroup QualCompls where
42+ (QualCompls a) <> (QualCompls b) = QualCompls $ Map.unionWith (++) a b
43+instance Monoid QualCompls where
44+ mempty = QualCompls Map.empty
45+ mappend = (Prelude.<>)
46+
47+-- | End result of the completions
48+data CachedCompletions = CC
49+ { allModNamesAsNS :: [T.Text] -- ^ All module names in scope.
50+ -- Prelude is a single module
51+ , unqualCompls :: [CompItem] -- ^ All Possible completion items
52+ , qualCompls :: QualCompls -- ^ Completion items associated to
53+ -- to a specific module name.
54+ , importableModules :: [T.Text] -- ^ All modules that may be imported.
55+ } deriving Show
56+
57+instance NFData CachedCompletions where
58+ rnf = rwhnf
src/Development/IDE/Spans/AtPoint.hs+87−53
@@ -8,26 +8,24 @@ module Development.IDE.Spans.AtPoint (
8 , gotoDefinition
8 , gotoDefinition
9 ) where
9 ) where
10
10
11−import Development.IDE.Spans.Documentation
12import Development.IDE.GHC.Error
11import Development.IDE.GHC.Error
13import Development.IDE.GHC.Orphans()
12import Development.IDE.GHC.Orphans()
14import Development.IDE.Types.Location
13import Development.IDE.Types.Location
15
14
16-- DAML compiler and infrastructure
15-- DAML compiler and infrastructure
17−import Development.Shake
18−import Development.IDE.GHC.Util
19import Development.IDE.GHC.Compat
16import Development.IDE.GHC.Compat
20import Development.IDE.Types.Options
17import Development.IDE.Types.Options
21−import Development.IDE.Spans.Type as SpanInfo
18+import Development.IDE.Spans.Type as SpanInfo
19+import Development.IDE.Spans.Common (spanDocToMarkdown)
22
20
23-- GHC API imports
21-- GHC API imports
24−import Avail
25−import GHC
26import DynFlags
22import DynFlags
27import FastString
23import FastString
28import Name
24import Name
29import Outputable hiding ((<>))
25import Outputable hiding ((<>))
30import SrcLoc
26import SrcLoc
27+import Type
28+import VarSet
31
29
32import Control.Monad.Extra
30import Control.Monad.Extra
33import Control.Monad.Trans.Maybe
31import Control.Monad.Trans.Maybe
@@ -39,98 +37,134 @@ import qualified Data.Text as T
39-- | Locate the definition of the name at a given position.
37-- | Locate the definition of the name at a given position.
40gotoDefinition
38gotoDefinition
41 :: MonadIO m
39 :: MonadIO m
42− => (FilePath -> m (Maybe HieFile))
40+ => (Module -> m (Maybe (HieFile, FilePath)))
43 -> IdeOptions
41 -> IdeOptions
44− -> HscEnv
45 -> [SpanInfo]
42 -> [SpanInfo]
46 -> Position
43 -> Position
47 -> m (Maybe Location)
44 -> m (Maybe Location)
48−gotoDefinition getHieFile ideOpts pkgState srcSpans pos =
45+gotoDefinition getHieFile ideOpts srcSpans pos =
49− listToMaybe <$> locationsAtPoint getHieFile ideOpts pkgState pos srcSpans
46+ listToMaybe <$> locationsAtPoint getHieFile ideOpts pos srcSpans
50
47
51-- | Synopsis for the name at a given position.
48-- | Synopsis for the name at a given position.
52atPoint
49atPoint
53 :: IdeOptions
50 :: IdeOptions
54− -> [TypecheckedModule]
51+ -> SpansInfo
55− -> [SpanInfo]
56 -> Position
52 -> Position
57 -> Maybe (Maybe Range, [T.Text])
53 -> Maybe (Maybe Range, [T.Text])
58−atPoint IdeOptions{..} tcs srcSpans pos = do
54+atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do
59− SpanInfo{..} <- listToMaybe $ orderSpans $ spansAtPoint pos srcSpans
55+ firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans
60− ty <- spaninfoType
56+ let constraintsAtPoint = mapMaybe spaninfoType (spansAtPoint pos cntsSpans)
61− let mbName = getNameM spaninfoSource
62− mbDefinedAt = fmap (\name -> "**Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "**\n") mbName
63− docInfo = maybe [] (\name -> getDocumentation name tcs) mbName
64− range = Range
65− (Position spaninfoStartLine spaninfoStartCol)
66− (Position spaninfoEndLine spaninfoEndCol)
67− colon = if optNewColonConvention then ":" else "::"
68− wrapLanguageSyntax x = T.unlines [ "```" <> T.pack optLanguageSyntax, x, "```"]
69− typeSig = wrapLanguageSyntax $ case mbName of
70− Nothing -> colon <> " " <> showName ty
71− Just name ->
72− let modulePrefix = maybe "" (<> ".") (getModuleNameAsText name)
73− in modulePrefix <> showName name <> "\n " <> colon <> " " <> showName ty
74− hoverInfo = docInfo <> [typeSig] <> maybeToList mbDefinedAt
75− return (Just range, hoverInfo)
57+ return (Just (range firstSpan), hoverInfo firstSpan constraintsAtPoint)
76 where
58 where
59+ -- Hover info for types, classes, type variables
60+ hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs , ..} _ =
61+ (wrapLanguageSyntax <$> name) <> location <> spanDocToMarkdown docs
62+ where
63+ name = [maybe shouldNotHappen showName mbName]
64+ location = [maybe shouldNotHappen definedAt mbName]
65+ shouldNotHappen = "ghcide: did not expect a type level component without a name"
66+ mbName = getNameM spaninfoSource
67+
68+ -- Hover info for values/data
69+ hoverInfo SpanInfo{spaninfoType = (Just typ), spaninfoDocs = docs , ..} cnts =
70+ (wrapLanguageSyntax <$> nameOrSource) <> location <> spanDocToMarkdown docs
71+ where
72+ mbName = getNameM spaninfoSource
73+ expr = case spaninfoSource of
74+ Named n -> qualifyNameIfPossible n
75+ Lit l -> crop $ T.pack l
76+ _ -> ""
77+ nameOrSource = [expr <> "\n" <> typeAnnotation]
78+ qualifyNameIfPossible name' = modulePrefix <> showName name'
79+ where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')
80+ location = [maybe "" definedAt mbName]
81+
82+ thisFVs = tyCoVarsOfType typ
83+ constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts
84+ constraintsT = T.intercalate ", " (map showName constraintsOverFVs)
85+
86+ typeAnnotation = case constraintsOverFVs of
87+ [] -> colon <> showName typ
88+ [_] -> colon <> constraintsT <> "\n=> " <> showName typ
89+ _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ
90+
91+ definedAt name = "*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*\n"
92+
93+ crop txt
94+ | T.length txt > 50 = T.take 46 txt <> " ..."
95+ | otherwise = txt
96+
97+ range SpanInfo{..} = Range
98+ (Position spaninfoStartLine spaninfoStartCol)
99+ (Position spaninfoEndLine spaninfoEndCol)
100+
101+ colon = if optNewColonConvention then ": " else ":: "
102+ wrapLanguageSyntax x = T.unlines [ "```" <> T.pack optLanguageSyntax, x, "```"]
103+
77 -- NOTE(RJR): This is a bit hacky.
104 -- NOTE(RJR): This is a bit hacky.
78 -- We don't want to show the user type signatures generated from Eq and Show
105 -- We don't want to show the user type signatures generated from Eq and Show
79 -- instances, as they do not appear in the source program.
106 -- instances, as they do not appear in the source program.
80 -- However the user could have written an `==` or `show` function directly,
107 -- However the user could have written an `==` or `show` function directly,
81 -- in which case we still want to show information for that.
108 -- in which case we still want to show information for that.
82 -- Hence we just move such information later in the list of spans.
109 -- Hence we just move such information later in the list of spans.
83− orderSpans :: [SpanInfo] -> [SpanInfo]
110+ deEmpasizeGeneratedEqShow :: [SpanInfo] -> [SpanInfo]
84− orderSpans = uncurry (++) . partition (not . isTypeclassDeclSpan)
111+ deEmpasizeGeneratedEqShow = uncurry (++) . partition (not . isTypeclassDeclSpan)
85 isTypeclassDeclSpan :: SpanInfo -> Bool
112 isTypeclassDeclSpan :: SpanInfo -> Bool
86 isTypeclassDeclSpan spanInfo =
113 isTypeclassDeclSpan spanInfo =
87 case getNameM (spaninfoSource spanInfo) of
114 case getNameM (spaninfoSource spanInfo) of
88 Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]
115 Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]
89 Nothing -> False
116 Nothing -> False
90
117
91−locationsAtPoint :: forall m . MonadIO m => (FilePath -> m (Maybe HieFile)) -> IdeOptions -> HscEnv -> Position -> [SpanInfo] -> m [Location]
118+locationsAtPoint
119+ :: forall m
120+ . MonadIO m
121+ => (Module -> m (Maybe (HieFile, FilePath)))
122+ -> IdeOptions
123+ -> Position
124+ -> [SpanInfo]
125+ -> m [Location]
92−locationsAtPoint getHieFile IdeOptions{..} pkgState pos =
126+locationsAtPoint getHieFile _ideOptions pos =
93− fmap (map srcSpanToLocation) .
94− mapMaybeM (getSpan . spaninfoSource) .
127+ fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos
95− spansAtPoint pos
96 where getSpan :: SpanSource -> m (Maybe SrcSpan)
128 where getSpan :: SpanSource -> m (Maybe SrcSpan)
97 getSpan NoSource = pure Nothing
129 getSpan NoSource = pure Nothing
98 getSpan (SpanS sp) = pure $ Just sp
130 getSpan (SpanS sp) = pure $ Just sp
131+ getSpan (Lit _) = pure Nothing
99 getSpan (Named name) = case nameSrcSpan name of
132 getSpan (Named name) = case nameSrcSpan name of
100 sp@(RealSrcSpan _) -> pure $ Just sp
133 sp@(RealSrcSpan _) -> pure $ Just sp
101 sp@(UnhelpfulSpan _) -> runMaybeT $ do
134 sp@(UnhelpfulSpan _) -> runMaybeT $ do
102 guard (sp /= wiredInSrcSpan)
135 guard (sp /= wiredInSrcSpan)
103− -- This case usually arises when the definition is in an external package.
136+ -- This case usually arises when the definition is in an external package (DAML only).
104 -- In this case the interface files contain garbage source spans
137 -- In this case the interface files contain garbage source spans
105 -- so we instead read the .hie files to get useful source spans.
138 -- so we instead read the .hie files to get useful source spans.
106− let mod = nameModule name
139+ mod <- MaybeT $ return $ nameModule_maybe name
107− let unitId = moduleUnitId mod
108− pkgConfig <- MaybeT $ pure $ lookupPackageConfig unitId pkgState
109− hiePath <- MaybeT $ liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod
110− hieFile <- MaybeT $ getHieFile hiePath
140+ (hieFile, srcPath) <- MaybeT $ getHieFile mod
111− avail <- MaybeT $ pure $ listToMaybe (filterAvails (eqName name) $ hie_exports hieFile)
141+ avail <- MaybeT $ pure $ find (eqName name . snd) $ hieExportNames hieFile
112− srcPath <- MaybeT $ liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod
113 -- The location will point to the source file used during compilation.
142 -- The location will point to the source file used during compilation.
114 -- This file might no longer exists and even if it does the path will be relative
143 -- This file might no longer exists and even if it does the path will be relative
115 -- to the compilation directory which we don’t know.
144 -- to the compilation directory which we don’t know.
116− let span = setFileName srcPath $ nameSrcSpan $ availName avail
145+ let span = setFileName srcPath $ fst avail
117 pure span
146 pure span
118 -- We ignore uniques and source spans and only compare the name and the module.
147 -- We ignore uniques and source spans and only compare the name and the module.
119 eqName :: Name -> Name -> Bool
148 eqName :: Name -> Name -> Bool
120− eqName n n' = nameOccName n == nameOccName n' && nameModule n == nameModule n'
149+ eqName n n' = nameOccName n == nameOccName n' && nameModule_maybe n == nameModule_maybe n'
121 setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })
150 setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })
122 setFileName _ span@(UnhelpfulSpan _) = span
151 setFileName _ span@(UnhelpfulSpan _) = span
123
152
153+-- | Filter out spans which do not enclose a given point
124spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo]
154spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo]
125spansAtPoint pos = filter atp where
155spansAtPoint pos = filter atp where
126 line = _line pos
156 line = _line pos
127 cha = _character pos
157 cha = _character pos
158+ atp SpanInfo{..} =
159+ startsBeforePosition && endsAfterPosition
160+ where
128− atp SpanInfo{..} = spaninfoStartLine <= line
161+ startLineCmp = compare spaninfoStartLine line
129− && spaninfoEndLine >= line
162+ endLineCmp = compare spaninfoEndLine line
163+
130− && spaninfoStartCol <= cha
164+ startsBeforePosition = startLineCmp == LT || (startLineCmp == EQ && spaninfoStartCol <= cha)
131− -- The end col points to the column after the
165+ -- The end col points to the column after the
132− -- last character so we use > instead of >=
166+ -- last character so we use > instead of >=
133− && spaninfoEndCol > cha
167+ endsAfterPosition = endLineCmp == GT || (endLineCmp == EQ && spaninfoEndCol > cha)
134
168
135showName :: Outputable a => a -> T.Text
169showName :: Outputable a => a -> T.Text
136showName = T.pack . prettyprint
170showName = T.pack . prettyprint
src/Development/IDE/Spans/Calculate.hs+149−64
@@ -9,29 +9,35 @@
9
9
10-- | Get information on modules, identifiers, etc.
10-- | Get information on modules, identifiers, etc.
11
11
12−module Development.IDE.Spans.Calculate(getSrcSpanInfos,listifyAllSpans) where
12+module Development.IDE.Spans.Calculate(getSrcSpanInfos) where
13
13
14import ConLike
14import ConLike
15import Control.Monad
15import Control.Monad
16import qualified CoreUtils
16import qualified CoreUtils
17−import Data.Data
18−import qualified Data.Generics
19import Data.List
17import Data.List
20import Data.Maybe
18import Data.Maybe
21import DataCon
19import DataCon
22import Desugar
20import Desugar
23import GHC
21import GHC
24import GhcMonad
22import GhcMonad
23+import HscTypes
25import FastString (mkFastString)
24import FastString (mkFastString)
25+import OccName
26import Development.IDE.Types.Location
26import Development.IDE.Types.Location
27import Development.IDE.Spans.Type
27import Development.IDE.Spans.Type
28+#ifdef GHC_LIB
28import Development.IDE.GHC.Error (zeroSpan)
29import Development.IDE.GHC.Error (zeroSpan)
30+#else
31+import Development.IDE.GHC.Error (zeroSpan, catchSrcErrors)
32+#endif
29import Prelude hiding (mod)
33import Prelude hiding (mod)
30import TcHsSyn
34import TcHsSyn
31import Var
35import Var
32import Development.IDE.Core.Compile
36import Development.IDE.Core.Compile
37+import qualified Development.IDE.GHC.Compat as Compat
33import Development.IDE.GHC.Util
38import Development.IDE.GHC.Util
34−
39+import Development.IDE.Spans.Common
40+import Development.IDE.Spans.Documentation
35
41
36-- A lot of things gained an extra X argument in GHC 8.6, which we mostly ignore
42-- A lot of things gained an extra X argument in GHC 8.6, which we mostly ignore
37-- this U ignores that arg in 8.6, but is hidden in 8.4
43-- this U ignores that arg in 8.6, but is hidden in 8.4
@@ -44,42 +50,67 @@ import Development.IDE.GHC.Util
44-- | Get source span info, used for e.g. AtPoint and Goto Definition.
50-- | Get source span info, used for e.g. AtPoint and Goto Definition.
45getSrcSpanInfos
51getSrcSpanInfos
46 :: HscEnv
52 :: HscEnv
47− -> [(Located ModuleName, Maybe NormalizedFilePath)]
53+ -> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order
48 -> TcModuleResult
54 -> TcModuleResult
49− -> IO [SpanInfo]
55+ -> [ParsedModule] -- ^ Dependencies parsed, optional
56+ -> [ModIface] -- ^ Dependencies module interfaces, required
57+ -> IO SpansInfo
50−getSrcSpanInfos env imports tc =
58+getSrcSpanInfos env imports tc parsedDeps deps =
51− runGhcEnv env
59+ evalGhcEnv env $
52− . getSpanInfo imports
53− $ tmrModule tc
60+ getSpanInfo imports (tmrModule tc) parsedDeps deps
54
61
55-- | Get ALL source spans in the module.
62-- | Get ALL source spans in the module.
56getSpanInfo :: GhcMonad m
63getSpanInfo :: GhcMonad m
57 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports
64 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports
58 -> TypecheckedModule
65 -> TypecheckedModule
59− -> m [SpanInfo]
66+ -> [ParsedModule]
67+ -> [ModIface]
68+ -> m SpansInfo
60−getSpanInfo mods tcm =
69+getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps deps =
61− do let tcs = tm_typechecked_source tcm
70+ do let tcs = tm_typechecked_source
62 bs = listifyAllSpans tcs :: [LHsBind GhcTc]
71 bs = listifyAllSpans tcs :: [LHsBind GhcTc]
63 es = listifyAllSpans tcs :: [LHsExpr GhcTc]
72 es = listifyAllSpans tcs :: [LHsExpr GhcTc]
64 ps = listifyAllSpans' tcs :: [Pat GhcTc]
73 ps = listifyAllSpans' tcs :: [Pat GhcTc]
65− ts = listifyAllSpans $ tm_renamed_source tcm :: [LHsType GhcRn]
74+ ts = listifyAllSpans tm_renamed_source :: [LHsType GhcRn]
75+ allModules = tm_parsed_module : parsedDeps
76+ funBinds = funBindMap tm_parsed_module
77+
78+ -- Load all modules in HPT to make their interface documentation available
79+ mapM_ (`loadDepModule` Nothing) (reverse deps)
80+ forM_ (modInfoIface tm_checked_module_info) $ \modIface ->
81+ modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing)
82+
66− bts <- mapM (getTypeLHsBind tcm) bs -- binds
83+ bts <- mapM (getTypeLHsBind allModules funBinds) bs -- binds
67− ets <- mapM (getTypeLHsExpr tcm) es -- expressions
84+ ets <- mapM (getTypeLHsExpr allModules) es -- expressions
68− pts <- mapM (getTypeLPat tcm) ps -- patterns
85+ pts <- mapM (getTypeLPat allModules) ps -- patterns
69− tts <- mapM (getLHsType tcm) ts -- types
86+ tts <- mapM (getLHsType allModules) ts -- types
70 let imports = importInfo mods
87 let imports = importInfo mods
71 let exports = getExports tcm
88 let exports = getExports tcm
72− let exprs = exports ++ imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)
89+ let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)
90+ let constraints = map constraintToInfo (concatMap getConstraintsLHsBind bs)
73− return (mapMaybe toSpanInfo (sortBy cmp exprs))
91+ return $ SpansInfo (mapMaybe toSpanInfo (sortBy cmp exprs))
92+ (mapMaybe toSpanInfo (sortBy cmp constraints))
74− where cmp (_,a,_) (_,b,_)
93+ where cmp (_,a,_,_) (_,b,_,_)
75 | a `isSubspanOf` b = LT
94 | a `isSubspanOf` b = LT
76 | b `isSubspanOf` a = GT
95 | b `isSubspanOf` a = GT
77 | otherwise = compare (srcSpanStart a) (srcSpanStart b)
96 | otherwise = compare (srcSpanStart a) (srcSpanStart b)
78
97
98+ addEmptyInfo = map (\(a,b) -> (a,b,Nothing,emptySpanDoc))
99+ constraintToInfo (sp, ty) = (SpanS sp, sp, Just ty, emptySpanDoc)
100+
101+-- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always
102+-- points to the first match) whereas the parsed module has the correct locations.
103+-- Therefore we build up a map from OccName to the corresponding definition in the parsed module
104+-- to lookup precise locations for things like multi-clause function definitions.
105+--
106+-- For now this only contains FunBinds.
107+funBindMap :: ParsedModule -> OccEnv (HsBind GhcPs)
108+funBindMap pm = mkOccEnv $ [ (occName $ unLoc f, bnd) | L _ (Compat.ValD bnd@FunBind{fun_id = f}) <- hsmodDecls $ unLoc $ pm_parsed_source pm ]
109+
79−getExports :: TypecheckedModule -> [(SpanSource, SrcSpan, Maybe Type)]
110+getExports :: TypecheckedModule -> [(SpanSource, SrcSpan)]
80getExports m
111getExports m
81 | Just (_, _, Just exports, _) <- renamedSource m =
112 | Just (_, _, Just exports, _) <- renamedSource m =
82− [ (Named $ unLoc n, getLoc n, Nothing)
113+ [ (Named $ unLoc n, getLoc n)
83 | (e, _) <- exports
114 | (e, _) <- exports
84 , n <- ieLNames $ unLoc e
115 , n <- ieLNames $ unLoc e
85 ]
116 ]
@@ -95,43 +126,96 @@ ieLNames _ = []
95
126
96-- | Get the name and type of a binding.
127-- | Get the name and type of a binding.
97getTypeLHsBind :: (GhcMonad m)
128getTypeLHsBind :: (GhcMonad m)
98− => TypecheckedModule
129+ => [ParsedModule]
130+ -> OccEnv (HsBind GhcPs)
99 -> LHsBind GhcTc
131 -> LHsBind GhcTc
100− -> m [(SpanSource, SrcSpan, Maybe Type)]
132+ -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
101−getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) =
133+getTypeLHsBind deps funBinds (L _spn FunBind{fun_id = pid})
134+ | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) = do
135+ let name = getName (unLoc pid)
136+ docs <- getDocumentationTryGhc deps name
137+ return [(Named name, getLoc mc_fun, Just (varType (unLoc pid)), docs) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]
138+-- In theory this shouldn’t ever fail but if it does, we can at least show the first clause.
139+getTypeLHsBind deps _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do
140+ let name = getName (unLoc pid)
141+ docs <- getDocumentationTryGhc deps name
102− return [(Named $ getName (unLoc pid), getLoc pid, Just (varType (unLoc pid)))]
142+ return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)]
103−getTypeLHsBind _ _ = return []
143+getTypeLHsBind _ _ _ = return []
144+
145+-- | Get information about constraints
146+getConstraintsLHsBind :: LHsBind GhcTc
147+ -> [(SrcSpan, Type)]
148+getConstraintsLHsBind (L spn AbsBinds { abs_ev_vars = vars })
149+ = map (\v -> (spn, varType v)) vars
150+getConstraintsLHsBind _ = []
104
151
105-- | Get the name and type of an expression.
152-- | Get the name and type of an expression.
106getTypeLHsExpr :: (GhcMonad m)
153getTypeLHsExpr :: (GhcMonad m)
107− => TypecheckedModule
154+ => [ParsedModule]
108 -> LHsExpr GhcTc
155 -> LHsExpr GhcTc
109− -> m (Maybe (SpanSource, SrcSpan, Maybe Type))
156+ -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
110−getTypeLHsExpr _ e = do
157+getTypeLHsExpr deps e = do
111 hs_env <- getSession
158 hs_env <- getSession
112 (_, mbe) <- liftIO (deSugarExpr hs_env e)
159 (_, mbe) <- liftIO (deSugarExpr hs_env e)
113− return $
114− case mbe of
160+ case mbe of
115− Just expr ->
161+ Just expr -> do
162+ let ss = getSpanSource (unLoc e)
163+ docs <- case ss of
164+ Named n -> getDocumentationTryGhc deps n
165+ _ -> return emptySpanDoc
116− Just (getSpanSource (unLoc e), getLoc e, Just (CoreUtils.exprType expr))
166+ return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr), docs)
117− Nothing -> Nothing
167+ Nothing -> return Nothing
118 where
168 where
119 getSpanSource :: HsExpr GhcTc -> SpanSource
169 getSpanSource :: HsExpr GhcTc -> SpanSource
170+ getSpanSource xpr | isLit xpr = Lit (showGhc xpr)
120 getSpanSource (HsVar U (L _ i)) = Named (getName i)
171 getSpanSource (HsVar U (L _ i)) = Named (getName i)
121 getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)
172 getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)
122 getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name)
173 getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name)
123 getSpanSource (HsWrap U _ xpr) = getSpanSource xpr
174 getSpanSource (HsWrap U _ xpr) = getSpanSource xpr
124 getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr)
175 getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr)
125− getSpanSource _ = NoSource
176+ getSpanSource _ = NoSource
177+
178+ isLit :: HsExpr GhcTc -> Bool
179+ isLit (HsLit U _) = True
180+ isLit (HsOverLit U _) = True
181+ isLit (ExplicitTuple U args _) = all (isTupLit . unLoc) args
182+#if MIN_GHC_API_VERSION(8,6,0)
183+ isLit (ExplicitSum U _ _ xpr) = isLitChild (unLoc xpr)
184+ isLit (ExplicitList U _ xprs) = all (isLitChild . unLoc) xprs
185+#else
186+ isLit (ExplicitSum _ _ xpr _) = isLitChild (unLoc xpr)
187+ isLit (ExplicitList _ _ xprs) = all (isLitChild . unLoc) xprs
188+#endif
189+ isLit _ = False
190+
191+ isTupLit (Present U xpr) = isLitChild (unLoc xpr)
192+ isTupLit _ = False
193+
194+ -- We need special treatment for children so things like [(1)] are still treated
195+ -- as a list literal while not treating (1) as a literal.
196+ isLitChild (HsWrap U _ xpr) = isLitChild xpr
197+ isLitChild (HsPar U xpr) = isLitChild (unLoc xpr)
198+#if MIN_GHC_API_VERSION(8,8,0)
199+ isLitChild (ExprWithTySig U xpr _) = isLitChild (unLoc xpr)
200+#elif MIN_GHC_API_VERSION(8,6,0)
201+ isLitChild (ExprWithTySig U xpr) = isLitChild (unLoc xpr)
202+#else
203+ isLitChild (ExprWithTySigOut xpr _) = isLitChild (unLoc xpr)
204+ isLitChild (ExprWithTySig xpr _) = isLitChild (unLoc xpr)
205+#endif
206+ isLitChild e = isLit e
126
207
127-- | Get the name and type of a pattern.
208-- | Get the name and type of a pattern.
128getTypeLPat :: (GhcMonad m)
209getTypeLPat :: (GhcMonad m)
129− => TypecheckedModule
210+ => [ParsedModule]
130 -> Pat GhcTc
211 -> Pat GhcTc
131− -> m (Maybe (SpanSource, SrcSpan, Maybe Type))
212+ -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
132−getTypeLPat _ pat =
213+getTypeLPat deps pat = do
133− let (src, spn) = getSpanSource pat in
214+ let (src, spn) = getSpanSource pat
215+ docs <- case src of
216+ Named n -> getDocumentationTryGhc deps n
217+ _ -> return emptySpanDoc
134− return $ Just (src, spn, Just (hsPatType pat))
218+ return $ Just (src, spn, Just (hsPatType pat), docs)
135 where
219 where
136 getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan)
220 getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan)
137 getSpanSource (VarPat U (L spn vid)) = (Named (getName vid), spn)
221 getSpanSource (VarPat U (L spn vid)) = (Named (getName vid), spn)
@@ -141,40 +225,40 @@ getTypeLPat _ pat =
141
225
142getLHsType
226getLHsType
143 :: GhcMonad m
227 :: GhcMonad m
144− => TypecheckedModule
228+ => [ParsedModule]
145 -> LHsType GhcRn
229 -> LHsType GhcRn
146− -> m [(SpanSource, SrcSpan, Maybe Type)]
230+ -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
147−getLHsType _ (L spn (HsTyVar U _ v)) = pure [(Named $ unLoc v, spn, Nothing)]
231+getLHsType deps (L spn (HsTyVar U _ v)) = do
232+ let n = unLoc v
233+ docs <- getDocumentationTryGhc deps n
234+#ifdef GHC_LIB
235+ let ty = Right Nothing
236+#else
237+ ty <- catchSrcErrors "completion" $ do
238+ name' <- lookupName n
239+ return $ name' >>= safeTyThingType
240+#endif
241+ let ty' = case ty of
242+ Right (Just x) -> Just x
243+ _ -> Nothing
244+ pure [(Named n, spn, ty', docs)]
148getLHsType _ _ = pure []
245getLHsType _ _ = pure []
149
246
150importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]
247importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]
151− -> [(SpanSource, SrcSpan, Maybe Type)]
248+ -> [(SpanSource, SrcSpan)]
152importInfo = mapMaybe (uncurry wrk) where
249importInfo = mapMaybe (uncurry wrk) where
153− wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan, Maybe Type)
250+ wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan)
154 wrk modName = \case
251 wrk modName = \case
155 Nothing -> Nothing
252 Nothing -> Nothing
156− Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName, Nothing)
253+ Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName)
157
254
158 -- TODO make this point to the module name
255 -- TODO make this point to the module name
159 fpToSpanSource :: FilePath -> SpanSource
256 fpToSpanSource :: FilePath -> SpanSource
160 fpToSpanSource fp = SpanS $ RealSrcSpan $ zeroSpan $ mkFastString fp
257 fpToSpanSource fp = SpanS $ RealSrcSpan $ zeroSpan $ mkFastString fp
161
258
162−-- | Get ALL source spans in the source.
163−listifyAllSpans :: (Typeable a, Data m) => m -> [Located a]
164−listifyAllSpans tcs =
165− Data.Generics.listify p tcs
166− where p (L spn _) = isGoodSrcSpan spn
167−-- This is a version of `listifyAllSpans` specialized on picking out
168−-- patterns. It comes about since GHC now defines `type LPat p = Pat
169−-- p` (no top-level locations).
170−listifyAllSpans' :: Typeable a
171− => TypecheckedSource -> [Pat a]
172−listifyAllSpans' tcs = Data.Generics.listify (const True) tcs
173−
174−
175-- | Pretty print the types into a 'SpanInfo'.
259-- | Pretty print the types into a 'SpanInfo'.
176−toSpanInfo :: (SpanSource, SrcSpan, Maybe Type) -> Maybe SpanInfo
260+toSpanInfo :: (SpanSource, SrcSpan, Maybe Type, SpanDoc) -> Maybe SpanInfo
177−toSpanInfo (name,mspan,typ) =
261+toSpanInfo (name,mspan,typ,docs) =
178 case mspan of
262 case mspan of
179 RealSrcSpan spn ->
263 RealSrcSpan spn ->
180 -- GHC’s line and column numbers are 1-based while LSP’s line and column
264 -- GHC’s line and column numbers are 1-based while LSP’s line and column
@@ -184,5 +268,6 @@ toSpanInfo (name,mspan,typ) =
184 (srcSpanEndLine spn - 1)
268 (srcSpanEndLine spn - 1)
185 (srcSpanEndCol spn - 1)
269 (srcSpanEndCol spn - 1)
186 typ
270 typ
187− name)
271+ name
272+ docs)
188 _ -> Nothing
273 _ -> Nothing
src/Development/IDE/Spans/Common.hsnew file+162
@@ -0,0 +1,162 @@
1+{-# LANGUAGE CPP #-}
2+#include "ghc-api-version.h"
3+
4+module Development.IDE.Spans.Common (
5+ showGhc
6+, listifyAllSpans
7+, listifyAllSpans'
8+, safeTyThingId
9+#ifndef GHC_LIB
10+, safeTyThingType
11+#endif
12+, SpanDoc(..)
13+, emptySpanDoc
14+, spanDocToMarkdown
15+, spanDocToMarkdownForTest
16+) where
17+
18+import Data.Data
19+import qualified Data.Generics
20+import qualified Data.Text as T
21+import Data.List.Extra
22+
23+import GHC
24+import Outputable
25+import DynFlags
26+import ConLike
27+import DataCon
28+#ifndef GHC_LIB
29+import Var
30+#endif
31+
32+import qualified Documentation.Haddock.Parser as H
33+import qualified Documentation.Haddock.Types as H
34+
35+showGhc :: Outputable a => a -> String
36+showGhc = showPpr unsafeGlobalDynFlags
37+
38+-- | Get ALL source spans in the source.
39+listifyAllSpans :: (Typeable a, Data m) => m -> [Located a]
40+listifyAllSpans tcs =
41+ Data.Generics.listify p tcs
42+ where p (L spn _) = isGoodSrcSpan spn
43+-- This is a version of `listifyAllSpans` specialized on picking out
44+-- patterns. It comes about since GHC now defines `type LPat p = Pat
45+-- p` (no top-level locations).
46+listifyAllSpans' :: Typeable a
47+ => TypecheckedSource -> [Pat a]
48+listifyAllSpans' tcs = Data.Generics.listify (const True) tcs
49+
50+#ifndef GHC_LIB
51+-- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs
52+safeTyThingType :: TyThing -> Maybe Type
53+safeTyThingType thing
54+ | Just i <- safeTyThingId thing = Just (varType i)
55+safeTyThingType (ATyCon tycon) = Just (tyConKind tycon)
56+safeTyThingType _ = Nothing
57+#endif
58+
59+safeTyThingId :: TyThing -> Maybe Id
60+safeTyThingId (AnId i) = Just i
61+safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc
62+safeTyThingId _ = Nothing
63+
64+-- Possible documentation for an element in the code
65+data SpanDoc
66+ = SpanDocString HsDocString
67+ | SpanDocText [T.Text]
68+ deriving Show
69+
70+emptySpanDoc :: SpanDoc
71+emptySpanDoc = SpanDocText []
72+
73+spanDocToMarkdown :: SpanDoc -> [T.Text]
74+#if MIN_GHC_API_VERSION(8,6,0)
75+spanDocToMarkdown (SpanDocString docs)
76+ = [T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs]
77+#else
78+spanDocToMarkdown (SpanDocString _)
79+ = []
80+#endif
81+spanDocToMarkdown (SpanDocText txt) = txt
82+
83+spanDocToMarkdownForTest :: String -> String
84+spanDocToMarkdownForTest
85+ = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing
86+
87+-- Simple (and a bit hacky) conversion from Haddock markup to Markdown
88+haddockToMarkdown
89+ :: H.DocH String String -> String
90+
91+haddockToMarkdown H.DocEmpty
92+ = ""
93+haddockToMarkdown (H.DocAppend d1 d2)
94+ = haddockToMarkdown d1 ++ " " ++ haddockToMarkdown d2
95+haddockToMarkdown (H.DocString s)
96+ = s
97+haddockToMarkdown (H.DocParagraph p)
98+ = "\n\n" ++ haddockToMarkdown p
99+haddockToMarkdown (H.DocIdentifier i)
100+ = "`" ++ i ++ "`"
101+haddockToMarkdown (H.DocIdentifierUnchecked i)
102+ = "`" ++ i ++ "`"
103+haddockToMarkdown (H.DocModule i)
104+ = "`" ++ i ++ "`"
105+haddockToMarkdown (H.DocWarning w)
106+ = haddockToMarkdown w
107+haddockToMarkdown (H.DocEmphasis d)
108+ = "*" ++ haddockToMarkdown d ++ "*"
109+haddockToMarkdown (H.DocBold d)
110+ = "**" ++ haddockToMarkdown d ++ "**"
111+haddockToMarkdown (H.DocMonospaced d)
112+ = "`" ++ escapeBackticks (haddockToMarkdown d) ++ "`"
113+ where
114+ escapeBackticks "" = ""
115+ escapeBackticks ('`':ss) = '\\':'`':escapeBackticks ss
116+ escapeBackticks (s :ss) = s:escapeBackticks ss
117+haddockToMarkdown (H.DocCodeBlock d)
118+ = "\n```haskell\n" ++ haddockToMarkdown d ++ "\n```\n"
119+haddockToMarkdown (H.DocExamples es)
120+ = "\n```haskell\n" ++ unlines (map exampleToMarkdown es) ++ "\n```\n"
121+ where
122+ exampleToMarkdown (H.Example expr result)
123+ = ">>> " ++ expr ++ "\n" ++ unlines result
124+haddockToMarkdown (H.DocHyperlink (H.Hyperlink url Nothing))
125+ = "<" ++ url ++ ">"
126+haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))
127+ = "[" ++ haddockToMarkdown label ++ "](" ++ url ++ ")"
128+haddockToMarkdown (H.DocPic (H.Picture url Nothing))
129+ = "![](" ++ url ++ ")"
130+haddockToMarkdown (H.DocPic (H.Picture url (Just label)))
131+ = "![" ++ label ++ "](" ++ url ++ ")"
132+haddockToMarkdown (H.DocAName aname)
133+ = "[" ++ aname ++ "]:"
134+haddockToMarkdown (H.DocHeader (H.Header level title))
135+ = replicate level '#' ++ " " ++ haddockToMarkdown title
136+
137+haddockToMarkdown (H.DocUnorderedList things)
138+ = '\n' : (unlines $ map (("+ " ++) . trimStart . splitForList . haddockToMarkdown) things)
139+haddockToMarkdown (H.DocOrderedList things)
140+ = '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things)
141+haddockToMarkdown (H.DocDefList things)
142+ = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things)
143+
144+-- we cannot render math by default
145+haddockToMarkdown (H.DocMathInline _)
146+ = "*cannot render inline math formula*"
147+haddockToMarkdown (H.DocMathDisplay _)
148+ = "\n\n*cannot render display math formula*\n\n"
149+
150+-- TODO: render tables
151+haddockToMarkdown (H.DocTable _t)
152+ = "\n\n*tables are not yet supported*\n\n"
153+
154+-- things I don't really know how to handle
155+haddockToMarkdown (H.DocProperty _)
156+ = "" -- don't really know what to do
157+
158+splitForList :: String -> String
159+splitForList s
160+ = case lines s of
161+ [] -> ""
162+ (first:rest) -> unlines $ first : map ((" " ++) . trimStart) rest
src/Development/IDE/Spans/Documentation.hs+41−18
@@ -1,8 +1,12 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4+{-# LANGUAGE CPP #-}
5+#include "ghc-api-version.h"
6+
4module Development.IDE.Spans.Documentation (
7module Development.IDE.Spans.Documentation (
5 getDocumentation
8 getDocumentation
9+ , getDocumentationTryGhc
6 ) where
10 ) where
7
11
8import Control.Monad
12import Control.Monad
@@ -10,16 +14,34 @@ import Data.List.Extra
10import qualified Data.Map as M
14import qualified Data.Map as M
11import Data.Maybe
15import Data.Maybe
12import qualified Data.Text as T
16import qualified Data.Text as T
17+import Development.IDE.GHC.Compat
13import Development.IDE.GHC.Error
18import Development.IDE.GHC.Error
14−import Development.IDE.Spans.Calculate
19+import Development.IDE.Spans.Common
15import FastString
20import FastString
16−import GHC
17import SrcLoc
21import SrcLoc
18
22
19
23
24+getDocumentationTryGhc
25+ :: GhcMonad m
26+ => [ParsedModule]
27+ -> Name
28+ -> m SpanDoc
29+-- getDocs goes through the GHCi codepaths which cause problems on ghc-lib.
30+-- See https://github.com/digital-asset/daml/issues/4152 for more details.
31+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
32+getDocumentationTryGhc sources name = do
33+ res <- catchSrcErrors "docs" $ getDocs name
34+ case res of
35+ Right (Right (Just docs, _)) -> return $ SpanDocString docs
36+ _ -> return $ SpanDocText $ getDocumentation sources name
37+#else
38+getDocumentationTryGhc sources name = do
39+ return $ SpanDocText $ getDocumentation sources name
40+#endif
41+
20getDocumentation
42getDocumentation
21− :: Name -- ^ The name you want documentation for.
22− -> [TypecheckedModule] -- ^ All of the possible modules it could be defined in.
43+ :: [ParsedModule] -- ^ All of the possible modules it could be defined in.
44+ -> Name -- ^ The name you want documentation for.
23 -> [T.Text]
45 -> [T.Text]
24-- This finds any documentation between the name you want
46-- This finds any documentation between the name you want
25-- documentation for and the one before it. This is only an
47-- documentation for and the one before it. This is only an
@@ -28,17 +50,18 @@ getDocumentation
28-- may be edge cases where it is very wrong).
50-- may be edge cases where it is very wrong).
29-- TODO : Build a version of GHC exactprint to extract this information
51-- TODO : Build a version of GHC exactprint to extract this information
30-- more accurately.
52-- more accurately.
31−getDocumentation targetName tcs = fromMaybe [] $ do
53+getDocumentation sources targetName = fromMaybe [] $ do
32 -- Find the module the target is defined in.
54 -- Find the module the target is defined in.
33 targetNameSpan <- realSpan $ nameSrcSpan targetName
55 targetNameSpan <- realSpan $ nameSrcSpan targetName
34 tc <-
56 tc <-
35− listToMaybe
36− $ filter ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)
57+ find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)
37− $ reverse tcs -- TODO : Is reversing the list here really neccessary?
58+ $ reverse sources -- TODO : Is reversing the list here really neccessary?
59+
38− -- Names bound by the module (we want to exclude non-"top-level"
60+ -- Top level names bound by the module
39− -- bindings but unfortunately we get all here).
61+ let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc
40− let bs = mapMaybe name_of_bind
62+ , L _ (ValD hsbind) <- hsmodDecls
41− (listifyAllSpans (tm_typechecked_source tc) :: [LHsBind GhcTc])
63+ , Just n <- [name_of_bind hsbind]
64+ ]
42 -- Sort the names' source spans.
65 -- Sort the names' source spans.
43 let sortedSpans = sortedNameSpans bs
66 let sortedSpans = sortedNameSpans bs
44 -- Now go ahead and extract the docs.
67 -- Now go ahead and extract the docs.
@@ -60,16 +83,16 @@ getDocumentation targetName tcs = fromMaybe [] $ do
60 where
83 where
61 -- Get the name bound by a binding. We only concern ourselves with
84 -- Get the name bound by a binding. We only concern ourselves with
62 -- @FunBind@ (which covers functions and variables).
85 -- @FunBind@ (which covers functions and variables).
63− name_of_bind :: LHsBind GhcTc -> Maybe Name
86+ name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)
64− name_of_bind (L _ FunBind {fun_id}) = Just (getName (unLoc fun_id))
87+ name_of_bind FunBind {fun_id} = Just fun_id
65 name_of_bind _ = Nothing
88 name_of_bind _ = Nothing
66 -- Get source spans from names, discard unhelpful spans, remove
89 -- Get source spans from names, discard unhelpful spans, remove
67 -- duplicates and sort.
90 -- duplicates and sort.
68− sortedNameSpans :: [Name] -> [RealSrcSpan]
91+ sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]
69− sortedNameSpans ls = nubSort (mapMaybe (realSpan . nameSrcSpan) ls)
92+ sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)
70 isBetween target before after = before <= target && target <= after
93 isBetween target before after = before <= target && target <= after
71− ann = snd . pm_annotations . tm_parsed_module
94+ ann = snd . pm_annotations
72− annotationFileName :: TypecheckedModule -> Maybe FastString
95+ annotationFileName :: ParsedModule -> Maybe FastString
73 annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann
96 annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann
74 realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]
97 realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]
75 realSpans =
98 realSpans =
src/Development/IDE/Spans/Type.hs+19−4
@@ -6,7 +6,8 @@
6-- | Types used separate to GHCi vanilla.
6-- | Types used separate to GHCi vanilla.
7
7
8module Development.IDE.Spans.Type(
8module Development.IDE.Spans.Type(
9+ SpansInfo(..)
9− SpanInfo(..)
10+ , SpanInfo(..)
10 , SpanSource(..)
11 , SpanSource(..)
11 , getNameM
12 , getNameM
12 ) where
13 ) where
@@ -15,6 +16,15 @@ import GHC
15import Control.DeepSeq
16import Control.DeepSeq
16import OccName
17import OccName
17import Development.IDE.GHC.Util
18import Development.IDE.GHC.Util
19+import Development.IDE.Spans.Common
20+
21+data SpansInfo =
22+ SpansInfo { spansExprs :: [SpanInfo]
23+ , spansConstraints :: [SpanInfo] }
24+ deriving Show
25+
26+instance NFData SpansInfo where
27+ rnf (SpansInfo e c) = liftRnf rnf e `seq` liftRnf rnf c
18
28
19-- | Type of some span of source code. Most of these fields are
29-- | Type of some span of source code. Most of these fields are
20-- unboxed but Haddock doesn't show that.
30-- unboxed but Haddock doesn't show that.
@@ -34,11 +44,14 @@ data SpanInfo =
34 -- any. This can be useful for accessing a variety of
44 -- any. This can be useful for accessing a variety of
35 -- information about the identifier such as module,
45 -- information about the identifier such as module,
36 -- locality, definition location, etc.
46 -- locality, definition location, etc.
47+ ,spaninfoDocs :: !SpanDoc
48+ -- ^ Documentation for the element
37 }
49 }
38instance Show SpanInfo where
50instance Show SpanInfo where
39− show (SpanInfo sl sc el ec t n) =
51+ show (SpanInfo sl sc el ec t n docs) =
40 unwords ["(SpanInfo", show sl, show sc, show el, show ec
52 unwords ["(SpanInfo", show sl, show sc, show el, show ec
41− , show $ maybe "NoType" prettyPrint t, "(" <> show n <> "))"]
53+ , show $ maybe "NoType" prettyPrint t, "(" <> show n <> "))"
54+ , "docs(" <> show docs <> ")"]
42
55
43instance NFData SpanInfo where
56instance NFData SpanInfo where
44 rnf = rwhnf
57 rnf = rwhnf
@@ -47,6 +60,7 @@ instance NFData SpanInfo where
47-- we don't always get a name out so sometimes manually annotating source is more appropriate
60-- we don't always get a name out so sometimes manually annotating source is more appropriate
48data SpanSource = Named Name
61data SpanSource = Named Name
49 | SpanS SrcSpan
62 | SpanS SrcSpan
63+ | Lit String
50 | NoSource
64 | NoSource
51 deriving (Eq)
65 deriving (Eq)
52
66
@@ -54,9 +68,10 @@ instance Show SpanSource where
54 show = \case
68 show = \case
55 Named n -> "Named " ++ occNameString (occName n)
69 Named n -> "Named " ++ occNameString (occName n)
56 SpanS sp -> "Span " ++ show sp
70 SpanS sp -> "Span " ++ show sp
71+ Lit lit -> "Lit " ++ lit
57 NoSource -> "NoSource"
72 NoSource -> "NoSource"
58
73
59getNameM :: SpanSource -> Maybe Name
74getNameM :: SpanSource -> Maybe Name
60getNameM = \case
75getNameM = \case
61 Named name -> Just name
76 Named name -> Just name
62− _ -> Nothing
77+ _ -> Nothing
src/Development/IDE/Types/Diagnostics.hs+38−7
@@ -4,19 +4,23 @@
4
4
5module Development.IDE.Types.Diagnostics (
5module Development.IDE.Types.Diagnostics (
6 LSP.Diagnostic(..),
6 LSP.Diagnostic(..),
7+ ShowDiagnostic(..),
7 FileDiagnostic,
8 FileDiagnostic,
9+ IdeResult,
8 LSP.DiagnosticSeverity(..),
10 LSP.DiagnosticSeverity(..),
9 DiagnosticStore,
11 DiagnosticStore,
10 List(..),
12 List(..),
11 ideErrorText,
13 ideErrorText,
14+ ideErrorWithSource,
12 showDiagnostics,
15 showDiagnostics,
13 showDiagnosticsColored,
16 showDiagnosticsColored,
14 ) where
17 ) where
15
18
19+import Control.DeepSeq
16import Data.Maybe as Maybe
20import Data.Maybe as Maybe
17import qualified Data.Text as T
21import qualified Data.Text as T
18import Data.Text.Prettyprint.Doc
22import Data.Text.Prettyprint.Doc
19−import Language.Haskell.LSP.Types as LSP (
23+import Language.Haskell.LSP.Types as LSP (DiagnosticSource,
20 DiagnosticSeverity(..)
24 DiagnosticSeverity(..)
21 , Diagnostic(..)
25 , Diagnostic(..)
22 , List(..)
26 , List(..)
@@ -28,17 +32,43 @@ import Data.Text.Prettyprint.Doc.Render.Terminal (Color(..), color)
28
32
29import Development.IDE.Types.Location
33import Development.IDE.Types.Location
30
34
35+-- A rule on a file should only return diagnostics for that given file. It should
36+-- not propagate diagnostic errors through multiple phases.
37+type IdeResult v = ([FileDiagnostic], Maybe v)
31
38
32ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic
39ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic
40+ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError)
41+
42+ideErrorWithSource
43+ :: Maybe DiagnosticSource
44+ -> Maybe DiagnosticSeverity
45+ -> a
46+ -> T.Text
47+ -> (a, ShowDiagnostic, Diagnostic)
33−ideErrorText fp msg = (fp, LSP.Diagnostic {
48+ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic {
34 _range = noRange,
49 _range = noRange,
35− _severity = Just LSP.DsError,
50+ _severity = sev,
36 _code = Nothing,
51 _code = Nothing,
37− _source = Just "compiler",
52+ _source = source,
38 _message = msg,
53 _message = msg,
39− _relatedInformation = Nothing
54+ _relatedInformation = Nothing,
55+ _tags = Nothing
40 })
56 })
41
57
58+-- | Defines whether a particular diagnostic should be reported
59+-- back to the user.
60+--
61+-- One important use case is "missing signature" code lenses,
62+-- for which we need to enable the corresponding warning during
63+-- type checking. However, we do not want to show the warning
64+-- unless the programmer asks for it (#261).
65+data ShowDiagnostic
66+ = ShowDiag -- ^ Report back to the user
67+ | HideDiag -- ^ Hide from user
68+ deriving (Eq, Ord, Show)
69+
70+instance NFData ShowDiagnostic where
71+ rnf = rwhnf
42
72
43-- | Human readable diagnostics for a specific file.
73-- | Human readable diagnostics for a specific file.
44--
74--
@@ -46,7 +76,7 @@ ideErrorText fp msg = (fp, LSP.Diagnostic {
46-- along with the related source location so that we can display the error
76-- along with the related source location so that we can display the error
47-- on either the console or in the IDE at the right source location.
77-- on either the console or in the IDE at the right source location.
48--
78--
49−type FileDiagnostic = (NormalizedFilePath, Diagnostic)
79+type FileDiagnostic = (NormalizedFilePath, ShowDiagnostic, Diagnostic)
50
80
51prettyRange :: Range -> Doc Terminal.AnsiStyle
81prettyRange :: Range -> Doc Terminal.AnsiStyle
52prettyRange Range{..} = f _start <> "-" <> f _end
82prettyRange Range{..} = f _start <> "-" <> f _end
@@ -66,9 +96,10 @@ prettyDiagnostics :: [FileDiagnostic] -> Doc Terminal.AnsiStyle
66prettyDiagnostics = vcat . map prettyDiagnostic
96prettyDiagnostics = vcat . map prettyDiagnostic
67
97
68prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle
98prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle
69−prettyDiagnostic (fp, LSP.Diagnostic{..}) =
99+prettyDiagnostic (fp, sh, LSP.Diagnostic{..}) =
70 vcat
100 vcat
71 [ slabel_ "File: " $ pretty (fromNormalizedFilePath fp)
101 [ slabel_ "File: " $ pretty (fromNormalizedFilePath fp)
102+ , slabel_ "Hidden: " $ if sh == ShowDiag then "no" else "yes"
72 , slabel_ "Range: " $ prettyRange _range
103 , slabel_ "Range: " $ prettyRange _range
73 , slabel_ "Source: " $ pretty _source
104 , slabel_ "Source: " $ pretty _source
74 , slabel_ "Severity:" $ pretty $ show sev
105 , slabel_ "Severity:" $ pretty $ show sev
src/Development/IDE/Types/Location.hs+70−59
@@ -10,84 +10,59 @@ module Development.IDE.Types.Location
10 , Position(..)
10 , Position(..)
11 , showPosition
11 , showPosition
12 , Range(..)
12 , Range(..)
13− , Uri(..)
13+ , LSP.Uri(..)
14− , NormalizedUri
14+ , LSP.NormalizedUri
15 , LSP.toNormalizedUri
15 , LSP.toNormalizedUri
16 , LSP.fromNormalizedUri
16 , LSP.fromNormalizedUri
17− , NormalizedFilePath
17+ , LSP.NormalizedFilePath
18 , fromUri
18 , fromUri
19+ , emptyFilePath
20+ , emptyPathUri
19− , toNormalizedFilePath
21+ , toNormalizedFilePath'
20− , fromNormalizedFilePath
22+ , LSP.fromNormalizedFilePath
21− , filePathToUri
22 , filePathToUri'
23 , filePathToUri'
23 , uriToFilePath'
24 , uriToFilePath'
25+ , readSrcSpan
24 ) where
26 ) where
25
27
28+import Control.Applicative
26import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..))
29import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..))
27−import Control.DeepSeq
30+import Control.Monad
28−import Data.Binary
31+import Data.Hashable (Hashable(hash))
29−import Data.Maybe as Maybe
30−import Data.Hashable
31import Data.String
32import Data.String
32−import System.FilePath
33+import FastString
33−import System.Info.Extra
34import qualified Language.Haskell.LSP.Types as LSP
34import qualified Language.Haskell.LSP.Types as LSP
35−import Language.Haskell.LSP.Types as LSP (
35+import SrcLoc as GHC
36− filePathToUri
36+import Text.ParserCombinators.ReadP as ReadP
37− , NormalizedUri(..)
37+import Data.Maybe (fromMaybe)
38− , Uri(..)
38+
39− , toNormalizedUri
40− , fromNormalizedUri
41− )
42−
43−
44−-- | Newtype wrapper around FilePath that always has normalized slashes.
45−newtype NormalizedFilePath = NormalizedFilePath FilePath
46− deriving (Eq, Ord, Show, Hashable, NFData, Binary)
47−
48−instance IsString NormalizedFilePath where
49− fromString = toNormalizedFilePath
50−
51−toNormalizedFilePath :: FilePath -> NormalizedFilePath
39+toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath
52−toNormalizedFilePath "" = NormalizedFilePath ""
40+-- We want to keep empty paths instead of normalising them to "."
53−toNormalizedFilePath fp = NormalizedFilePath $ normalise' fp
41+toNormalizedFilePath' "" = emptyFilePath
54− where
42+toNormalizedFilePath' fp = LSP.toNormalizedFilePath fp
55− -- We do not use System.FilePath’s normalise here since that
43+
56− -- also normalises things like the case of the drive letter
44+emptyFilePath :: LSP.NormalizedFilePath
57− -- which NormalizedUri does not normalise so we get VFS lookup failures.
45+emptyFilePath = LSP.NormalizedFilePath emptyPathUri ""
58− normalise' :: FilePath -> FilePath
59− normalise' = oneSlash . map (\c -> if isPathSeparator c then pathSeparator else c)
60−
61− -- Allow double slashes as the very first element of the path for UNC drives on Windows
62− -- otherwise turn adjacent slashes into one. These slashes often arise from dodgy CPP
63− oneSlash :: FilePath -> FilePath
64− oneSlash (x:xs) | isWindows = x : f xs
65− oneSlash xs = f xs
66−
67− f (x:y:xs) | isPathSeparator x, isPathSeparator y = f (x:xs)
68− f (x:xs) = x : f xs
69− f [] = []
70−
71−
72−fromNormalizedFilePath :: NormalizedFilePath -> FilePath
73−fromNormalizedFilePath (NormalizedFilePath fp) = fp
74
46
75-- | We use an empty string as a filepath when we don’t have a file.
47-- | We use an empty string as a filepath when we don’t have a file.
76-- However, haskell-lsp doesn’t support that in uriToFilePath and given
48-- However, haskell-lsp doesn’t support that in uriToFilePath and given
77-- that it is not a valid filepath it does not make sense to upstream a fix.
49-- that it is not a valid filepath it does not make sense to upstream a fix.
78-- So we have our own wrapper here that supports empty filepaths.
50-- So we have our own wrapper here that supports empty filepaths.
79−uriToFilePath' :: Uri -> Maybe FilePath
51+uriToFilePath' :: LSP.Uri -> Maybe FilePath
80uriToFilePath' uri
52uriToFilePath' uri
81− | uri == filePathToUri "" = Just ""
53+ | uri == LSP.fromNormalizedUri emptyPathUri = Just ""
82 | otherwise = LSP.uriToFilePath uri
54 | otherwise = LSP.uriToFilePath uri
83
55
84−filePathToUri' :: NormalizedFilePath -> NormalizedUri
56+emptyPathUri :: LSP.NormalizedUri
85−filePathToUri' = toNormalizedUri . filePathToUri . fromNormalizedFilePath
57+emptyPathUri =
86−
58+ let s = "file://"
59+ in LSP.NormalizedUri (hash s) s
87
60
88−fromUri :: LSP.NormalizedUri -> NormalizedFilePath
61+filePathToUri' :: LSP.NormalizedFilePath -> LSP.NormalizedUri
89−fromUri = toNormalizedFilePath . fromMaybe noFilePath . uriToFilePath' . fromNormalizedUri
62+filePathToUri' = LSP.normalizedFilePathToUri
90
63
64+fromUri :: LSP.NormalizedUri -> LSP.NormalizedFilePath
65+fromUri = fromMaybe (toNormalizedFilePath' noFilePath) . LSP.uriToNormalizedFilePath
91
66
92noFilePath :: FilePath
67noFilePath :: FilePath
93noFilePath = "<unknown>"
68noFilePath = "<unknown>"
@@ -96,6 +71,42 @@ noFilePath = "<unknown>"
96noRange :: Range
71noRange :: Range
97noRange = Range (Position 0 0) (Position 100000 0)
72noRange = Range (Position 0 0) (Position 100000 0)
98
73
99−
100showPosition :: Position -> String
74showPosition :: Position -> String
101showPosition Position{..} = show (_line + 1) ++ ":" ++ show (_character + 1)
75showPosition Position{..} = show (_line + 1) ++ ":" ++ show (_character + 1)
76+
77+-- | Parser for the GHC output format
78+readSrcSpan :: ReadS SrcSpan
79+readSrcSpan = readP_to_S (singleLineSrcSpanP <|> multiLineSrcSpanP)
80+ where
81+ singleLineSrcSpanP, multiLineSrcSpanP :: ReadP SrcSpan
82+ singleLineSrcSpanP = do
83+ fp <- filePathP
84+ l <- readS_to_P reads <* char ':'
85+ c0 <- readS_to_P reads
86+ c1 <- (char '-' *> readS_to_P reads) <|> pure c0
87+ let from = mkSrcLoc fp l c0
88+ to = mkSrcLoc fp l c1
89+ return $ mkSrcSpan from to
90+
91+ multiLineSrcSpanP = do
92+ fp <- filePathP
93+ s <- parensP (srcLocP fp)
94+ void $ char '-'
95+ e <- parensP (srcLocP fp)
96+ return $ mkSrcSpan s e
97+
98+ parensP :: ReadP a -> ReadP a
99+ parensP = between (char '(') (char ')')
100+
101+ filePathP :: ReadP FastString
102+ filePathP = fromString <$> (readFilePath <* char ':') <|> pure ""
103+
104+ srcLocP :: FastString -> ReadP SrcLoc
105+ srcLocP fp = do
106+ l <- readS_to_P reads
107+ void $ char ','
108+ c <- readS_to_P reads
109+ return $ mkSrcLoc fp l c
110+
111+ readFilePath :: ReadP FilePath
112+ readFilePath = some ReadP.get
src/Development/IDE/Types/Options.hs+35−8
@@ -12,25 +12,25 @@ module Development.IDE.Types.Options
12 , clientSupportsProgress
12 , clientSupportsProgress
13 , IdePkgLocationOptions(..)
13 , IdePkgLocationOptions(..)
14 , defaultIdeOptions
14 , defaultIdeOptions
15+ , IdeResult
15 ) where
16 ) where
16
17
17−import Data.Maybe
18import Development.Shake
18import Development.Shake
19import Development.IDE.GHC.Util
19import Development.IDE.GHC.Util
20import GHC hiding (parseModule, typecheckModule)
20import GHC hiding (parseModule, typecheckModule)
21import GhcPlugins as GHC hiding (fst3, (<>))
21import GhcPlugins as GHC hiding (fst3, (<>))
22import qualified Language.Haskell.LSP.Types.Capabilities as LSP
22import qualified Language.Haskell.LSP.Types.Capabilities as LSP
23+import qualified Data.Text as T
24+import Development.IDE.Types.Diagnostics
23
25
24data IdeOptions = IdeOptions
26data IdeOptions = IdeOptions
25 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource
27 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource
26 -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings
28 -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings
27 -- and a list of errors, along with a new parse tree.
29 -- and a list of errors, along with a new parse tree.
28− , optGhcSession :: IO (FilePath -> Action HscEnvEq)
30+ , optGhcSession :: Action (FilePath -> Action (IdeResult HscEnvEq))
29 -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.
31 -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.
30− -- The 'IO' will be called once, then the resulting function will be applied once per file.
32+ -- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.
31 -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.
33 -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.
32− -- You should not use 'newCacheIO' to get that caching, because of
33− -- https://github.com/ndmitchell/shake/issues/725.
34 , optPkgLocationOpts :: IdePkgLocationOptions
34 , optPkgLocationOpts :: IdePkgLocationOptions
35 -- ^ How to locate source and @.hie@ files given a module name.
35 -- ^ How to locate source and @.hie@ files given a module name.
36 , optExtensions :: [String]
36 , optExtensions :: [String]
@@ -43,12 +43,17 @@ data IdeOptions = IdeOptions
43 -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds.
43 -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds.
44 , optShakeProfiling :: Maybe FilePath
44 , optShakeProfiling :: Maybe FilePath
45 -- ^ Set to 'Just' to create a directory of profiling reports.
45 -- ^ Set to 'Just' to create a directory of profiling reports.
46+ , optTesting :: Bool
47+ -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
46 , optReportProgress :: IdeReportProgress
48 , optReportProgress :: IdeReportProgress
47 -- ^ Whether to report progress during long operations.
49 -- ^ Whether to report progress during long operations.
48 , optLanguageSyntax :: String
50 , optLanguageSyntax :: String
49 -- ^ the ```language to use
51 -- ^ the ```language to use
50 , optNewColonConvention :: Bool
52 , optNewColonConvention :: Bool
51 -- ^ whether to use new colon convention
53 -- ^ whether to use new colon convention
54+ , optKeywords :: [T.Text]
55+ -- ^ keywords used for completions. These are customizable
56+ -- since DAML has a different set of keywords than Haskell.
52 , optDefer :: IdeDefer
57 , optDefer :: IdeDefer
53 -- ^ Whether to defer type errors, typed holes and out of scope
58 -- ^ Whether to defer type errors, typed holes and out of scope
54 -- variables. Deferral allows the IDE to continue to provide
59 -- variables. Deferral allows the IDE to continue to provide
@@ -70,10 +75,10 @@ newtype IdeReportProgress = IdeReportProgress Bool
70newtype IdeDefer = IdeDefer Bool
75newtype IdeDefer = IdeDefer Bool
71
76
72clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress
77clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress
73−clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $
78+clientSupportsProgress caps = IdeReportProgress $ Just True ==
74− LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)
79+ (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))
75
80
76−defaultIdeOptions :: IO (FilePath -> Action HscEnvEq) -> IdeOptions
81+defaultIdeOptions :: Action (FilePath -> Action (IdeResult HscEnvEq)) -> IdeOptions
77defaultIdeOptions session = IdeOptions
82defaultIdeOptions session = IdeOptions
78 {optPreprocessor = IdePreprocessedSource [] []
83 {optPreprocessor = IdePreprocessedSource [] []
79 ,optGhcSession = session
84 ,optGhcSession = session
@@ -85,7 +90,9 @@ defaultIdeOptions session = IdeOptions
85 ,optReportProgress = IdeReportProgress False
90 ,optReportProgress = IdeReportProgress False
86 ,optLanguageSyntax = "haskell"
91 ,optLanguageSyntax = "haskell"
87 ,optNewColonConvention = False
92 ,optNewColonConvention = False
93+ ,optKeywords = haskellKeywords
88 ,optDefer = IdeDefer True
94 ,optDefer = IdeDefer True
95+ ,optTesting = False
89 }
96 }
90
97
91
98
@@ -103,3 +110,23 @@ data IdePkgLocationOptions = IdePkgLocationOptions
103defaultIdePkgLocationOptions :: IdePkgLocationOptions
110defaultIdePkgLocationOptions :: IdePkgLocationOptions
104defaultIdePkgLocationOptions = IdePkgLocationOptions f f
111defaultIdePkgLocationOptions = IdePkgLocationOptions f f
105 where f _ _ = return Nothing
112 where f _ _ = return Nothing
113+
114+-- | From https://wiki.haskell.org/Keywords
115+haskellKeywords :: [T.Text]
116+haskellKeywords =
117+ [ "as"
118+ , "case", "of"
119+ , "class", "instance", "type"
120+ , "data", "family", "newtype"
121+ , "default"
122+ , "deriving"
123+ , "do", "mdo", "proc", "rec"
124+ , "forall"
125+ , "foreign"
126+ , "hiding"
127+ , "if", "then", "else"
128+ , "import", "qualified", "hiding"
129+ , "infix", "infixl", "infixr"
130+ , "let", "in", "where"
131+ , "module"
132+ ]
stack-ghc-lib.yaml+10−4
@@ -2,12 +2,18 @@ resolver: nightly-2019-09-16
2packages:
2packages:
3- .
3- .
4extra-deps:
4extra-deps:
5−- haskell-lsp-0.18.0.0
5+- haskell-lsp-0.22.0.0
6−- haskell-lsp-types-0.18.0.0
6+- haskell-lsp-types-0.22.0.0
7−- lsp-test-0.8.2.0
7+- lsp-test-0.10.3.0
8−- hie-bios-0.2.0
8+- hie-bios-0.5.0
9- ghc-lib-parser-8.8.1
9- ghc-lib-parser-8.8.1
10- ghc-lib-8.8.1
10- ghc-lib-8.8.1
11+- fuzzy-0.1.0.0
12+- shake-0.18.5
13+- regex-base-0.94.0.0
14+- regex-tdfa-1.3.1.0
15+- haddock-library-1.8.0
16+- ghc-check-0.3.0.1
11nix:
17nix:
12 packages: [zlib]
18 packages: [zlib]
13flags:
19flags:
stack.yaml+14−5
@@ -1,10 +1,19 @@
1−resolver: nightly-2019-09-16
1+resolver: nightly-2019-09-21
2packages:
2packages:
3- .
3- .
4extra-deps:
4extra-deps:
5−- haskell-lsp-0.18.0.0
5+- haskell-lsp-0.22.0.0
6−- haskell-lsp-types-0.18.0.0
6+- haskell-lsp-types-0.22.0.0
7−- lsp-test-0.8.2.0
7+- lsp-test-0.11.0.1
8−- hie-bios-0.2.1
8+- hie-bios-0.5.0
9+- fuzzy-0.1.0.0
10+- regex-pcre-builtin-0.95.1.1.8.43
11+- regex-base-0.94.0.0
12+- regex-tdfa-1.3.1.0
13+- shake-0.18.5
14+- parser-combinators-1.2.1
15+- haddock-library-1.8.0
16+- tasty-rerun-1.1.17
17+- ghc-check-0.3.0.1
9nix:
18nix:
10 packages: [zlib]
19 packages: [zlib]
stack810.yamlnew file+18
@@ -0,0 +1,18 @@
1+resolver: nightly-2020-02-13
2+compiler: ghc-8.10.1
3+allow-newer: true
4+packages:
5+- .
6+extra-deps:
7+- haskell-lsp-0.22.0.0
8+- haskell-lsp-types-0.22.0.0
9+- lsp-test-0.11.0.1
10+- ghc-check-0.3.0.1
11+- hie-bios-0.5.0
12+
13+# for ghc-8.10
14+- Cabal-3.2.0.0
15+- lens-4.19.1
16+
17+nix:
18+ packages: [zlib]
stack84.yaml+23−6
@@ -3,14 +3,31 @@ packages:
3- .
3- .
4
4
5extra-deps:
5extra-deps:
6−- haskell-lsp-0.18.0.0
6+- aeson-1.4.6.0
7−- haskell-lsp-types-0.18.0.0
7+- base-orphans-0.8.2
8−- lsp-test-0.8.2.0
8+- haskell-lsp-0.22.0.0
9+- haskell-lsp-types-0.22.0.0
10+- lsp-test-0.11.0.1
9- rope-utf16-splay-0.3.1.0
11- rope-utf16-splay-0.3.1.0
10−- shake-0.18.3
11- filepattern-0.1.1
12- filepattern-0.1.1
12- js-dgtable-0.5.2
13- js-dgtable-0.5.2
13−- hie-bios-0.2.1
14+- hie-bios-0.5.0
15+- fuzzy-0.1.0.0
16+- shake-0.18.5
17+- time-compat-1.9.2.2
18+- regex-base-0.94.0.0
19+- regex-tdfa-1.3.1.0
20+- parser-combinators-1.2.1
21+- haddock-library-1.8.0
22+- unordered-containers-0.2.10.0
23+- file-embed-0.0.11.2
24+- heaps-0.3.6.1
25+- ghc-check-0.3.0.1
26+# For tasty-retun
27+- ansi-terminal-0.10.3
28+- ansi-wl-pprint-0.6.9
29+- tasty-1.2.3
30+- tasty-rerun-1.1.17
31+
14nix:
32nix:
15 packages: [zlib]
33 packages: [zlib]
16−allow-newer: true
stack88.yaml+6−2
@@ -1,7 +1,11 @@
1−resolver: nightly-2019-12-06
1+resolver: nightly-2020-02-13
2packages:
2packages:
3- .
3- .
4extra-deps:
4extra-deps:
5−allow-newer: true
5+- haskell-lsp-0.22.0.0
6+- haskell-lsp-types-0.22.0.0
7+- lsp-test-0.11.0.1
8+- ghc-check-0.3.0.1
9+- hie-bios-0.5.0
6nix:
10nix:
7 packages: [zlib]
11 packages: [zlib]
test/data/GotoHover.hsdeleted−34
@@ -1,34 +0,0 @@
1−{- HLINT ignore -}
2−module Testing ( module Testing )where
3−import Data.Text (Text, pack)
4−data TypeConstructor = DataConstructor
5− { fff :: Text
6− , ggg :: Int }
7−aaa :: TypeConstructor
8−aaa = DataConstructor
9− { fff = ""
10− , ggg = 0
11− }
12−bbb :: TypeConstructor
13−bbb = DataConstructor "" 0
14−ccc :: (Text, Int)
15−ccc = (fff bbb, ggg aaa)
16−ddd :: Num a => a -> a -> a
17−ddd vv ww = vv +! ww
18−a +! b = a - b
19−hhh (Just a) (><) = a >< a
20−iii a b = a `b` a
21−jjj s = pack $ s <> s
22−class Class a where
23− method :: a -> Int
24−instance Class Int where
25− method = succ
26−kkk :: Class a => Int -> a -> Int
27−kkk n c = n + method c
28−
29−doBind :: Maybe ()
30−doBind = do unwrapped <- Just ()
31− return unwrapped
32−
33−listCompBind :: [Char]
34−listCompBind = [ succ c | c <- "abc" ]
test/data/hover/Bar.hsnew file+3
@@ -0,0 +1,3 @@
1+module Bar (Bar(..)) where
2+
3+data Bar = Bar
test/data/hover/Foo.hsnew file+5
@@ -0,0 +1,5 @@
1+module Foo (Bar, foo) where
2+
3+import Bar
4+
5+foo = Bar
test/data/hover/GotoHover.hsnew file+57
@@ -0,0 +1,57 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{- HLINT ignore -}
3+module Testing ( module Testing ) where
4+import Data.Text (Text, pack)
5+import Foo (Bar, foo)
6+
7+
8+data TypeConstructor = DataConstructor
9+ { fff :: Text
10+ , ggg :: Int }
11+aaa :: TypeConstructor
12+aaa = DataConstructor
13+ { fff = "dfgy"
14+ , ggg = 832
15+ }
16+bbb :: TypeConstructor
17+bbb = DataConstructor "mjgp" 2994
18+ccc :: (Text, Int)
19+ccc = (fff bbb, ggg aaa)
20+ddd :: Num a => a -> a -> a
21+ddd vv ww = vv +! ww
22+a +! b = a - b
23+hhh (Just a) (><) = a >< a
24+iii a b = a `b` a
25+jjj s = pack $ s <> s
26+class MyClass a where
27+ method :: a -> Int
28+instance MyClass Int where
29+ method = succ
30+kkk :: MyClass a => Int -> a -> Int
31+kkk n c = n + method c
32+
33+doBind :: Maybe ()
34+doBind = do unwrapped <- Just ()
35+ return unwrapped
36+
37+listCompBind :: [Char]
38+listCompBind = [ succ c | c <- "ptfx" ]
39+
40+multipleClause :: Bool -> Char
41+multipleClause True = 't'
42+multipleClause False = 'f'
43+
44+-- | Recognizable docs: kpqz
45+documented :: Monad m => Either Int (m a)
46+documented = Left 7518
47+
48+listOfInt = [ 8391 :: Int, 6268 ]
49+
50+outer :: Bool
51+outer = undefined where
52+
53+ inner :: Char
54+ inner = undefined
55+
56+imported :: Bar
57+imported = foo
test/data/multi/a/A.hsnew file+3
@@ -0,0 +1,3 @@
1+module A(foo) where
2+
3+foo = ()
test/data/multi/a/a.cabalnew file+9
@@ -0,0 +1,9 @@
1+name: a
2+version: 1.0.0
3+build-type: Simple
4+cabal-version: >= 1.2
5+
6+library
7+ build-depends: base
8+ exposed-modules: A
9+ hs-source-dirs: .
test/data/multi/b/B.hsnew file+3
@@ -0,0 +1,3 @@
1+module B(module B) where
2+import A
3+qux = foo
test/data/multi/b/b.cabalnew file+9
@@ -0,0 +1,9 @@
1+name: b
2+version: 1.0.0
3+build-type: Simple
4+cabal-version: >= 1.2
5+
6+library
7+ build-depends: base, a
8+ exposed-modules: B
9+ hs-source-dirs: .
test/data/multi/cabal.projectnew file+1
@@ -0,0 +1 @@
1+packages: a b
test/data/multi/hie.yamlnew file+6
@@ -0,0 +1,6 @@
1+cradle:
2+ cabal:
3+ - path: "./a"
4+ component: "lib:a"
5+ - path: "./b"
6+ component: "lib:b"
test/exe/Main.hs+1731−171
@@ -1,48 +1,83 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4+{-# LANGUAGE AllowAmbiguousTypes #-}
4{-# LANGUAGE DuplicateRecordFields #-}
5{-# LANGUAGE DuplicateRecordFields #-}
6+{-# LANGUAGE PatternSynonyms #-}
5{-# LANGUAGE CPP #-}
7{-# LANGUAGE CPP #-}
6#include "ghc-api-version.h"
8#include "ghc-api-version.h"
7
9
8module Main (main) where
10module Main (main) where
9
11
10import Control.Applicative.Combinators
12import Control.Applicative.Combinators
13+import Control.Exception (bracket, catch)
14+import qualified Control.Lens as Lens
11import Control.Monad
15import Control.Monad
12import Control.Monad.IO.Class (liftIO)
16import Control.Monad.IO.Class (liftIO)
13−import Data.Char (toLower)
17+import Data.Aeson (FromJSON, Value)
14import Data.Foldable
18import Data.Foldable
19+import Data.List.Extra
20+import Data.Rope.UTF16 (Rope)
21+import qualified Data.Rope.UTF16 as Rope
22+import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
15import Development.IDE.GHC.Util
23import Development.IDE.GHC.Util
16import qualified Data.Text as T
24import qualified Data.Text as T
25+import Data.Typeable
26+import Development.IDE.Spans.Common
17import Development.IDE.Test
27import Development.IDE.Test
18import Development.IDE.Test.Runfiles
28import Development.IDE.Test.Runfiles
29+import Development.IDE.Types.Location
30+import Development.Shake (getDirectoryFilesIO)
19import Language.Haskell.LSP.Test
31import Language.Haskell.LSP.Test
32+import Language.Haskell.LSP.Messages
20import Language.Haskell.LSP.Types
33import Language.Haskell.LSP.Types
21import Language.Haskell.LSP.Types.Capabilities
34import Language.Haskell.LSP.Types.Capabilities
35+import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)
36+import Language.Haskell.LSP.VFS (applyChange)
37+import Network.URI
22−import System.Environment.Blank (setEnv)
38+import System.Environment.Blank (getEnv, setEnv, unsetEnv)
23import System.FilePath
39import System.FilePath
24import System.IO.Extra
40import System.IO.Extra
25import System.Directory
41import System.Directory
42+import Test.QuickCheck
43+import Test.QuickCheck.Instances ()
26import Test.Tasty
44import Test.Tasty
27−import Test.Tasty.HUnit
28import Test.Tasty.ExpectedFailure
45import Test.Tasty.ExpectedFailure
46+import Test.Tasty.Ingredients.Rerun
47+import Test.Tasty.HUnit
48+import Test.Tasty.QuickCheck
29import Data.Maybe
49import Data.Maybe
30
50
31main :: IO ()
51main :: IO ()
52+main = do
53+ -- We mess with env vars so run single-threaded.
54+ setEnv "TASTY_NUM_THREADS" "1" True
32−main = defaultMain $ testGroup "HIE"
55+ defaultMainWithRerun $ testGroup "HIE"
33− [ testSession "open close" $ do
56+ [ testSession "open close" $ do
34− doc <- openDoc' "Testing.hs" "haskell" ""
57+ doc <- createDoc "Testing.hs" "haskell" ""
35− void (message :: Session WorkDoneProgressCreateRequest)
58+ void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
36− void (message :: Session WorkDoneProgressBeginNotification)
59+ void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
37− closeDoc doc
60+ closeDoc doc
38− void (message :: Session WorkDoneProgressEndNotification)
61+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
39− , initializeResponseTests
62+ , initializeResponseTests
63+ , completionTests
64+ , cppTests
40− , diagnosticTests
65+ , diagnosticTests
41− , codeActionTests
66+ , codeActionTests
67+ , codeLensesTests
68+ , outlineTests
42− , findDefinitionAndHoverTests
69+ , findDefinitionAndHoverTests
43− , pluginTests
70+ , pluginTests
71+ , preprocessorTests
44− , thTests
72+ , thTests
73+ , safeTests
74+ , unitTests
75+ , haddockTests
76+ , positionMappingTests
77+ , watchedFilesTests
78+ , cradleTests
79+ , dependentFileTest
45− ]
80+ ]
46
81
47initializeResponseTests :: TestTree
82initializeResponseTests :: TestTree
48initializeResponseTests = withResource acquire release tests where
83initializeResponseTests = withResource acquire release tests where
@@ -57,14 +92,14 @@ initializeResponseTests = withResource acquire release tests where
57 testGroup "initialize response capabilities"
92 testGroup "initialize response capabilities"
58 [ chk " text doc sync" _textDocumentSync tds
93 [ chk " text doc sync" _textDocumentSync tds
59 , chk " hover" _hoverProvider (Just True)
94 , chk " hover" _hoverProvider (Just True)
60− , chk "NO completion" _completionProvider Nothing
95+ , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing)
61 , chk "NO signature help" _signatureHelpProvider Nothing
96 , chk "NO signature help" _signatureHelpProvider Nothing
62 , chk " goto definition" _definitionProvider (Just True)
97 , chk " goto definition" _definitionProvider (Just True)
63 , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)
98 , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)
64 , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic False)
99 , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic False)
65 , chk "NO find references" _referencesProvider Nothing
100 , chk "NO find references" _referencesProvider Nothing
66 , chk "NO doc highlight" _documentHighlightProvider Nothing
101 , chk "NO doc highlight" _documentHighlightProvider Nothing
67− , chk "NO doc symbol" _documentSymbolProvider Nothing
102+ , chk " doc symbol" _documentSymbolProvider (Just True)
68 , chk "NO workspace symbol" _workspaceSymbolProvider Nothing
103 , chk "NO workspace symbol" _workspaceSymbolProvider Nothing
69 , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True
104 , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True
70 , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing
105 , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing
@@ -77,8 +112,8 @@ initializeResponseTests = withResource acquire release tests where
77 , chk "NO doc link" _documentLinkProvider Nothing
112 , chk "NO doc link" _documentLinkProvider Nothing
78 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
113 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
79 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
114 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
80− , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
115+ , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
81− , chk "NO workspace" _workspace nothingWorkspace
116+ , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
82 , chk "NO experimental" _experimental Nothing
117 , chk "NO experimental" _experimental Nothing
83 ] where
118 ] where
84
119
@@ -89,14 +124,21 @@ initializeResponseTests = withResource acquire release tests where
89 , _willSaveWaitUntil = Nothing
124 , _willSaveWaitUntil = Nothing
90 , _save = Just (SaveOptions {_includeText = Nothing})}))
125 , _save = Just (SaveOptions {_includeText = Nothing})}))
91
126
92− nothingWorkspace = Just (WorkspaceOptions {_workspaceFolders = Nothing})
93−
94 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree
127 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree
95 chk title getActual expected =
128 chk title getActual expected =
96 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
129 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
97
130
131+ che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree
132+ che title getActual _expected = testCase title doTest
133+ where
134+ doTest = do
135+ ir <- getInitializeResponse
136+ let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir
137+ True @=? T.isSuffixOf "typesignature.add" command
138+
139+
98 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
99− innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c
141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
100 innerCaps _ = error "this test only expects inner capabilities"
142 innerCaps _ = error "this test only expects inner capabilities"
101
143
102 acquire :: IO InitializeResponse
144 acquire :: IO InitializeResponse
@@ -110,7 +152,7 @@ diagnosticTests :: TestTree
110diagnosticTests = testGroup "diagnostics"
152diagnosticTests = testGroup "diagnostics"
111 [ testSessionWait "fix syntax error" $ do
153 [ testSessionWait "fix syntax error" $ do
112 let content = T.unlines [ "module Testing wher" ]
154 let content = T.unlines [ "module Testing wher" ]
113− doc <- openDoc' "Testing.hs" "haskell" content
155+ doc <- createDoc "Testing.hs" "haskell" content
114 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
115 let change = TextDocumentContentChangeEvent
157 let change = TextDocumentContentChangeEvent
116 { _range = Just (Range (Position 0 15) (Position 0 19))
158 { _range = Just (Range (Position 0 15) (Position 0 19))
@@ -121,9 +163,9 @@ diagnosticTests = testGroup "diagnostics"
121 expectDiagnostics [("Testing.hs", [])]
163 expectDiagnostics [("Testing.hs", [])]
122 , testSessionWait "introduce syntax error" $ do
164 , testSessionWait "introduce syntax error" $ do
123 let content = T.unlines [ "module Testing where" ]
165 let content = T.unlines [ "module Testing where" ]
124− doc <- openDoc' "Testing.hs" "haskell" content
166+ doc <- createDoc "Testing.hs" "haskell" content
125− void (message :: Session WorkDoneProgressCreateRequest)
167+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
126− void (message :: Session WorkDoneProgressBeginNotification)
168+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
127 let change = TextDocumentContentChangeEvent
169 let change = TextDocumentContentChangeEvent
128 { _range = Just (Range (Position 0 15) (Position 0 18))
170 { _range = Just (Range (Position 0 15) (Position 0 18))
129 , _rangeLength = Nothing
171 , _rangeLength = Nothing
@@ -139,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"
139 , "bar :: Int -> Int -> Int"
181 , "bar :: Int -> Int -> Int"
140 , "bar a b = cd + b"
182 , "bar a b = cd + b"
141 ]
183 ]
142− _ <- openDoc' "Testing.hs" "haskell" content
184+ _ <- createDoc "Testing.hs" "haskell" content
143 expectDiagnostics
185 expectDiagnostics
144 [ ( "Testing.hs"
186 [ ( "Testing.hs"
145 , [ (DsError, (2, 14), "Variable not in scope: ab")
187 , [ (DsError, (2, 14), "Variable not in scope: ab")
@@ -153,7 +195,7 @@ diagnosticTests = testGroup "diagnostics"
153 , "foo :: Int -> String -> Int"
195 , "foo :: Int -> String -> Int"
154 , "foo a b = a + b"
196 , "foo a b = a + b"
155 ]
197 ]
156− _ <- openDoc' "Testing.hs" "haskell" content
198+ _ <- createDoc "Testing.hs" "haskell" content
157 expectDiagnostics
199 expectDiagnostics
158 [ ( "Testing.hs"
200 [ ( "Testing.hs"
159 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
@@ -165,7 +207,7 @@ diagnosticTests = testGroup "diagnostics"
165 , "foo :: Int -> String"
207 , "foo :: Int -> String"
166 , "foo a = _ a"
208 , "foo a = _ a"
167 ]
209 ]
168− _ <- openDoc' "Testing.hs" "haskell" content
210+ _ <- createDoc "Testing.hs" "haskell" content
169 expectDiagnostics
211 expectDiagnostics
170 [ ( "Testing.hs"
212 [ ( "Testing.hs"
171 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
@@ -187,24 +229,23 @@ diagnosticTests = testGroup "diagnostics"
187 [ ("A.hs", [(DsError, (2,4), aMessage)])
229 [ ("A.hs", [(DsError, (2,4), aMessage)])
188 , ("B.hs", [(DsError, (3,4), bMessage)])]
230 , ("B.hs", [(DsError, (3,4), bMessage)])]
189 deferralTest title binding msg = testSessionWait title $ do
231 deferralTest title binding msg = testSessionWait title $ do
190− _ <- openDoc' "A.hs" "haskell" $ sourceA binding
232+ _ <- createDoc "A.hs" "haskell" $ sourceA binding
191− _ <- openDoc' "B.hs" "haskell" sourceB
233+ _ <- createDoc "B.hs" "haskell" sourceB
192 expectDiagnostics $ expectedDs msg
234 expectDiagnostics $ expectedDs msg
193 in
235 in
194 [ deferralTest "type error" "True" "Couldn't match expected type"
236 [ deferralTest "type error" "True" "Couldn't match expected type"
195 , deferralTest "typed hole" "_" "Found hole"
237 , deferralTest "typed hole" "_" "Found hole"
196 , deferralTest "out of scope var" "unbound" "Variable not in scope"
238 , deferralTest "out of scope var" "unbound" "Variable not in scope"
197− , deferralTest "message shows error" "True" "A.hs:3:5: error:"
198 ]
239 ]
199
240
200 , testSessionWait "remove required module" $ do
241 , testSessionWait "remove required module" $ do
201 let contentA = T.unlines [ "module ModuleA where" ]
242 let contentA = T.unlines [ "module ModuleA where" ]
202− docA <- openDoc' "ModuleA.hs" "haskell" contentA
243+ docA <- createDoc "ModuleA.hs" "haskell" contentA
203 let contentB = T.unlines
244 let contentB = T.unlines
204 [ "module ModuleB where"
245 [ "module ModuleB where"
205 , "import ModuleA"
246 , "import ModuleA"
206 ]
247 ]
207− _ <- openDoc' "ModuleB.hs" "haskell" contentB
248+ _ <- createDoc "ModuleB.hs" "haskell" contentB
208 let change = TextDocumentContentChangeEvent
249 let change = TextDocumentContentChangeEvent
209 { _range = Just (Range (Position 0 0) (Position 0 20))
250 { _range = Just (Range (Position 0 0) (Position 0 20))
210 , _rangeLength = Nothing
251 , _rangeLength = Nothing
@@ -217,11 +258,21 @@ diagnosticTests = testGroup "diagnostics"
217 [ "module ModuleB where"
258 [ "module ModuleB where"
218 , "import ModuleA"
259 , "import ModuleA"
219 ]
260 ]
220− _ <- openDoc' "ModuleB.hs" "haskell" contentB
261+ _ <- createDoc "ModuleB.hs" "haskell" contentB
221 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
222 let contentA = T.unlines [ "module ModuleA where" ]
263 let contentA = T.unlines [ "module ModuleA where" ]
223− _ <- openDoc' "ModuleA.hs" "haskell" contentA
264+ _ <- createDoc "ModuleA.hs" "haskell" contentA
224 expectDiagnostics [("ModuleB.hs", [])]
265 expectDiagnostics [("ModuleB.hs", [])]
266+ , testSessionWait "add missing module (non workspace)" $ do
267+ let contentB = T.unlines
268+ [ "module ModuleB where"
269+ , "import ModuleA"
270+ ]
271+ _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB
272+ expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
273+ let contentA = T.unlines [ "module ModuleA where" ]
274+ _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA
275+ expectDiagnostics [("/tmp/ModuleB.hs", [])]
225 , testSessionWait "cyclic module dependency" $ do
276 , testSessionWait "cyclic module dependency" $ do
226 let contentA = T.unlines
277 let contentA = T.unlines
227 [ "module ModuleA where"
278 [ "module ModuleA where"
@@ -231,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"
231 [ "module ModuleB where"
282 [ "module ModuleB where"
232 , "import ModuleA"
283 , "import ModuleA"
233 ]
284 ]
234− _ <- openDoc' "ModuleA.hs" "haskell" contentA
285+ _ <- createDoc "ModuleA.hs" "haskell" contentA
235− _ <- openDoc' "ModuleB.hs" "haskell" contentB
286+ _ <- createDoc "ModuleB.hs" "haskell" contentB
236 expectDiagnostics
287 expectDiagnostics
237 [ ( "ModuleA.hs"
288 [ ( "ModuleA.hs"
238 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
@@ -253,9 +304,9 @@ diagnosticTests = testGroup "diagnostics"
253 let contentBboot = T.unlines
304 let contentBboot = T.unlines
254 [ "module ModuleB where"
305 [ "module ModuleB where"
255 ]
306 ]
256− _ <- openDoc' "ModuleA.hs" "haskell" contentA
307+ _ <- createDoc "ModuleA.hs" "haskell" contentA
257− _ <- openDoc' "ModuleB.hs" "haskell" contentB
308+ _ <- createDoc "ModuleB.hs" "haskell" contentB
258− _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
309+ _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
259 expectDiagnostics []
310 expectDiagnostics []
260 , testSessionWait "correct reference used with hs-boot" $ do
311 , testSessionWait "correct reference used with hs-boot" $ do
261 let contentB = T.unlines
312 let contentB = T.unlines
@@ -277,10 +328,10 @@ diagnosticTests = testGroup "diagnostics"
277 -- resolved to the hs-boot file
328 -- resolved to the hs-boot file
278 , "y = x"
329 , "y = x"
279 ]
330 ]
280− _ <- openDoc' "ModuleB.hs" "haskell" contentB
331+ _ <- createDoc "ModuleB.hs" "haskell" contentB
281− _ <- openDoc' "ModuleA.hs" "haskell" contentA
332+ _ <- createDoc "ModuleA.hs" "haskell" contentA
282− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
333+ _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot
283− _ <- openDoc' "ModuleC.hs" "haskell" contentC
334+ _ <- createDoc "ModuleC.hs" "haskell" contentC
284 expectDiagnostics []
335 expectDiagnostics []
285 , testSessionWait "redundant import" $ do
336 , testSessionWait "redundant import" $ do
286 let contentA = T.unlines ["module ModuleA where"]
337 let contentA = T.unlines ["module ModuleA where"]
@@ -289,8 +340,8 @@ diagnosticTests = testGroup "diagnostics"
289 , "module ModuleB where"
340 , "module ModuleB where"
290 , "import ModuleA"
341 , "import ModuleA"
291 ]
342 ]
292− _ <- openDoc' "ModuleA.hs" "haskell" contentA
343+ _ <- createDoc "ModuleA.hs" "haskell" contentA
293− _ <- openDoc' "ModuleB.hs" "haskell" contentB
344+ _ <- createDoc "ModuleB.hs" "haskell" contentB
294 expectDiagnostics
345 expectDiagnostics
295 [ ( "ModuleB.hs"
346 [ ( "ModuleB.hs"
296 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
@@ -299,6 +350,7 @@ diagnosticTests = testGroup "diagnostics"
299 , testSessionWait "package imports" $ do
350 , testSessionWait "package imports" $ do
300 let thisDataListContent = T.unlines
351 let thisDataListContent = T.unlines
301 [ "module Data.List where"
352 [ "module Data.List where"
353+ , "x :: Integer"
302 , "x = 123"
354 , "x = 123"
303 ]
355 ]
304 let mainContent = T.unlines
356 let mainContent = T.unlines
@@ -311,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"
311 , "wrong1 = ThisList.map"
363 , "wrong1 = ThisList.map"
312 , "wrong2 = BaseList.x"
364 , "wrong2 = BaseList.x"
313 ]
365 ]
314− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent
366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
315− _ <- openDoc' "Main.hs" "haskell" mainContent
367+ _ <- createDoc "Main.hs" "haskell" mainContent
316 expectDiagnostics
368 expectDiagnostics
317 [ ( "Main.hs"
369 [ ( "Main.hs"
318 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
@@ -327,7 +379,7 @@ diagnosticTests = testGroup "diagnostics"
327 , "foo :: Ord a => a -> Int"
379 , "foo :: Ord a => a -> Int"
328 , "foo a = 1"
380 , "foo a = 1"
329 ]
381 ]
330− _ <- openDoc' "Foo.hs" "haskell" fooContent
382+ _ <- createDoc "Foo.hs" "haskell" fooContent
331 expectDiagnostics
383 expectDiagnostics
332 [ ( "Foo.hs"
384 [ ( "Foo.hs"
333 -- The test is to make sure that warnings contain unqualified names
385 -- The test is to make sure that warnings contain unqualified names
@@ -352,18 +404,18 @@ diagnosticTests = testGroup "diagnostics"
352 Just pathB <- pure $ uriToFilePath uriB
404 Just pathB <- pure $ uriToFilePath uriB
353 uriB <- pure $
405 uriB <- pure $
354 let (drive, suffix) = splitDrive pathB
406 let (drive, suffix) = splitDrive pathB
355− in filePathToUri (joinDrive (map toLower drive ) suffix)
407+ in filePathToUri (joinDrive (lower drive) suffix)
356 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
408 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
357 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
409 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
358 uriA <- getDocUri "A/A.hs"
410 uriA <- getDocUri "A/A.hs"
359 Just pathA <- pure $ uriToFilePath uriA
411 Just pathA <- pure $ uriToFilePath uriA
360 uriA <- pure $
412 uriA <- pure $
361 let (drive, suffix) = splitDrive pathA
413 let (drive, suffix) = splitDrive pathA
362− in filePathToUri (joinDrive (map toLower drive ) suffix)
414+ in filePathToUri (joinDrive (lower drive) suffix)
363 let itemA = TextDocumentItem uriA "haskell" 0 aContent
415 let itemA = TextDocumentItem uriA "haskell" 0 aContent
364 let a = TextDocumentIdentifier uriA
416 let a = TextDocumentIdentifier uriA
365 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
417 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
366− diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
418+ diagsNot <- skipManyTill anyMessage diagnostic
367 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
419 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
368 -- Check that if we put a lower-case drive in for A.A
420 -- Check that if we put a lower-case drive in for A.A
369 -- the diagnostics for A.B will also be lower-case.
421 -- the diagnostics for A.B will also be lower-case.
@@ -372,6 +424,38 @@ diagnosticTests = testGroup "diagnostics"
372 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
424 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
373 assertFailure ("Expected redundant import but got " <> T.unpack msg)
425 assertFailure ("Expected redundant import but got " <> T.unpack msg)
374 closeDoc a
426 closeDoc a
427+ , testSessionWait "haddock parse error" $ do
428+ let fooContent = T.unlines
429+ [ "module Foo where"
430+ , "foo :: Int"
431+ , "foo = 1 {-|-}"
432+ ]
433+ _ <- createDoc "Foo.hs" "haskell" fooContent
434+ expectDiagnostics
435+ [ ( "Foo.hs"
436+ , [(DsError, (2, 8), "Parse error on input")
437+ ]
438+ )
439+ ]
440+ , testSessionWait "strip file path" $ do
441+ let
442+ name = "Testing"
443+ content = T.unlines
444+ [ "module " <> name <> " where"
445+ , "value :: Maybe ()"
446+ , "value = [()]"
447+ ]
448+ _ <- createDoc (T.unpack name <> ".hs") "haskell" content
449+ notification <- skipManyTill anyMessage diagnostic
450+ let
451+ offenders =
452+ Lsp.params .
453+ Lsp.diagnostics .
454+ Lens.folded .
455+ Lsp.message .
456+ Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))
457+ failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg
458+ Lens.mapMOf_ offenders failure notification
375 ]
459 ]
376
460
377codeActionTests :: TestTree
461codeActionTests :: TestTree
@@ -379,9 +463,46 @@ codeActionTests = testGroup "code actions"
379 [ renameActionTests
463 [ renameActionTests
380 , typeWildCardActionTests
464 , typeWildCardActionTests
381 , removeImportTests
465 , removeImportTests
466+ , extendImportTests
467+ , suggestImportTests
468+ , addExtensionTests
469+ , fixConstructorImportTests
382 , importRenameActionTests
470 , importRenameActionTests
383 , fillTypedHoleTests
471 , fillTypedHoleTests
384 , addSigActionTests
472 , addSigActionTests
473+ , insertNewDefinitionTests
474+ ]
475+
476+codeLensesTests :: TestTree
477+codeLensesTests = testGroup "code lenses"
478+ [ addSigLensesTests
479+ ]
480+
481+watchedFilesTests :: TestTree
482+watchedFilesTests = testGroup "watched files"
483+ [ testSession' "workspace files" $ \sessionDir -> do
484+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"
485+ _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
486+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
487+
488+ -- Expect 4 subscriptions (A does not get any because it's VFS):
489+ -- - /path-to-workspace/WatchedFilesMissingModule.hs
490+ -- - /path-to-workspace/WatchedFilesMissingModule.lhs
491+ -- - /path-to-workspace/src/WatchedFilesMissingModule.hs
492+ -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs
493+ liftIO $ length watchedFileRegs @?= 4
494+
495+ , testSession' "non workspace file" $ \sessionDir -> do
496+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
497+ _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
498+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
499+
500+ -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):
501+ -- - /path-to-workspace/WatchedFilesMissingModule.hs
502+ -- - /path-to-workspace/WatchedFilesMissingModule.lhs
503+ liftIO $ length watchedFileRegs @?= 2
504+
505+ -- TODO add a test for didChangeWorkspaceFolder
385 ]
506 ]
386
507
387renameActionTests :: TestTree
508renameActionTests :: TestTree
@@ -392,11 +513,9 @@ renameActionTests = testGroup "rename actions"
392 , "foo :: Int -> Int"
513 , "foo :: Int -> Int"
393 , "foo argName = argNme"
514 , "foo argName = argNme"
394 ]
515 ]
395− doc <- openDoc' "Testing.hs" "haskell" content
516+ doc <- createDoc "Testing.hs" "haskell" content
396 _ <- waitForDiagnostics
517 _ <- waitForDiagnostics
397− [CACodeAction action@CodeAction { _title = actionTitle }]
398− <- getCodeActions doc (Range (Position 2 14) (Position 2 20))
518+ action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
399− liftIO $ "Replace with ‘argName’" @=? actionTitle
400 executeCodeAction action
519 executeCodeAction action
401 contentAfterAction <- documentContents doc
520 contentAfterAction <- documentContents doc
402 let expectedContentAfterAction = T.unlines
521 let expectedContentAfterAction = T.unlines
@@ -412,11 +531,9 @@ renameActionTests = testGroup "rename actions"
412 , "foo :: Maybe a -> [a]"
531 , "foo :: Maybe a -> [a]"
413 , "foo = maybToList"
532 , "foo = maybToList"
414 ]
533 ]
415− doc <- openDoc' "Testing.hs" "haskell" content
534+ doc <- createDoc "Testing.hs" "haskell" content
416 _ <- waitForDiagnostics
535 _ <- waitForDiagnostics
417− [CACodeAction action@CodeAction { _title = actionTitle }]
418− <- getCodeActions doc (Range (Position 3 6) (Position 3 16))
536+ action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
419− liftIO $ "Replace with ‘maybeToList’" @=? actionTitle
420 executeCodeAction action
537 executeCodeAction action
421 contentAfterAction <- documentContents doc
538 contentAfterAction <- documentContents doc
422 let expectedContentAfterAction = T.unlines
539 let expectedContentAfterAction = T.unlines
@@ -432,12 +549,11 @@ renameActionTests = testGroup "rename actions"
432 , "foo :: Char -> Char -> Char -> Char"
549 , "foo :: Char -> Char -> Char -> Char"
433 , "foo argument1 argument2 argument3 = argumentX"
550 , "foo argument1 argument2 argument3 = argumentX"
434 ]
551 ]
435− doc <- openDoc' "Testing.hs" "haskell" content
552+ doc <- createDoc "Testing.hs" "haskell" content
436 _ <- waitForDiagnostics
553 _ <- waitForDiagnostics
437− actionsOrCommands <- getCodeActions doc (Range (Position 2 36) (Position 2 45))
554+ _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
438− let actionTitles = [ actionTitle | CACodeAction CodeAction{ _title = actionTitle } <- actionsOrCommands ]
439− expectedActionTitles = ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
555+ ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
440− liftIO $ expectedActionTitles @=? actionTitles
556+ return()
441 , testSession "change infix function" $ do
557 , testSession "change infix function" $ do
442 let content = T.unlines
558 let content = T.unlines
443 [ "module Testing where"
559 [ "module Testing where"
@@ -445,7 +561,7 @@ renameActionTests = testGroup "rename actions"
445 , "monus x y = max 0 (x - y)"
561 , "monus x y = max 0 (x - y)"
446 , "foo x y = x `monnus` y"
562 , "foo x y = x `monnus` y"
447 ]
563 ]
448− doc <- openDoc' "Testing.hs" "haskell" content
564+ doc <- createDoc "Testing.hs" "haskell" content
449 _ <- waitForDiagnostics
565 _ <- waitForDiagnostics
450 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
451 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
567 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
@@ -468,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
468 , "func :: _"
584 , "func :: _"
469 , "func x = x"
585 , "func x = x"
470 ]
586 ]
471− doc <- openDoc' "Testing.hs" "haskell" content
587+ doc <- createDoc "Testing.hs" "haskell" content
472 _ <- waitForDiagnostics
588 _ <- waitForDiagnostics
473 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
474 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -488,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
488 , "func :: _"
604 , "func :: _"
489 , "func x y = x + y"
605 , "func x y = x + y"
490 ]
606 ]
491− doc <- openDoc' "Testing.hs" "haskell" content
607+ doc <- createDoc "Testing.hs" "haskell" content
492 _ <- waitForDiagnostics
608 _ <- waitForDiagnostics
493 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
494 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -511,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
511 , " y = x * 2"
627 , " y = x * 2"
512 , " in y"
628 , " in y"
513 ]
629 ]
514− doc <- openDoc' "Testing.hs" "haskell" content
630+ doc <- createDoc "Testing.hs" "haskell" content
515 _ <- waitForDiagnostics
631 _ <- waitForDiagnostics
516 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
517 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -536,14 +652,15 @@ removeImportTests = testGroup "remove import actions"
536 let contentA = T.unlines
652 let contentA = T.unlines
537 [ "module ModuleA where"
653 [ "module ModuleA where"
538 ]
654 ]
539− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
540 let contentB = T.unlines
656 let contentB = T.unlines
541 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
542 , "module ModuleB where"
658 , "module ModuleB where"
543 , "import ModuleA"
659 , "import ModuleA"
660+ , "stuffB :: Integer"
544 , "stuffB = 123"
661 , "stuffB = 123"
545 ]
662 ]
546− docB <- openDoc' "ModuleB.hs" "haskell" contentB
663+ docB <- createDoc "ModuleB.hs" "haskell" contentB
547 _ <- waitForDiagnostics
664 _ <- waitForDiagnostics
548 [CACodeAction action@CodeAction { _title = actionTitle }]
665 [CACodeAction action@CodeAction { _title = actionTitle }]
549 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -553,6 +670,7 @@ removeImportTests = testGroup "remove import actions"
553 let expectedContentAfterAction = T.unlines
670 let expectedContentAfterAction = T.unlines
554 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
671 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
555 , "module ModuleB where"
672 , "module ModuleB where"
673+ , "stuffB :: Integer"
556 , "stuffB = 123"
674 , "stuffB = 123"
557 ]
675 ]
558 liftIO $ expectedContentAfterAction @=? contentAfterAction
676 liftIO $ expectedContentAfterAction @=? contentAfterAction
@@ -560,14 +678,15 @@ removeImportTests = testGroup "remove import actions"
560 let contentA = T.unlines
678 let contentA = T.unlines
561 [ "module ModuleA where"
679 [ "module ModuleA where"
562 ]
680 ]
563− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
564 let contentB = T.unlines
682 let contentB = T.unlines
565 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
566 , "module ModuleB where"
684 , "module ModuleB where"
567 , "import qualified ModuleA"
685 , "import qualified ModuleA"
686+ , "stuffB :: Integer"
568 , "stuffB = 123"
687 , "stuffB = 123"
569 ]
688 ]
570− docB <- openDoc' "ModuleB.hs" "haskell" contentB
689+ docB <- createDoc "ModuleB.hs" "haskell" contentB
571 _ <- waitForDiagnostics
690 _ <- waitForDiagnostics
572 [CACodeAction action@CodeAction { _title = actionTitle }]
691 [CACodeAction action@CodeAction { _title = actionTitle }]
573 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -577,10 +696,457 @@ removeImportTests = testGroup "remove import actions"
577 let expectedContentAfterAction = T.unlines
696 let expectedContentAfterAction = T.unlines
578 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
697 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
579 , "module ModuleB where"
698 , "module ModuleB where"
699+ , "stuffB :: Integer"
580 , "stuffB = 123"
700 , "stuffB = 123"
581 ]
701 ]
582 liftIO $ expectedContentAfterAction @=? contentAfterAction
702 liftIO $ expectedContentAfterAction @=? contentAfterAction
703+ , testSession "redundant binding" $ do
704+ let contentA = T.unlines
705+ [ "module ModuleA where"
706+ , "stuffA = False"
707+ , "stuffB :: Integer"
708+ , "stuffB = 123"
709+ , "stuffC = ()"
710+ ]
711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
712+ let contentB = T.unlines
713+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
714+ , "module ModuleB where"
715+ , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
716+ , "main = print stuffB"
717+ ]
718+ docB <- createDoc "ModuleB.hs" "haskell" contentB
719+ _ <- waitForDiagnostics
720+ [CACodeAction action@CodeAction { _title = actionTitle }]
721+ <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
722+ liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle
723+ executeCodeAction action
724+ contentAfterAction <- documentContents docB
725+ let expectedContentAfterAction = T.unlines
726+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
727+ , "module ModuleB where"
728+ , "import ModuleA (stuffB)"
729+ , "main = print stuffB"
730+ ]
731+ liftIO $ expectedContentAfterAction @=? contentAfterAction
732+ , testSession "redundant operator" $ do
733+ let contentA = T.unlines
734+ [ "module ModuleA where"
735+ , "a !! b = a"
736+ , "a <?> b = a"
737+ , "stuffB :: Integer"
738+ , "stuffB = 123"
739+ ]
740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
741+ let contentB = T.unlines
742+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
743+ , "module ModuleB where"
744+ , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
745+ , "main = print A.stuffB"
746+ ]
747+ docB <- createDoc "ModuleB.hs" "haskell" contentB
748+ _ <- waitForDiagnostics
749+ [CACodeAction action@CodeAction { _title = actionTitle }]
750+ <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
751+ liftIO $ "Remove !!, <?> from import" @=? actionTitle
752+ executeCodeAction action
753+ contentAfterAction <- documentContents docB
754+ let expectedContentAfterAction = T.unlines
755+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
756+ , "module ModuleB where"
757+ , "import qualified ModuleA as A (stuffB)"
758+ , "main = print A.stuffB"
759+ ]
760+ liftIO $ expectedContentAfterAction @=? contentAfterAction
761+ , testSession "redundant all import" $ do
762+ let contentA = T.unlines
763+ [ "module ModuleA where"
764+ , "data A = A"
765+ , "stuffB :: Integer"
766+ , "stuffB = 123"
767+ ]
768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
769+ let contentB = T.unlines
770+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
771+ , "module ModuleB where"
772+ , "import ModuleA (A(..), stuffB)"
773+ , "main = print stuffB"
774+ ]
775+ docB <- createDoc "ModuleB.hs" "haskell" contentB
776+ _ <- waitForDiagnostics
777+ [CACodeAction action@CodeAction { _title = actionTitle }]
778+ <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
779+ liftIO $ "Remove A from import" @=? actionTitle
780+ executeCodeAction action
781+ contentAfterAction <- documentContents docB
782+ let expectedContentAfterAction = T.unlines
783+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
784+ , "module ModuleB where"
785+ , "import ModuleA (stuffB)"
786+ , "main = print stuffB"
787+ ]
788+ liftIO $ expectedContentAfterAction @=? contentAfterAction
789+ , testSession "redundant constructor import" $ do
790+ let contentA = T.unlines
791+ [ "module ModuleA where"
792+ , "data D = A | B"
793+ , "data E = F"
794+ ]
795+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
796+ let contentB = T.unlines
797+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
798+ , "module ModuleB where"
799+ , "import ModuleA (D(A,B), E(F))"
800+ , "main = B"
801+ ]
802+ docB <- createDoc "ModuleB.hs" "haskell" contentB
803+ _ <- waitForDiagnostics
804+ [CACodeAction action@CodeAction { _title = actionTitle }]
805+ <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
806+ liftIO $ "Remove A, E, F from import" @=? actionTitle
807+ executeCodeAction action
808+ contentAfterAction <- documentContents docB
809+ let expectedContentAfterAction = T.unlines
810+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"
811+ , "module ModuleB where"
812+ , "import ModuleA (D(B))"
813+ , "main = B"
814+ ]
815+ liftIO $ expectedContentAfterAction @=? contentAfterAction
816+ ]
817+
818+extendImportTests :: TestTree
819+extendImportTests = testGroup "extend import actions"
820+ [ testSession "extend single line import with value" $ template
821+ (T.unlines
822+ [ "module ModuleA where"
823+ , "stuffA :: Double"
824+ , "stuffA = 0.00750"
825+ , "stuffB :: Integer"
826+ , "stuffB = 123"
827+ ])
828+ (T.unlines
829+ [ "module ModuleB where"
830+ , "import ModuleA as A (stuffB)"
831+ , "main = print (stuffA, stuffB)"
832+ ])
833+ (Range (Position 3 17) (Position 3 18))
834+ "Add stuffA to the import list of ModuleA"
835+ (T.unlines
836+ [ "module ModuleB where"
837+ , "import ModuleA as A (stuffA, stuffB)"
838+ , "main = print (stuffA, stuffB)"
839+ ])
840+ , testSession "extend single line import with operator" $ template
841+ (T.unlines
842+ [ "module ModuleA where"
843+ , "(.*) :: Integer -> Integer -> Integer"
844+ , "x .* y = x * y"
845+ , "stuffB :: Integer"
846+ , "stuffB = 123"
847+ ])
848+ (T.unlines
849+ [ "module ModuleB where"
850+ , "import ModuleA as A (stuffB)"
851+ , "main = print (stuffB .* stuffB)"
852+ ])
853+ (Range (Position 3 17) (Position 3 18))
854+ "Add .* to the import list of ModuleA"
855+ (T.unlines
856+ [ "module ModuleB where"
857+ , "import ModuleA as A ((.*), stuffB)"
858+ , "main = print (stuffB .* stuffB)"
859+ ])
860+ , testSession "extend single line import with type" $ template
861+ (T.unlines
862+ [ "module ModuleA where"
863+ , "type A = Double"
864+ ])
865+ (T.unlines
866+ [ "module ModuleB where"
867+ , "import ModuleA ()"
868+ , "b :: A"
869+ , "b = 0"
870+ ])
871+ (Range (Position 2 5) (Position 2 5))
872+ "Add A to the import list of ModuleA"
873+ (T.unlines
874+ [ "module ModuleB where"
875+ , "import ModuleA (A)"
876+ , "b :: A"
877+ , "b = 0"
878+ ])
879+ , (`xfail` "known broken") $ testSession "extend single line import with constructor" $ template
880+ (T.unlines
881+ [ "module ModuleA where"
882+ , "data A = Constructor"
883+ ])
884+ (T.unlines
885+ [ "module ModuleB where"
886+ , "import ModuleA (A)"
887+ , "b :: A"
888+ , "b = Constructor"
889+ ])
890+ (Range (Position 2 5) (Position 2 5))
891+ "Add Constructor to the import list of ModuleA"
892+ (T.unlines
893+ [ "module ModuleB where"
894+ , "import ModuleA (A(Constructor))"
895+ , "b :: A"
896+ , "b = Constructor"
897+ ])
898+ , testSession "extend single line qualified import with value" $ template
899+ (T.unlines
900+ [ "module ModuleA where"
901+ , "stuffA :: Double"
902+ , "stuffA = 0.00750"
903+ , "stuffB :: Integer"
904+ , "stuffB = 123"
905+ ])
906+ (T.unlines
907+ [ "module ModuleB where"
908+ , "import qualified ModuleA as A (stuffB)"
909+ , "main = print (A.stuffA, A.stuffB)"
910+ ])
911+ (Range (Position 3 17) (Position 3 18))
912+ "Add stuffA to the import list of ModuleA"
913+ (T.unlines
914+ [ "module ModuleB where"
915+ , "import qualified ModuleA as A (stuffA, stuffB)"
916+ , "main = print (A.stuffA, A.stuffB)"
917+ ])
918+ , testSession "extend multi line import with value" $ template
919+ (T.unlines
920+ [ "module ModuleA where"
921+ , "stuffA :: Double"
922+ , "stuffA = 0.00750"
923+ , "stuffB :: Integer"
924+ , "stuffB = 123"
925+ ])
926+ (T.unlines
927+ [ "module ModuleB where"
928+ , "import ModuleA (stuffB"
929+ , " )"
930+ , "main = print (stuffA, stuffB)"
931+ ])
932+ (Range (Position 3 17) (Position 3 18))
933+ "Add stuffA to the import list of ModuleA"
934+ (T.unlines
935+ [ "module ModuleB where"
936+ , "import ModuleA (stuffA, stuffB"
937+ , " )"
938+ , "main = print (stuffA, stuffB)"
939+ ])
940+ ]
941+ where
942+ template contentA contentB range expectedAction expectedContentB = do
943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
944+ docB <- createDoc "ModuleB.hs" "haskell" contentB
945+ _ <- waitForDiagnostics
946+ CACodeAction action@CodeAction { _title = actionTitle } : _
947+ <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
948+ getCodeActions docB range
949+ liftIO $ expectedAction @=? actionTitle
950+ executeCodeAction action
951+ contentAfterAction <- documentContents docB
952+ liftIO $ expectedContentB @=? contentAfterAction
953+
954+suggestImportTests :: TestTree
955+suggestImportTests = testGroup "suggest import actions"
956+ [ testGroup "Dont want suggestion"
957+ [ -- extend import
958+ test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
959+ -- data constructor
960+ , test False [] "f = First" [] "import Data.Monoid (First)"
961+ -- internal module
962+ , test False [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable.Internal (Typeable)"
963+ -- package not in scope
964+ , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)"
965+ ]
966+ , testGroup "want suggestion"
967+ [ test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
968+ , test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))"
969+ , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)"
970+ , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (NonEmpty)"
971+ , test True [] "f = First" [] "import Data.Monoid (First(First))"
972+ , test True [] "f = Endo" [] "import Data.Monoid (Endo(Endo))"
973+ , test True [] "f = Version" [] "import Data.Version (Version(Version))"
974+ , test True [] "f ExitSuccess = ()" [] "import System.Exit (ExitCode(ExitSuccess))"
975+ , test True [] "f = AssertionFailed" [] "import Control.Exception (AssertionFailed(AssertionFailed))"
976+ , test True ["Prelude"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
977+ , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)"
978+ , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))"
979+ , test True [] "f = (&)" [] "import Data.Function ((&))"
980+ , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE"
981+ , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"
982+ , test True [] "f = pack" [] "import Data.Text (pack)"
983+ , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)"
984+ , test True [] "f = [] & id" [] "import Data.Function ((&))"
985+ , test True [] "f = (&) [] id" [] "import Data.Function ((&))"
986+ ]
987+ ]
988+ where
989+ test wanted imps def other newImp = testSession' (T.unpack def) $ \dir -> do
990+ let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other
991+ after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
992+ cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"
993+ liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
994+ doc <- createDoc "Test.hs" "haskell" before
995+ _diags <- waitForDiagnostics
996+ let defLine = length imps + 1
997+ range = Range (Position defLine 0) (Position defLine maxBound)
998+ actions <- getCodeActions doc range
999+ if wanted
1000+ then do
1001+ action <- liftIO $ pickActionWithTitle newImp actions
1002+ executeCodeAction action
1003+ contentAfterAction <- documentContents doc
1004+ liftIO $ after @=? contentAfterAction
1005+ else
1006+ liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
1007+
1008+
1009+addExtensionTests :: TestTree
1010+addExtensionTests = testGroup "add language extension actions"
1011+ [ testSession "add NamedFieldPuns language extension" $ template
1012+ (T.unlines
1013+ [ "module Module where"
1014+ , ""
1015+ , "data A = A { getA :: Bool }"
1016+ , ""
1017+ , "f :: A -> Bool"
1018+ , "f A { getA } = getA"
1019+ ])
1020+ (Range (Position 0 0) (Position 0 0))
1021+ "Add NamedFieldPuns extension"
1022+ (T.unlines
1023+ [ "{-# LANGUAGE NamedFieldPuns #-}"
1024+ , "module Module where"
1025+ , ""
1026+ , "data A = A { getA :: Bool }"
1027+ , ""
1028+ , "f :: A -> Bool"
1029+ , "f A { getA } = getA"
1030+ ])
1031+ , testSession "add RecordWildCards language extension" $ template
1032+ (T.unlines
1033+ [ "module Module where"
1034+ , ""
1035+ , "data A = A { getA :: Bool }"
1036+ , ""
1037+ , "f :: A -> Bool"
1038+ , "f A { .. } = getA"
1039+ ])
1040+ (Range (Position 0 0) (Position 0 0))
1041+ "Add RecordWildCards extension"
1042+ (T.unlines
1043+ [ "{-# LANGUAGE RecordWildCards #-}"
1044+ , "module Module where"
1045+ , ""
1046+ , "data A = A { getA :: Bool }"
1047+ , ""
1048+ , "f :: A -> Bool"
1049+ , "f A { .. } = getA"
1050+ ])
583 ]
1051 ]
1052+ where
1053+ template initialContent range expectedAction expectedContents = do
1054+ doc <- createDoc "Module.hs" "haskell" initialContent
1055+ _ <- waitForDiagnostics
1056+ CACodeAction action@CodeAction { _title = actionTitle } : _
1057+ <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1058+ getCodeActions doc range
1059+ liftIO $ expectedAction @=? actionTitle
1060+ executeCodeAction action
1061+ contentAfterAction <- documentContents doc
1062+ liftIO $ expectedContents @=? contentAfterAction
1063+
1064+
1065+insertNewDefinitionTests :: TestTree
1066+insertNewDefinitionTests = testGroup "insert new definition actions"
1067+ [ testSession "insert new function definition" $ do
1068+ let txtB =
1069+ ["foo True = select [True]"
1070+ , ""
1071+ ,"foo False = False"
1072+ ]
1073+ txtB' =
1074+ [""
1075+ ,"someOtherCode = ()"
1076+ ]
1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1078+ _ <- waitForDiagnostics
1079+ CACodeAction action@CodeAction { _title = actionTitle } : _
1080+ <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1081+ getCodeActions docB (R 1 0 1 50)
1082+ liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"
1083+ executeCodeAction action
1084+ contentAfterAction <- documentContents docB
1085+ liftIO $ contentAfterAction @?= T.unlines (txtB ++
1086+ [ ""
1087+ , "select :: [Bool] -> Bool"
1088+ , "select = error \"not implemented\""
1089+ ]
1090+ ++ txtB')
1091+ , testSession "define a hole" $ do
1092+ let txtB =
1093+ ["foo True = _select [True]"
1094+ , ""
1095+ ,"foo False = False"
1096+ ]
1097+ txtB' =
1098+ [""
1099+ ,"someOtherCode = ()"
1100+ ]
1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1102+ _ <- waitForDiagnostics
1103+ CACodeAction action@CodeAction { _title = actionTitle } : _
1104+ <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1105+ getCodeActions docB (R 1 0 1 50)
1106+ liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"
1107+ executeCodeAction action
1108+ contentAfterAction <- documentContents docB
1109+ liftIO $ contentAfterAction @?= T.unlines (
1110+ ["foo True = select [True]"
1111+ , ""
1112+ ,"foo False = False"
1113+ , ""
1114+ , "select :: [Bool] -> Bool"
1115+ , "select = error \"not implemented\""
1116+ ]
1117+ ++ txtB')
1118+ ]
1119+
1120+fixConstructorImportTests :: TestTree
1121+fixConstructorImportTests = testGroup "fix import actions"
1122+ [ testSession "fix constructor import" $ template
1123+ (T.unlines
1124+ [ "module ModuleA where"
1125+ , "data A = Constructor"
1126+ ])
1127+ (T.unlines
1128+ [ "module ModuleB where"
1129+ , "import ModuleA(Constructor)"
1130+ ])
1131+ (Range (Position 1 10) (Position 1 11))
1132+ "Fix import of A(Constructor)"
1133+ (T.unlines
1134+ [ "module ModuleB where"
1135+ , "import ModuleA(A(Constructor))"
1136+ ])
1137+ ]
1138+ where
1139+ template contentA contentB range expectedAction expectedContentB = do
1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB
1142+ _diags <- waitForDiagnostics
1143+ CACodeAction action@CodeAction { _title = actionTitle } : _
1144+ <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1145+ getCodeActions docB range
1146+ liftIO $ expectedAction @=? actionTitle
1147+ executeCodeAction action
1148+ contentAfterAction <- documentContents docB
1149+ liftIO $ expectedContentB @=? contentAfterAction
584
1150
585importRenameActionTests :: TestTree
1151importRenameActionTests :: TestTree
586importRenameActionTests = testGroup "import rename actions"
1152importRenameActionTests = testGroup "import rename actions"
@@ -591,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"
591 [ "module Testing where"
1157 [ "module Testing where"
592 , "import Data.Mape"
1158 , "import Data.Mape"
593 ]
1159 ]
594− doc <- openDoc' "Testing.hs" "haskell" content
1160+ doc <- createDoc "Testing.hs" "haskell" content
595 _ <- waitForDiagnostics
1161 _ <- waitForDiagnostics
596 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
1162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
597 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
1163 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
@@ -628,10 +1194,10 @@ fillTypedHoleTests = let
628 newA newB newC = testSession (T.unpack actionTitle) $ do
1194 newA newB newC = testSession (T.unpack actionTitle) $ do
629 let originalCode = sourceCode oldA oldB oldC
1195 let originalCode = sourceCode oldA oldB oldC
630 let expectedCode = sourceCode newA newB newC
1196 let expectedCode = sourceCode newA newB newC
631− doc <- openDoc' "Testing.hs" "haskell" originalCode
1197+ doc <- createDoc "Testing.hs" "haskell" originalCode
632 _ <- waitForDiagnostics
1198 _ <- waitForDiagnostics
633 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
1199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
634− let chosenAction = pickActionWithTitle actionTitle actionsOrCommands
1200+ chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
635 executeCodeAction chosenAction
1201 executeCodeAction chosenAction
636 modifiedCode <- documentContents doc
1202 modifiedCode <- documentContents doc
637 liftIO $ expectedCode @=? modifiedCode
1203 liftIO $ expectedCode @=? modifiedCode
@@ -668,47 +1234,81 @@ fillTypedHoleTests = let
668
1234
669addSigActionTests :: TestTree
1235addSigActionTests :: TestTree
670addSigActionTests = let
1236addSigActionTests = let
671− header = T.unlines [ "{-# OPTIONS_GHC -Wmissing-signatures #-}"
1237+ header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"
672− , "module Sigs where"]
1238+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
673− before def = T.unlines [header, def]
1239+ before def = T.unlines [header, moduleH, def]
674− after' def sig = T.unlines [header, sig, def]
1240+ after' def sig = T.unlines [header, moduleH, sig, def]
675
1241
676 def >:: sig = testSession (T.unpack def) $ do
1242 def >:: sig = testSession (T.unpack def) $ do
677 let originalCode = before def
1243 let originalCode = before def
678− let expectedCode = after' def sig
1244+ let expectedCode = after' def sig
679− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode
680 _ <- waitForDiagnostics
1246 _ <- waitForDiagnostics
681 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
1247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
682− let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
1248+ chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
683 executeCodeAction chosenAction
1249 executeCodeAction chosenAction
684 modifiedCode <- documentContents doc
1250 modifiedCode <- documentContents doc
685 liftIO $ expectedCode @=? modifiedCode
1251 liftIO $ expectedCode @=? modifiedCode
686 in
1252 in
687 testGroup "add signature"
1253 testGroup "add signature"
688− [ "abc = True" >:: "abc :: Bool"
1254+ [ "abc = True" >:: "abc :: Bool"
689− , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
1255+ , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
690− , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"
1256+ , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"
691− , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
1257+ , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
692− , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
1258+ , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
693− , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"
1259+ , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"
1260+ , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"
694− ]
1261+ ]
695
1262
696−findDefinitionAndHoverTests :: TestTree
1263+addSigLensesTests :: TestTree
697−findDefinitionAndHoverTests = let
1264+addSigLensesTests = let
1265+ missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"
1266+ notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"
1267+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
1268+ other = T.unlines ["f :: Integer -> Integer", "f x = 3"]
1269+ before withMissing def
1270+ = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]
1271+ after' withMissing def sig
1272+ = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other]
698
1273
699− tst (get, check) pos targetRange title = testSession title $ do
1274+ sigSession withMissing def sig = testSession (T.unpack def) $ do
700− doc <- openTestDataDoc sourceFilePath
1275+ let originalCode = before withMissing def
701− found <- get doc pos
1276+ let expectedCode = after' withMissing def sig
702− check found targetRange
1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode
1278+ [CodeLens {_command = Just c}] <- getCodeLenses doc
1279+ executeCommand c
1280+ modifiedCode <- getDocumentEdit doc
1281+ liftIO $ expectedCode @=? modifiedCode
1282+ in
1283+ testGroup "add signature"
1284+ [ testGroup title
1285+ [ sigSession enableWarnings "abc = True" "abc :: Bool"
1286+ , sigSession enableWarnings "foo a b = a + b" "foo :: Num a => a -> a -> a"
1287+ , sigSession enableWarnings "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"
1288+ , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
1289+ , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
1290+ , sigSession enableWarnings "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"
1291+ , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a"
1292+ ]
1293+ | (title, enableWarnings) <-
1294+ [("with warnings enabled", True)
1295+ ,("with warnings disabled", False)
1296+ ]
1297+ ]
703
1298
704− checkDefs :: [Location] -> [Expect] -> Session ()
1299+checkDefs :: [Location] -> Session [Expect] -> Session ()
705− checkDefs defs expectations = traverse_ check expectations where
1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
706
1301
707− check (ExpectRange expectedRange) = do
1302+ check (ExpectRange expectedRange) = do
708− assertNDefinitionsFound 1 defs
1303+ assertNDefinitionsFound 1 defs
709− assertRangeCorrect (head defs) expectedRange
1304+ assertRangeCorrect (head defs) expectedRange
1305+ check (ExpectLocation expectedLocation) = do
1306+ assertNDefinitionsFound 1 defs
1307+ liftIO $ head defs @?= expectedLocation
1308+ check ExpectNoDefinitions = do
1309+ assertNDefinitionsFound 0 defs
710− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1310+ check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
711− check _ = pure () -- all other expectations not relevant to getDefinition
1311+ check _ = pure () -- all other expectations not relevant to getDefinition
712
1312
713 assertNDefinitionsFound :: Int -> [a] -> Session ()
1313 assertNDefinitionsFound :: Int -> [a] -> Session ()
714 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
1314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
@@ -716,23 +1316,35 @@ findDefinitionAndHoverTests = let
716 assertRangeCorrect Location{_range = foundRange} expectedRange =
1316 assertRangeCorrect Location{_range = foundRange} expectedRange =
717 liftIO $ expectedRange @=? foundRange
1317 liftIO $ expectedRange @=? foundRange
718
1318
1319+
1320+findDefinitionAndHoverTests :: TestTree
1321+findDefinitionAndHoverTests = let
1322+
1323+ tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do
1324+ doc <- openTestDataDoc (dir </> sourceFilePath)
1325+ found <- get doc pos
1326+ check found targetRange
1327+
1328+
1329+
719− checkHover :: Maybe Hover -> [Expect] -> Session ()
1330+ checkHover :: Maybe Hover -> Session [Expect] -> Session ()
720− checkHover hover expectations = traverse_ check expectations where
1331+ checkHover hover expectations = traverse_ check =<< expectations where
721
1332
722 check expected =
1333 check expected =
723 case hover of
1334 case hover of
724− Nothing -> liftIO $ assertFailure "no hover found"
1335+ Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
725 Just Hover{_contents = (HoverContents MarkupContent{_value = msg})
1336 Just Hover{_contents = (HoverContents MarkupContent{_value = msg})
726 ,_range = rangeInHover } ->
1337 ,_range = rangeInHover } ->
727 case expected of
1338 case expected of
728 ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
1339 ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
729 ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
1340 ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
730 ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
1341 ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
1342+ ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover
731 _ -> pure () -- all other expectations not relevant to hover
1343 _ -> pure () -- all other expectations not relevant to hover
732 _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
1344 _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
733
1345
734 extractLineColFromHoverMsg :: T.Text -> [T.Text]
1346 extractLineColFromHoverMsg :: T.Text -> [T.Text]
735− extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "**" . last . T.splitOn (sourceFileName <> ":")
1347+ extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")
736
1348
737 checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()
1349 checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()
738 checkHoverRange expectedRange rangeInHover msg =
1350 checkHoverRange expectedRange rangeInHover msg =
@@ -759,9 +1371,12 @@ findDefinitionAndHoverTests = let
759
1371
760 mkFindTests tests = testGroup "get"
1372 mkFindTests tests = testGroup "get"
761 [ testGroup "definition" $ mapMaybe fst tests
1373 [ testGroup "definition" $ mapMaybe fst tests
762− , testGroup "hover" $ mapMaybe snd tests ]
1374+ , testGroup "hover" $ mapMaybe snd tests
1375+ , checkFileCompiles sourceFilePath ]
1376+
1377+ test runDef runHover look expect = testM runDef runHover look (return expect)
763
1378
764− test runDef runHover look expect title =
1379+ testM runDef runHover look expect title =
765 ( runDef $ tst def look expect title
1380 ( runDef $ tst def look expect title
766 , runHover $ tst hover look expect title ) where
1381 , runHover $ tst hover look expect title ) where
767 def = (getDefinitions, checkDefs)
1382 def = (getDefinitions, checkDefs)
@@ -769,59 +1384,100 @@ findDefinitionAndHoverTests = let
769 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
1384 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
770
1385
771 -- search locations expectations on results
1386 -- search locations expectations on results
772− fffL4 = _start fffR ; fffR = mkRange 4 4 4 7 ; fff = [ExpectRange fffR]
1387+ fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR]
773− fffL8 = Position 8 4 ;
1388+ fffL8 = Position 12 4 ;
774− fffL14 = Position 14 7 ;
1389+ fffL14 = Position 18 7 ;
775− aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]
1390+ aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]
776− dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]
1391+ dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]
777− dcL12 = Position 12 11 ;
1392+ dcL12 = Position 16 11 ;
778− xtcL5 = Position 5 11 ; xtc = [ExpectExternFail]
1393+ xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
779− tcL6 = Position 6 11 ; tcData = [mkR 3 0 5 16]
1394+ tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]]
780− vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]
1395+ vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6]
781− opL16 = Position 16 15 ; op = [mkR 17 2 17 4]
1396+ opL16 = Position 20 15 ; op = [mkR 21 2 21 4]
782− opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]
1397+ opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]
783− aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]
1398+ aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]
784− b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]
1399+ b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]
785− xvL20 = Position 20 8 ; xvMsg = [ExpectHoverText ["Data.Text.pack", ":: String -> Text"], ExpectExternFail]
1400+ xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
786− clL23 = Position 23 11 ; cls = [mkR 21 0 22 20]
1401+ clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]]
787− clL25 = Position 25 9
1402+ clL25 = Position 29 9
788− eclL15 = Position 15 8 ; ecls = [ExpectHoverText ["Num"], ExpectExternFail]
1403+ eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
789− dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]
1404+ dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21]
790− dnbL30 = Position 30 23
1405+ dnbL30 = Position 34 23
791− lcbL33 = Position 33 26 ; lcb = [ExpectHoverText [":: Char"], mkR 33 26 33 27]
1406+ lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27]
792− lclL33 = Position 33 22
1407+ lclL33 = Position 37 22
1408+ mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14]
1409+ mclL37 = Position 41 1
1410+ spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1411+ docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1412+ ; constr = [ExpectHoverText ["Monad m"]]
1413+ eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1414+ intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]]
1415+ tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1416+ intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]]
1417+ chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]]
1418+ txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1419+ lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1420+ outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
1421+ innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
1422+ imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo"], mkL foo 4 0 4 3]
1423+ reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar"], mkL bar 2 0 2 14]
793 in
1424 in
794 mkFindTests
1425 mkFindTests
795− -- def hover look expect
1426+ -- def hover look expect
796− [ test yes yes fffL4 fff "field in record definition"
1427+ [ test yes yes fffL4 fff "field in record definition"
797− , test broken broken fffL8 fff "field in record construction"
1428+ , test broken broken fffL8 fff "field in record construction #71"
798− , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
1429+ , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
799− , test yes yes aaaL14 aaa "top-level name" -- 120
1430+ , test yes yes aaaL14 aaa "top-level name" -- 120
800− , test broken broken dcL7 tcDC "record data constructor"
1431+ , test yes yes dcL7 tcDC "data constructor record #247"
801− , test yes yes dcL12 tcDC "plain data constructor" -- 121
1432+ , test yes yes dcL12 tcDC "data constructor plain" -- 121
802− , test yes broken tcL6 tcData "type constructor" -- 147
1433+ , test yes yes tcL6 tcData "type constructor #248" -- 147
803− , test broken broken xtcL5 xtc "type constructor from other package"
1434+ , test broken yes xtcL5 xtc "type constructor external #248,249"
804− , test broken yes xvL20 xvMsg "value from other package" -- 120
1435+ , test broken yes xvL20 xvMsg "value external package #249" -- 120
805− , test yes yes vvL16 vv "plain parameter" -- 120
1436+ , test yes yes vvL16 vv "plain parameter" -- 120
806− , test yes yes aL18 apmp "pattern match name" -- 120
1437+ , test yes yes aL18 apmp "pattern match name" -- 120
807− , test yes yes opL16 op "top-level operator" -- 120, 123
1438+ , test yes yes opL16 op "top-level operator" -- 120, 123
808− , test yes yes opL18 opp "parameter operator" -- 120
1439+ , test yes yes opL18 opp "parameter operator" -- 120
809− , test yes yes b'L19 bp "name in backticks" -- 120
1440+ , test yes yes b'L19 bp "name in backticks" -- 120
810− , test yes broken clL23 cls "class in instance declaration"
1441+ , test yes yes clL23 cls "class in instance declaration #250"
811− , test yes broken clL25 cls "class in signature" -- 147
1442+ , test yes yes clL25 cls "class in signature #250" -- 147
812− , test broken broken eclL15 ecls "external class in signature"
1443+ , test broken yes eclL15 ecls "external class in signature #249,250"
813− , test yes yes dnbL29 dnb "do-notation bind" -- 137
1444+ , test yes yes dnbL29 dnb "do-notation bind" -- 137
814− , test yes yes dnbL30 dnb "do-notation lookup"
1445+ , test yes yes dnbL30 dnb "do-notation lookup"
815− , test yes yes lcbL33 lcb "listcomp bind" -- 137
1446+ , test yes yes lcbL33 lcb "listcomp bind" -- 137
816− , test yes yes lclL33 lcb "listcomp lookup"
1447+ , test yes yes lclL33 lcb "listcomp lookup"
1448+ , test yes yes mclL36 mcl "top-level fn 1st clause"
1449+ , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1450+ , test yes yes spaceL37 space "top-level fn on space #315"
1451+ , test no broken docL41 doc "documentation #7"
1452+ , test no yes eitL40 kindE "kind of Either #273"
1453+ , test no yes intL40 kindI "kind of Int #273"
1454+ , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1455+ , test no yes intL41 litI "literal Int in hover info #274"
1456+ , test no yes chrL36 litC "literal Char in hover info #274"
1457+ , test no yes txtL8 litT "literal Text in hover info #274"
1458+ , test no yes lstL43 litL "literal List in hover info #274"
1459+ , test no yes docL41 constr "type constraint in hover info #283"
1460+ , test broken broken outL45 outSig "top-level signature #310"
1461+ , test broken broken innL48 innSig "inner signature #310"
1462+ , testM yes yes imported importedSig "Imported symbol"
1463+ , testM yes yes reexported reexportedSig "Imported symbol (reexported)"
817 ]
1464 ]
818 where yes, broken :: (TestTree -> Maybe TestTree)
1465 where yes, broken :: (TestTree -> Maybe TestTree)
819 yes = Just -- test should run and pass
1466 yes = Just -- test should run and pass
820 broken = Just . (`xfail` "known broken")
1467 broken = Just . (`xfail` "known broken")
821− -- no = const Nothing -- don't run this test at all
1468+ no = const Nothing -- don't run this test at all
1469+
1470+checkFileCompiles :: FilePath -> TestTree
1471+checkFileCompiles fp =
1472+ testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do
1473+ void (openTestDataDoc (dir </> fp))
1474+ expectNoMoreDiagnostics 0.5
1475+
1476+
822
1477
823pluginTests :: TestTree
1478pluginTests :: TestTree
1479+pluginTests = (`xfail8101` "known broken (#556)")
824−pluginTests = testSessionWait "plugins" $ do
1480+ $ testSessionWait "plugins" $ do
825 let content =
1481 let content =
826 T.unlines
1482 T.unlines
827 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
1483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
@@ -835,13 +1491,100 @@ pluginTests = testSessionWait "plugins" $ do
835 , "foo :: Int -> Int -> Int"
1491 , "foo :: Int -> Int -> Int"
836 , "foo a b = a + c"
1492 , "foo a b = a + c"
837 ]
1493 ]
838− _ <- openDoc' "Testing.hs" "haskell" content
1494+ _ <- createDoc "Testing.hs" "haskell" content
839 expectDiagnostics
1495 expectDiagnostics
840 [ ( "Testing.hs",
1496 [ ( "Testing.hs",
841 [(DsError, (8, 14), "Variable not in scope: c")]
1497 [(DsError, (8, 14), "Variable not in scope: c")]
842 )
1498 )
843 ]
1499 ]
844
1500
1501+cppTests :: TestTree
1502+cppTests =
1503+ testGroup "cpp"
1504+ [ testCase "cpp-error" $ do
1505+ let content =
1506+ T.unlines
1507+ [ "{-# LANGUAGE CPP #-}",
1508+ "module Testing where",
1509+ "#ifdef FOO",
1510+ "foo = 42"
1511+ ]
1512+ -- The error locations differ depending on which C-preprocessor is used.
1513+ -- Some give the column number and others don't (hence -1). Assert either
1514+ -- of them.
1515+ (run $ expectError content (2, -1))
1516+ `catch` ( \e -> do
1517+ let _ = e :: HUnitFailure
1518+ run $ expectError content (2, 1)
1519+ )
1520+ , testSessionWait "cpp-ghcide" $ do
1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines
1522+ ["{-# LANGUAGE CPP #-}"
1523+ ,"main ="
1524+ ,"#ifdef __GHCIDE__"
1525+ ," worked"
1526+ ,"#else"
1527+ ," failed"
1528+ ,"#endif"
1529+ ]
1530+ expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])]
1531+ ]
1532+ where
1533+ expectError :: T.Text -> Cursor -> Session ()
1534+ expectError content cursor = do
1535+ _ <- createDoc "Testing.hs" "haskell" content
1536+ expectDiagnostics
1537+ [ ( "Testing.hs",
1538+ [(DsError, cursor, "error: unterminated")]
1539+ )
1540+ ]
1541+ expectNoMoreDiagnostics 0.5
1542+
1543+preprocessorTests :: TestTree
1544+preprocessorTests = testSessionWait "preprocessor" $ do
1545+ let content =
1546+ T.unlines
1547+ [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}"
1548+ , "module Testing where"
1549+ , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic
1550+ ]
1551+ _ <- createDoc "Testing.hs" "haskell" content
1552+ expectDiagnostics
1553+ [ ( "Testing.hs",
1554+ [(DsError, (2, 8), "Variable not in scope: z")]
1555+ )
1556+ ]
1557+
1558+
1559+safeTests :: TestTree
1560+safeTests =
1561+ testGroup
1562+ "SafeHaskell"
1563+ [ -- Test for https://github.com/digital-asset/ghcide/issues/424
1564+ testSessionWait "load" $ do
1565+ let sourceA =
1566+ T.unlines
1567+ ["{-# LANGUAGE Trustworthy #-}"
1568+ ,"module A where"
1569+ ,"import System.IO.Unsafe"
1570+ ,"import System.IO"
1571+ ,"trustWorthyId :: a -> a"
1572+ ,"trustWorthyId i = unsafePerformIO $ do"
1573+ ," putStrLn \"I'm safe\""
1574+ ," return i"]
1575+ sourceB =
1576+ T.unlines
1577+ ["{-# LANGUAGE Safe #-}"
1578+ ,"module B where"
1579+ ,"import A"
1580+ ,"safeId :: a -> a"
1581+ ,"safeId = trustWorthyId"
1582+ ]
1583+
1584+ _ <- createDoc "A.hs" "haskell" sourceA
1585+ _ <- createDoc "B.hs" "haskell" sourceB
1586+ expectNoMoreDiagnostics 1 ]
1587+
845thTests :: TestTree
1588thTests :: TestTree
846thTests =
1589thTests =
847 testGroup
1590 testGroup
@@ -867,24 +1610,586 @@ thTests =
867 "b :: Integer",
1610 "b :: Integer",
868 "b = $(litE $ IntegerL $ a) + n"
1611 "b = $(litE $ IntegerL $ a) + n"
869 ]
1612 ]
870− _ <- openDoc' "A.hs" "haskell" sourceA
1613+ _ <- createDoc "A.hs" "haskell" sourceA
871− _ <- openDoc' "B.hs" "haskell" sourceB
1614+ _ <- createDoc "B.hs" "haskell" sourceB
872 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
1615 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
1616+ , testSessionWait "newtype-closure" $ do
1617+ let sourceA =
1618+ T.unlines
1619+ [ "{-# LANGUAGE DeriveDataTypeable #-}"
1620+ ,"{-# LANGUAGE TemplateHaskell #-}"
1621+ ,"module A (a) where"
1622+ ,"import Data.Data"
1623+ ,"import Language.Haskell.TH"
1624+ ,"newtype A = A () deriving (Data)"
1625+ ,"a :: ExpQ"
1626+ ,"a = [| 0 |]"]
1627+ let sourceB =
1628+ T.unlines
1629+ [ "{-# LANGUAGE TemplateHaskell #-}"
1630+ ,"module B where"
1631+ ,"import A"
1632+ ,"b :: Int"
1633+ ,"b = $( a )" ]
1634+ _ <- createDoc "A.hs" "haskell" sourceA
1635+ _ <- createDoc "B.hs" "haskell" sourceB
1636+ return ()
1637+ ]
1638+
1639+completionTests :: TestTree
1640+completionTests
1641+ = testGroup "completion"
1642+ [ testSessionWait "variable" $ do
1643+ let source = T.unlines ["module A where", "f = hea"]
1644+ docId <- createDoc "A.hs" "haskell" source
1645+ compls <- getCompletions docId (Position 1 7)
1646+ liftIO $ map dropDocs compls @?=
1647+ [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1648+ let [CompletionItem { _documentation = headDocs}] = compls
1649+ checkDocText "head" headDocs [ "Defined in 'Prelude'"
1650+#if MIN_GHC_API_VERSION(8,6,5)
1651+ , "Extract the first element of a list"
1652+#endif
1653+ ]
1654+ , testSessionWait "constructor" $ do
1655+ let source = T.unlines ["module A where", "f = Tru"]
1656+ docId <- createDoc "A.hs" "haskell" source
1657+ compls <- getCompletions docId (Position 1 7)
1658+ liftIO $ map dropDocs compls @?=
1659+ [ complItem "True" (Just CiConstructor) (Just "Bool")
1660+#if MIN_GHC_API_VERSION(8,6,0)
1661+ , complItem "truncate" (Just CiFunction) (Just "(RealFrac a, Integral b) => a -> b")
1662+#else
1663+ , complItem "truncate" (Just CiFunction) (Just "RealFrac a => forall b. Integral b => a -> b")
1664+#endif
1665+ ]
1666+ , testSessionWait "type" $ do
1667+ let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]
1668+ docId <- createDoc "A.hs" "haskell" source
1669+ expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1670+ changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
1671+ compls <- getCompletions docId (Position 2 7)
1672+ liftIO $ map dropDocs compls @?=
1673+ [ complItem "Bounded" (Just CiClass) (Just "* -> Constraint")
1674+ , complItem "Bool" (Just CiStruct) (Just "*") ]
1675+ let [ CompletionItem { _documentation = boundedDocs},
1676+ CompletionItem { _documentation = boolDocs } ] = compls
1677+ checkDocText "Bounded" boundedDocs [ "Defined in 'Prelude'"
1678+#if MIN_GHC_API_VERSION(8,6,5)
1679+ , "name the upper and lower limits"
1680+#endif
1681+ ]
1682+ checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1683+ , testSessionWait "qualified" $ do
1684+ let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]
1685+ docId <- createDoc "A.hs" "haskell" source
1686+ expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1687+ changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
1688+ compls <- getCompletions docId (Position 2 15)
1689+ liftIO $ map dropDocs compls @?=
1690+ [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1691+ let [CompletionItem { _documentation = headDocs}] = compls
1692+ checkDocText "head" headDocs [ "Defined in 'Prelude'"
1693+#if MIN_GHC_API_VERSION(8,6,5)
1694+ , "Extract the first element of a list"
1695+#endif
1696+ ]
1697+ , testSessionWait "keyword" $ do
1698+ let source = T.unlines ["module A where", "f = newty"]
1699+ docId <- createDoc "A.hs" "haskell" source
1700+ compls <- getCompletions docId (Position 1 9)
1701+ liftIO $ compls @?= [keywordItem "newtype"]
1702+ , testSessionWait "type context" $ do
1703+ let source = T.unlines
1704+ [ "{-# OPTIONS_GHC -Wunused-binds #-}"
1705+ , "module A () where"
1706+ , "f = f"
1707+ ]
1708+ docId <- createDoc "A.hs" "haskell" source
1709+ expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]
1710+ changeDoc docId
1711+ [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
1712+ [ "{-# OPTIONS_GHC -Wunused-binds #-}"
1713+ , "module A () where"
1714+ , "f = f"
1715+ , "g :: Intege"
1716+ ]
1717+ ]
1718+ -- At this point the module parses but does not typecheck.
1719+ -- This should be sufficient to detect that we are in a
1720+ -- type context and only show the completion to the type.
1721+ compls <- getCompletions docId (Position 3 11)
1722+ liftIO $ map dropDocs compls @?= [complItem "Integer"(Just CiStruct) (Just "*")]
873 ]
1723 ]
1724+ where
1725+ dropDocs :: CompletionItem -> CompletionItem
1726+ dropDocs ci = ci { _documentation = Nothing }
1727+ complItem label kind ty = CompletionItem
1728+ { _label = label
1729+ , _kind = kind
1730+ , _tags = List []
1731+ , _detail = (":: " <>) <$> ty
1732+ , _documentation = Nothing
1733+ , _deprecated = Nothing
1734+ , _preselect = Nothing
1735+ , _sortText = Nothing
1736+ , _filterText = Nothing
1737+ , _insertText = Nothing
1738+ , _insertTextFormat = Just PlainText
1739+ , _textEdit = Nothing
1740+ , _additionalTextEdits = Nothing
1741+ , _commitCharacters = Nothing
1742+ , _command = Nothing
1743+ , _xdata = Nothing
1744+ }
1745+ keywordItem label = CompletionItem
1746+ { _label = label
1747+ , _kind = Just CiKeyword
1748+ , _tags = List []
1749+ , _detail = Nothing
1750+ , _documentation = Nothing
1751+ , _deprecated = Nothing
1752+ , _preselect = Nothing
1753+ , _sortText = Nothing
1754+ , _filterText = Nothing
1755+ , _insertText = Nothing
1756+ , _insertTextFormat = Nothing
1757+ , _textEdit = Nothing
1758+ , _additionalTextEdits = Nothing
1759+ , _commitCharacters = Nothing
1760+ , _command = Nothing
1761+ , _xdata = Nothing
1762+ }
1763+ getDocText (CompletionDocString s) = s
1764+ getDocText (CompletionDocMarkup (MarkupContent _ s)) = s
1765+ checkDocText thing Nothing _
1766+ = liftIO $ assertFailure $ "docs for " ++ thing ++ " not found"
1767+ checkDocText thing (Just doc) items
1768+ = liftIO $ assertBool ("docs for " ++ thing ++ " contain the strings") $
1769+ all (`T.isInfixOf` getDocText doc) items
1770+
1771+outlineTests :: TestTree
1772+outlineTests = testGroup
1773+ "outline"
1774+ [ testSessionWait "type class" $ do
1775+ let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]
1776+ docId <- createDoc "A.hs" "haskell" source
1777+ symbols <- getDocumentSymbols docId
1778+ liftIO $ symbols @?= Left
1779+ [ moduleSymbol
1780+ "A"
1781+ (R 0 7 0 8)
1782+ [ classSymbol "A a"
1783+ (R 1 0 1 30)
1784+ [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)]
1785+ ]
1786+ ]
1787+ , testSessionWait "type class instance " $ do
1788+ let source = T.unlines ["class A a where", "instance A () where"]
1789+ docId <- createDoc "A.hs" "haskell" source
1790+ symbols <- getDocumentSymbols docId
1791+ liftIO $ symbols @?= Left
1792+ [ classSymbol "A a" (R 0 0 0 15) []
1793+ , docSymbol "A ()" SkInterface (R 1 0 1 19)
1794+ ]
1795+ , testSessionWait "type family" $ do
1796+ let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1797+ docId <- createDoc "A.hs" "haskell" source
1798+ symbols <- getDocumentSymbols docId
1799+ liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]
1800+ , testSessionWait "type family instance " $ do
1801+ let source = T.unlines
1802+ [ "{-# language TypeFamilies #-}"
1803+ , "type family A a"
1804+ , "type instance A () = ()"
1805+ ]
1806+ docId <- createDoc "A.hs" "haskell" source
1807+ symbols <- getDocumentSymbols docId
1808+ liftIO $ symbols @?= Left
1809+ [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
1810+ , docSymbol "A ()" SkInterface (R 2 0 2 23)
1811+ ]
1812+ , testSessionWait "data family" $ do
1813+ let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1814+ docId <- createDoc "A.hs" "haskell" source
1815+ symbols <- getDocumentSymbols docId
1816+ liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]
1817+ , testSessionWait "data family instance " $ do
1818+ let source = T.unlines
1819+ [ "{-# language TypeFamilies #-}"
1820+ , "data family A a"
1821+ , "data instance A () = A ()"
1822+ ]
1823+ docId <- createDoc "A.hs" "haskell" source
1824+ symbols <- getDocumentSymbols docId
1825+ liftIO $ symbols @?= Left
1826+ [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
1827+ , docSymbol "A ()" SkInterface (R 2 0 2 25)
1828+ ]
1829+ , testSessionWait "constant" $ do
1830+ let source = T.unlines ["a = ()"]
1831+ docId <- createDoc "A.hs" "haskell" source
1832+ symbols <- getDocumentSymbols docId
1833+ liftIO $ symbols @?= Left
1834+ [docSymbol "a" SkFunction (R 0 0 0 6)]
1835+ , testSessionWait "pattern" $ do
1836+ let source = T.unlines ["Just foo = Just 21"]
1837+ docId <- createDoc "A.hs" "haskell" source
1838+ symbols <- getDocumentSymbols docId
1839+ liftIO $ symbols @?= Left
1840+ [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1841+ , testSessionWait "pattern with type signature" $ do
1842+ let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1843+ docId <- createDoc "A.hs" "haskell" source
1844+ symbols <- getDocumentSymbols docId
1845+ liftIO $ symbols @?= Left
1846+ [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1847+ , testSessionWait "function" $ do
1848+ let source = T.unlines ["a x = ()"]
1849+ docId <- createDoc "A.hs" "haskell" source
1850+ symbols <- getDocumentSymbols docId
1851+ liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1852+ , testSessionWait "type synonym" $ do
1853+ let source = T.unlines ["type A = Bool"]
1854+ docId <- createDoc "A.hs" "haskell" source
1855+ symbols <- getDocumentSymbols docId
1856+ liftIO $ symbols @?= Left
1857+ [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]
1858+ , testSessionWait "datatype" $ do
1859+ let source = T.unlines ["data A = C"]
1860+ docId <- createDoc "A.hs" "haskell" source
1861+ symbols <- getDocumentSymbols docId
1862+ liftIO $ symbols @?= Left
1863+ [ docSymbolWithChildren "A"
1864+ SkStruct
1865+ (R 0 0 0 10)
1866+ [docSymbol "C" SkConstructor (R 0 9 0 10)]
1867+ ]
1868+ , testSessionWait "record fields" $ do
1869+ let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"]
1870+ docId <- createDoc "A.hs" "haskell" source
1871+ symbols <- getDocumentSymbols docId
1872+ liftIO $ symbols @=? Left
1873+ [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13)
1874+ [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10)
1875+ [ docSymbol "x" SkField (R 1 2 1 3)
1876+ , docSymbol "y" SkField (R 2 4 2 5)
1877+ ]
1878+ ]
1879+ ]
1880+ , testSessionWait "import" $ do
1881+ let source = T.unlines ["import Data.Maybe"]
1882+ docId <- createDoc "A.hs" "haskell" source
1883+ symbols <- getDocumentSymbols docId
1884+ liftIO $ symbols @?= Left
1885+ [docSymbolWithChildren "imports"
1886+ SkModule
1887+ (R 0 0 0 17)
1888+ [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)
1889+ ]
1890+ ]
1891+ , testSessionWait "multiple import" $ do
1892+ let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]
1893+ docId <- createDoc "A.hs" "haskell" source
1894+ symbols <- getDocumentSymbols docId
1895+ liftIO $ symbols @?= Left
1896+ [docSymbolWithChildren "imports"
1897+ SkModule
1898+ (R 1 0 3 24)
1899+ [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 17)
1900+ , docSymbol "import Control.Exception" SkModule (R 3 0 3 24)
1901+ ]
1902+ ]
1903+ , testSessionWait "foreign import" $ do
1904+ let source = T.unlines
1905+ [ "{-# language ForeignFunctionInterface #-}"
1906+ , "foreign import ccall \"a\" a :: Int"
1907+ ]
1908+ docId <- createDoc "A.hs" "haskell" source
1909+ symbols <- getDocumentSymbols docId
1910+ liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]
1911+ , testSessionWait "foreign export" $ do
1912+ let source = T.unlines
1913+ [ "{-# language ForeignFunctionInterface #-}"
1914+ , "foreign export ccall odd :: Int -> Bool"
1915+ ]
1916+ docId <- createDoc "A.hs" "haskell" source
1917+ symbols <- getDocumentSymbols docId
1918+ liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]
1919+ ]
1920+ where
1921+ docSymbol name kind loc =
1922+ DocumentSymbol name Nothing kind Nothing loc loc Nothing
1923+ docSymbol' name kind loc selectionLoc =
1924+ DocumentSymbol name Nothing kind Nothing loc selectionLoc Nothing
1925+ docSymbolD name detail kind loc =
1926+ DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1927+ docSymbolWithChildren name kind loc cc =
1928+ DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)
1929+ docSymbolWithChildren' name kind loc selectionLoc cc =
1930+ DocumentSymbol name Nothing kind Nothing loc selectionLoc (Just $ List cc)
1931+ moduleSymbol name loc cc = DocumentSymbol name
1932+ Nothing
1933+ SkFile
1934+ Nothing
1935+ (R 0 0 maxBound 0)
1936+ loc
1937+ (Just $ List cc)
1938+ classSymbol name loc cc = DocumentSymbol name
1939+ (Just "class")
1940+ SkClass
1941+ Nothing
1942+ loc
1943+ loc
1944+ (Just $ List cc)
1945+
1946+pattern R :: Int -> Int -> Int -> Int -> Range
1947+pattern R x y x' y' = Range (Position x y) (Position x' y')
874
1948
875xfail :: TestTree -> String -> TestTree
1949xfail :: TestTree -> String -> TestTree
876xfail = flip expectFailBecause
1950xfail = flip expectFailBecause
877
1951
1952+xfail8101 :: TestTree -> String -> TestTree
1953+#if MIN_GHC_API_VERSION(8,10,0)
1954+xfail8101 = flip expectFailBecause
1955+#else
1956+xfail8101 t _ = t
1957+#endif
1958+
878data Expect
1959data Expect
879 = ExpectRange Range -- Both gotoDef and hover should report this range
1960 = ExpectRange Range -- Both gotoDef and hover should report this range
1961+ | ExpectLocation Location
880-- | ExpectDefRange Range -- Only gotoDef should report this range
1962-- | ExpectDefRange Range -- Only gotoDef should report this range
881 | ExpectHoverRange Range -- Only hover should report this range
1963 | ExpectHoverRange Range -- Only hover should report this range
882 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
1964 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
883 | ExpectExternFail -- definition lookup in other file expected to fail
1965 | ExpectExternFail -- definition lookup in other file expected to fail
1966+ | ExpectNoDefinitions
1967+ | ExpectNoHover
884-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
1968-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
1969+ deriving Eq
885
1970
886mkR :: Int -> Int -> Int -> Int -> Expect
1971mkR :: Int -> Int -> Int -> Int -> Expect
887mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
1972mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
1973+
1974+mkL :: Uri -> Int -> Int -> Int -> Int -> Expect
1975+mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn
1976+
1977+haddockTests :: TestTree
1978+haddockTests
1979+ = testGroup "haddock"
1980+ [ testCase "Num" $ checkHaddock
1981+ (unlines
1982+ [ "However, '(+)' and '(*)' are"
1983+ , "customarily expected to define a ring and have the following properties:"
1984+ , ""
1985+ , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@"
1986+ , "[__Commutativity of (+)__]: @x + y@ = @y + x@"
1987+ , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@"
1988+ ]
1989+ )
1990+ (unlines
1991+ [ ""
1992+ , ""
1993+ , "However, `(+)` and `(*)` are"
1994+ , "customarily expected to define a ring and have the following properties: "
1995+ , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`"
1996+ , "+ ****Commutativity of (+)****: `x + y` = `y + x`"
1997+ , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`"
1998+ ]
1999+ )
2000+ , testCase "unsafePerformIO" $ checkHaddock
2001+ (unlines
2002+ [ "may require"
2003+ , "different precautions:"
2004+ , ""
2005+ , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"
2006+ , " that calls 'unsafePerformIO'. If the call is inlined,"
2007+ , " the I\\/O may be performed more than once."
2008+ , ""
2009+ , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression"
2010+ , " elimination being performed on the module."
2011+ , ""
2012+ ]
2013+ )
2014+ (unlines
2015+ [ ""
2016+ , ""
2017+ , "may require"
2018+ , "different precautions: "
2019+ , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` "
2020+ , " that calls `unsafePerformIO` . If the call is inlined,"
2021+ , " the I/O may be performed more than once."
2022+ , ""
2023+ , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression"
2024+ , " elimination being performed on the module."
2025+ , ""
2026+ ]
2027+ )
2028+ ]
2029+ where
2030+ checkHaddock s txt = spanDocToMarkdownForTest s @?= txt
2031+
2032+cradleTests :: TestTree
2033+cradleTests = testGroup "cradle"
2034+ [testGroup "dependencies" [sessionDepsArePickedUp]
2035+ ,testGroup "loading" [loadCradleOnlyonce]
2036+ ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]
2037+ ]
2038+
2039+loadCradleOnlyonce :: TestTree
2040+loadCradleOnlyonce = testGroup "load cradle only once"
2041+ [ testSession' "implicit" implicit
2042+ , testSession' "direct" direct
2043+ ]
2044+ where
2045+ direct dir = do
2046+ liftIO $ writeFileUTF8 (dir </> "hie.yaml")
2047+ "cradle: {direct: {arguments: []}}"
2048+ test dir
2049+ implicit dir = test dir
2050+ test _dir = do
2051+ doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"
2052+ msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2053+ liftIO $ length msgs @?= 1
2054+ changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]
2055+ msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2056+ liftIO $ length msgs @?= 0
2057+ _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"
2058+ msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2059+ liftIO $ length msgs @?= 0
2060+
2061+
2062+dependentFileTest :: TestTree
2063+dependentFileTest = testGroup "addDependentFile"
2064+ [testGroup "file-changed" [testSession' "test" test]
2065+ ]
2066+ where
2067+ test dir = do
2068+ -- If the file contains B then no type error
2069+ -- otherwise type error
2070+ liftIO $ writeFile (dir </> "dep-file.txt") "A"
2071+ let fooContent = T.unlines
2072+ [ "{-# LANGUAGE TemplateHaskell #-}"
2073+ , "module Foo where"
2074+ , "import Language.Haskell.TH.Syntax"
2075+ , "foo :: Int"
2076+ , "foo = 1 + $(do"
2077+ , " qAddDependentFile \"dep-file.txt\""
2078+ , " f <- qRunIO (readFile \"dep-file.txt\")"
2079+ , " if f == \"B\" then [| 1 |] else lift f)"
2080+ ]
2081+ let bazContent = T.unlines ["module Baz where", "import Foo"]
2082+ _ <-createDoc "Foo.hs" "haskell" fooContent
2083+ doc <- createDoc "Baz.hs" "haskell" bazContent
2084+ expectDiagnostics
2085+ [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]
2086+ -- Now modify the dependent file
2087+ liftIO $ writeFile (dir </> "dep-file.txt") "B"
2088+ let change = TextDocumentContentChangeEvent
2089+ { _range = Just (Range (Position 2 0) (Position 2 6))
2090+ , _rangeLength = Nothing
2091+ , _text = "f = ()"
2092+ }
2093+ -- Modifying Baz will now trigger Foo to be rebuilt as well
2094+ changeDoc doc [change]
2095+ expectDiagnostics [("Foo.hs", [])]
2096+
2097+
2098+cradleLoadedMessage :: Session FromServerMessage
2099+cradleLoadedMessage = satisfy $ \case
2100+ NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod
2101+ _ -> False
2102+
2103+cradleLoadedMethod :: T.Text
2104+cradleLoadedMethod = "ghcide/cradle/loaded"
2105+
2106+-- Stack sets this which trips up cabal in the multi-component tests.
2107+-- However, our plugin tests rely on those env vars so we unset it locally.
2108+withoutStackEnv :: IO a -> IO a
2109+withoutStackEnv s =
2110+ bracket
2111+ (mapM getEnv vars >>= \prevState -> mapM_ unsetEnv vars >> pure prevState)
2112+ (\prevState -> mapM_ (\(var, value) -> restore var value) (zip vars prevState))
2113+ (const s)
2114+ where vars =
2115+ [ "GHC_PACKAGE_PATH"
2116+ , "GHC_ENVIRONMENT"
2117+ , "HASKELL_DIST_DIR"
2118+ , "HASKELL_PACKAGE_SANDBOX"
2119+ , "HASKELL_PACKAGE_SANDBOXES"
2120+ ]
2121+ restore var Nothing = unsetEnv var
2122+ restore var (Just val) = setEnv var val True
2123+
2124+simpleMultiTest :: TestTree
2125+simpleMultiTest = testCase "simple-multi-test" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do
2126+ let aPath = dir </> "a/A.hs"
2127+ bPath = dir </> "b/B.hs"
2128+ aSource <- liftIO $ readFileUtf8 aPath
2129+ (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
2130+ expectNoMoreDiagnostics 0.5
2131+ bSource <- liftIO $ readFileUtf8 bPath
2132+ bdoc <- createDoc bPath "haskell" bSource
2133+ expectNoMoreDiagnostics 0.5
2134+ locs <- getDefinitions bdoc (Position 2 7)
2135+ let fooL = mkL adoc 2 0 2 3
2136+ checkDefs locs (pure [fooL])
2137+ expectNoMoreDiagnostics 0.5
2138+
2139+-- Like simpleMultiTest but open the files in the other order
2140+simpleMultiTest2 :: TestTree
2141+simpleMultiTest2 = testCase "simple-multi-test2" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do
2142+ let aPath = dir </> "a/A.hs"
2143+ bPath = dir </> "b/B.hs"
2144+ bSource <- liftIO $ readFileUtf8 bPath
2145+ bdoc <- createDoc bPath "haskell" bSource
2146+ expectNoMoreDiagnostics 5
2147+ aSource <- liftIO $ readFileUtf8 aPath
2148+ (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
2149+ -- Need to have some delay here or the test fails
2150+ expectNoMoreDiagnostics 5
2151+ locs <- getDefinitions bdoc (Position 2 7)
2152+ let fooL = mkL adoc 2 0 2 3
2153+ checkDefs locs (pure [fooL])
2154+ expectNoMoreDiagnostics 0.5
2155+
2156+sessionDepsArePickedUp :: TestTree
2157+sessionDepsArePickedUp = testSession'
2158+ "session-deps-are-picked-up"
2159+ $ \dir -> do
2160+ liftIO $
2161+ writeFileUTF8
2162+ (dir </> "hie.yaml")
2163+ "cradle: {direct: {arguments: []}}"
2164+ -- Open without OverloadedStrings and expect an error.
2165+ doc <- createDoc "Foo.hs" "haskell" fooContent
2166+ expectDiagnostics
2167+ [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
2168+ -- Update hie.yaml to enable OverloadedStrings.
2169+ liftIO $
2170+ writeFileUTF8
2171+ (dir </> "hie.yaml")
2172+ "cradle: {direct: {arguments: [-XOverloadedStrings]}}"
2173+ -- Send change event.
2174+ let change =
2175+ TextDocumentContentChangeEvent
2176+ { _range = Just (Range (Position 4 0) (Position 4 0)),
2177+ _rangeLength = Nothing,
2178+ _text = "\n"
2179+ }
2180+ changeDoc doc [change]
2181+ -- Now no errors.
2182+ expectDiagnostics [("Foo.hs", [])]
2183+ where
2184+ fooContent =
2185+ T.unlines
2186+ [ "module Foo where",
2187+ "import Data.Text",
2188+ "foo :: Text",
2189+ "foo = \"hello\""
2190+ ]
2191+
2192+
888----------------------------------------------------------------------
2193----------------------------------------------------------------------
889-- Utils
2194-- Utils
890
2195
@@ -892,6 +2197,12 @@ mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine st
892testSession :: String -> Session () -> TestTree
2197testSession :: String -> Session () -> TestTree
893testSession name = testCase name . run
2198testSession name = testCase name . run
894
2199
2200+testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree
2201+testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix
2202+
2203+testSession' :: String -> (FilePath -> Session ()) -> TestTree
2204+testSession' name = testCase name . run'
2205+
895testSessionWait :: String -> Session () -> TestTree
2206testSessionWait :: String -> Session () -> TestTree
896testSessionWait name = testSession name .
2207testSessionWait name = testSession name .
897 -- Check that any diagnostics produced were already consumed by the test case.
2208 -- Check that any diagnostics produced were already consumed by the test case.
@@ -902,35 +2213,284 @@ testSessionWait name = testSession name .
902 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.
2213 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.
903 ( >> expectNoMoreDiagnostics 0.5)
2214 ( >> expectNoMoreDiagnostics 0.5)
904
2215
905−pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction
2216+pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction
906−pickActionWithTitle title actions = head
2217+pickActionWithTitle title actions = do
2218+ assertBool ("Found no matching actions: " <> show titles) (not $ null matches)
2219+ return $ head matches
2220+ where
2221+ titles =
2222+ [ actionTitle
2223+ | CACodeAction CodeAction { _title = actionTitle } <- actions
2224+ ]
2225+ matches =
907− [ action
2226+ [ action
908− | CACodeAction action@CodeAction{ _title = actionTitle } <- actions
2227+ | CACodeAction action@CodeAction { _title = actionTitle } <- actions
909− , title == actionTitle ]
2228+ , title == actionTitle
2229+ ]
910
2230
911mkRange :: Int -> Int -> Int -> Int -> Range
2231mkRange :: Int -> Int -> Int -> Int -> Range
912mkRange a b c d = Range (Position a b) (Position c d)
2232mkRange a b c d = Range (Position a b) (Position c d)
913
2233
914run :: Session a -> IO a
2234run :: Session a -> IO a
915−run s = withTempDir $ \dir -> do
2235+run s = withTempDir $ \dir -> runInDir dir s
2236+
2237+runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a
2238+runWithExtraFiles prefix s = withTempDir $ \dir -> do
2239+ copyTestDataFiles dir prefix
2240+ runInDir dir (s dir)
2241+
2242+copyTestDataFiles :: FilePath -> FilePath -> IO ()
2243+copyTestDataFiles dir prefix = do
2244+ -- Copy all the test data files to the temporary workspace
2245+ testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]
2246+ for_ testDataFiles $ \f -> do
2247+ createDirectoryIfMissing True $ dir </> takeDirectory f
2248+ copyFile ("test/data" </> prefix </> f) (dir </> f)
2249+
2250+run' :: (FilePath -> Session a) -> IO a
2251+run' s = withTempDir $ \dir -> runInDir dir (s dir)
2252+
2253+runInDir :: FilePath -> Session a -> IO a
2254+runInDir dir s = do
916 ghcideExe <- locateGhcideExecutable
2255 ghcideExe <- locateGhcideExecutable
917
2256
918 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
2257 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
919 -- since the package import test creates "Data/List.hs", which otherwise has no physical home
2258 -- since the package import test creates "Data/List.hs", which otherwise has no physical home
920 createDirectoryIfMissing True $ dir ++ "/Data"
2259 createDirectoryIfMissing True $ dir ++ "/Data"
921
2260
2261+
922− let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]
2262+ let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
923 -- HIE calls getXgdDirectory which assumes that HOME is set.
2263 -- HIE calls getXgdDirectory which assumes that HOME is set.
924 -- Only sets HOME if it wasn't already set.
2264 -- Only sets HOME if it wasn't already set.
925 setEnv "HOME" "/homeless-shelter" False
2265 setEnv "HOME" "/homeless-shelter" False
926− runSessionWithConfig conf cmd fullCaps { _window = Just $ WindowClientCapabilities $ Just True } dir s
2266+ let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }
2267+ runSessionWithConfig conf cmd lspTestCaps dir s
927 where
2268 where
928 conf = defaultConfig
2269 conf = defaultConfig
929− -- If you uncomment this you can see all messages
2270+ -- If you uncomment this you can see all logging
930 -- which can be quite useful for debugging.
2271 -- which can be quite useful for debugging.
931− -- { logMessages = True, logColor = False, logStdErr = True }
2272+ -- { logStdErr = True, logColor = False }
2273+ -- If you really want to, you can also see all messages
2274+ -- { logMessages = True, logColor = False }
932
2275
933openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
2276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
934openTestDataDoc path = do
2277openTestDataDoc path = do
935 source <- liftIO $ readFileUtf8 $ "test/data" </> path
2278 source <- liftIO $ readFileUtf8 $ "test/data" </> path
936− openDoc' path "haskell" source
2279+ createDoc path "haskell" source
2280+
2281+findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
2282+findCodeActions doc range expectedTitles = do
2283+ actions <- getCodeActions doc range
2284+ let matches = sequence
2285+ [ listToMaybe
2286+ [ action
2287+ | CACodeAction action@CodeAction { _title = actionTitle } <- actions
2288+ , actionTitle == expectedTitle ]
2289+ | expectedTitle <- expectedTitles]
2290+ let msg = show
2291+ [ actionTitle
2292+ | CACodeAction CodeAction { _title = actionTitle } <- actions
2293+ ]
2294+ ++ " is not a superset of "
2295+ ++ show expectedTitles
2296+ liftIO $ case matches of
2297+ Nothing -> assertFailure msg
2298+ Just _ -> pure ()
2299+ return (fromJust matches)
2300+
2301+findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction
2302+findCodeAction doc range t = head <$> findCodeActions doc range [t]
2303+
2304+unitTests :: TestTree
2305+unitTests = do
2306+ testGroup "Unit"
2307+ [ testCase "empty file path does NOT work with the empty String literal" $
2308+ uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "."
2309+ , testCase "empty file path works using toNormalizedFilePath'" $
2310+ uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just ""
2311+ , testCase "empty path URI" $ do
2312+ Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri)
2313+ uriScheme @?= "file:"
2314+ uriPath @?= ""
2315+ , testCase "from empty path URI" $ do
2316+ let uri = Uri "file://"
2317+ uriToFilePath' uri @?= Just ""
2318+ ]
2319+
2320+positionMappingTests :: TestTree
2321+positionMappingTests =
2322+ testGroup "position mapping"
2323+ [ testGroup "toCurrent"
2324+ [ testCase "before" $
2325+ toCurrent
2326+ (Range (Position 0 1) (Position 0 3))
2327+ "ab"
2328+ (Position 0 0) @?= Just (Position 0 0)
2329+ , testCase "after, same line, same length" $
2330+ toCurrent
2331+ (Range (Position 0 1) (Position 0 3))
2332+ "ab"
2333+ (Position 0 3) @?= Just (Position 0 3)
2334+ , testCase "after, same line, increased length" $
2335+ toCurrent
2336+ (Range (Position 0 1) (Position 0 3))
2337+ "abc"
2338+ (Position 0 3) @?= Just (Position 0 4)
2339+ , testCase "after, same line, decreased length" $
2340+ toCurrent
2341+ (Range (Position 0 1) (Position 0 3))
2342+ "a"
2343+ (Position 0 3) @?= Just (Position 0 2)
2344+ , testCase "after, next line, no newline" $
2345+ toCurrent
2346+ (Range (Position 0 1) (Position 0 3))
2347+ "abc"
2348+ (Position 1 3) @?= Just (Position 1 3)
2349+ , testCase "after, next line, newline" $
2350+ toCurrent
2351+ (Range (Position 0 1) (Position 0 3))
2352+ "abc\ndef"
2353+ (Position 1 0) @?= Just (Position 2 0)
2354+ , testCase "after, same line, newline" $
2355+ toCurrent
2356+ (Range (Position 0 1) (Position 0 3))
2357+ "abc\nd"
2358+ (Position 0 4) @?= Just (Position 1 2)
2359+ , testCase "after, same line, newline + newline at end" $
2360+ toCurrent
2361+ (Range (Position 0 1) (Position 0 3))
2362+ "abc\nd\n"
2363+ (Position 0 4) @?= Just (Position 2 1)
2364+ , testCase "after, same line, newline + newline at end" $
2365+ toCurrent
2366+ (Range (Position 0 1) (Position 0 1))
2367+ "abc"
2368+ (Position 0 1) @?= Just (Position 0 4)
2369+ ]
2370+ , testGroup "fromCurrent"
2371+ [ testCase "before" $
2372+ fromCurrent
2373+ (Range (Position 0 1) (Position 0 3))
2374+ "ab"
2375+ (Position 0 0) @?= Just (Position 0 0)
2376+ , testCase "after, same line, same length" $
2377+ fromCurrent
2378+ (Range (Position 0 1) (Position 0 3))
2379+ "ab"
2380+ (Position 0 3) @?= Just (Position 0 3)
2381+ , testCase "after, same line, increased length" $
2382+ fromCurrent
2383+ (Range (Position 0 1) (Position 0 3))
2384+ "abc"
2385+ (Position 0 4) @?= Just (Position 0 3)
2386+ , testCase "after, same line, decreased length" $
2387+ fromCurrent
2388+ (Range (Position 0 1) (Position 0 3))
2389+ "a"
2390+ (Position 0 2) @?= Just (Position 0 3)
2391+ , testCase "after, next line, no newline" $
2392+ fromCurrent
2393+ (Range (Position 0 1) (Position 0 3))
2394+ "abc"
2395+ (Position 1 3) @?= Just (Position 1 3)
2396+ , testCase "after, next line, newline" $
2397+ fromCurrent
2398+ (Range (Position 0 1) (Position 0 3))
2399+ "abc\ndef"
2400+ (Position 2 0) @?= Just (Position 1 0)
2401+ , testCase "after, same line, newline" $
2402+ fromCurrent
2403+ (Range (Position 0 1) (Position 0 3))
2404+ "abc\nd"
2405+ (Position 1 2) @?= Just (Position 0 4)
2406+ , testCase "after, same line, newline + newline at end" $
2407+ fromCurrent
2408+ (Range (Position 0 1) (Position 0 3))
2409+ "abc\nd\n"
2410+ (Position 2 1) @?= Just (Position 0 4)
2411+ , testCase "after, same line, newline + newline at end" $
2412+ fromCurrent
2413+ (Range (Position 0 1) (Position 0 1))
2414+ "abc"
2415+ (Position 0 4) @?= Just (Position 0 1)
2416+ ]
2417+ , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties"
2418+ [ testProperty "fromCurrent r t <=< toCurrent r t" $ do
2419+ -- Note that it is important to use suchThatMap on all values at once
2420+ -- instead of only using it on the position. Otherwise you can get
2421+ -- into situations where there is no position that can be mapped back
2422+ -- for the edit which will result in QuickCheck looping forever.
2423+ let gen = do
2424+ rope <- genRope
2425+ range <- genRange rope
2426+ PrintableText replacement <- arbitrary
2427+ oldPos <- genPosition rope
2428+ pure (range, replacement, oldPos)
2429+ forAll
2430+ (suchThatMap gen
2431+ (\(range, replacement, oldPos) -> (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $
2432+ \(range, replacement, oldPos, newPos) ->
2433+ fromCurrent range replacement newPos === Just oldPos
2434+ , testProperty "toCurrent r t <=< fromCurrent r t" $ do
2435+ let gen = do
2436+ rope <- genRope
2437+ range <- genRange rope
2438+ PrintableText replacement <- arbitrary
2439+ let newRope = applyChange rope (TextDocumentContentChangeEvent (Just range) Nothing replacement)
2440+ newPos <- genPosition newRope
2441+ pure (range, replacement, newPos)
2442+ forAll
2443+ (suchThatMap gen
2444+ (\(range, replacement, newPos) -> (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $
2445+ \(range, replacement, newPos, oldPos) ->
2446+ toCurrent range replacement oldPos === Just newPos
2447+ ]
2448+ ]
2449+
2450+newtype PrintableText = PrintableText { getPrintableText :: T.Text }
2451+ deriving Show
2452+
2453+instance Arbitrary PrintableText where
2454+ arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary
2455+
2456+
2457+genRope :: Gen Rope
2458+genRope = Rope.fromText . getPrintableText <$> arbitrary
2459+
2460+genPosition :: Rope -> Gen Position
2461+genPosition r = do
2462+ row <- choose (0, max 0 $ rows - 1)
2463+ let columns = Rope.columns (nthLine row r)
2464+ column <- choose (0, max 0 $ columns - 1)
2465+ pure $ Position row column
2466+ where rows = Rope.rows r
2467+
2468+genRange :: Rope -> Gen Range
2469+genRange r = do
2470+ startPos@(Position startLine startColumn) <- genPosition r
2471+ let maxLineDiff = max 0 $ rows - 1 - startLine
2472+ endLine <- choose (startLine, startLine + maxLineDiff)
2473+ let columns = Rope.columns (nthLine endLine r)
2474+ endColumn <-
2475+ if startLine == endLine
2476+ then choose (startColumn, columns)
2477+ else choose (0, max 0 $ columns - 1)
2478+ pure $ Range startPos (Position endLine endColumn)
2479+ where rows = Rope.rows r
2480+
2481+-- | Get the ith line of a rope, starting from 0. Trailing newline not included.
2482+nthLine :: Int -> Rope -> Rope
2483+nthLine i r
2484+ | i < 0 = error $ "Negative line number: " <> show i
2485+ | i == 0 && Rope.rows r == 0 = r
2486+ | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
2487+ | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r
2488+
2489+getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]
2490+getWatchedFilesSubscriptionsUntil = do
2491+ msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)
2492+ return
2493+ [ args
2494+ | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs
2495+ , Registration _id WorkspaceDidChangeWatchedFiles args <- regs
2496+ ]
test/preprocessor/Main.hsnew file+10
@@ -0,0 +1,10 @@
1+
2+module Main(main) where
3+
4+import System.Environment
5+
6+main :: IO ()
7+main = do
8+ _:input:output:_ <- getArgs
9+ let f = map (\x -> if x == 'x' then 'y' else x)
10+ writeFile output . f =<< readFile input
test/src/Development/IDE/Test.hs+8−2
@@ -1,10 +1,13 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4+{-# LANGUAGE DuplicateRecordFields #-}
5+
4module Development.IDE.Test
6module Development.IDE.Test
5 ( Cursor
7 ( Cursor
6 , cursorPosition
8 , cursorPosition
7 , requireDiagnostic
9 , requireDiagnostic
10+ , diagnostic
8 , expectDiagnostics
11 , expectDiagnostics
9 , expectNoMoreDiagnostics
12 , expectNoMoreDiagnostics
10 ) where
13 ) where
@@ -15,7 +18,7 @@ import Control.Monad
15import Control.Monad.IO.Class
18import Control.Monad.IO.Class
16import qualified Data.Map.Strict as Map
19import qualified Data.Map.Strict as Map
17import qualified Data.Text as T
20import qualified Data.Text as T
18−import Language.Haskell.LSP.Test hiding (message, openDoc')
21+import Language.Haskell.LSP.Test hiding (message)
19import qualified Language.Haskell.LSP.Test as LspTest
22import qualified Language.Haskell.LSP.Test as LspTest
20import Language.Haskell.LSP.Types
23import Language.Haskell.LSP.Types
21import Language.Haskell.LSP.Types.Lens as Lsp
24import Language.Haskell.LSP.Types.Lens as Lsp
@@ -77,7 +80,7 @@ expectDiagnostics expected = do
77 go m
80 go m
78 | Map.null m = pure ()
81 | Map.null m = pure ()
79 | otherwise = do
82 | otherwise = do
80− diagsNot <- skipManyTill anyMessage LspTest.message :: Session PublishDiagnosticsNotification
83+ diagsNot <- skipManyTill anyMessage diagnostic
81 let fileUri = diagsNot ^. params . uri
84 let fileUri = diagsNot ^. params . uri
82 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of
85 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of
83 Nothing -> do
86 Nothing -> do
@@ -96,6 +99,9 @@ expectDiagnostics expected = do
96 " but got " <> show actual
99 " but got " <> show actual
97 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m
100 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m
98
101
102+diagnostic :: Session PublishDiagnosticsNotification
103+diagnostic = LspTest.message
104+
99standardizeQuotes :: T.Text -> T.Text
105standardizeQuotes :: T.Text -> T.Text
100standardizeQuotes msg = let
106standardizeQuotes msg = let
101 repl '‘' = '\''
107 repl '‘' = '\''