git.iko.soy/ghcide
on 87f449d help sign in
5a754e1
swap
0 ahead, 175 behind
.azure/linux-stack.ymldeleted−63
since splitsnapshots
unifiedsplit
@@ -1,63 +0,0 @@
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.ymldeleted−68
@@ -1,68 +0,0 @@
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'))
.editorconfigdeleted−11
@@ -1,11 +0,0 @@
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
.ghcinew file+24
@@ -0,0 +1,24 @@
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,7 +4,3 @@ 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+2−12
@@ -73,23 +73,16 @@
73 - {name: ViewPatterns, within: []}
73 - {name: ViewPatterns, within: []}
74
74
75 # Shady extensions
75 # Shady extensions
76+ - {name: ImplicitParams, within: []}
76 - name: CPP
77 - name: CPP
77 within:
78 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
82 - Development.IDE.GHC.Compat
81 - Development.IDE.GHC.Compat
83− - Development.IDE.GHC.Orphans
84 - Development.IDE.GHC.Util
82 - Development.IDE.GHC.Util
85 - Development.IDE.Import.FindImports
83 - Development.IDE.Import.FindImports
86− - Development.IDE.LSP.Outline
84+ - Development.IDE.LSP.CodeAction
87 - Development.IDE.Spans.Calculate
85 - 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
93 - Main
86 - Main
94
87
95- flags:
88- flags:
@@ -101,12 +94,9 @@
101# - {name: Control.Arrow, within: []} # Certain modules are banned entirely
94# - {name: Control.Arrow, within: []} # Certain modules are banned entirely
102#
95#
103- functions:
96- functions:
104− # Things that are unsafe in Haskell base library
105 - {name: unsafeInterleaveIO, within: []}
97 - {name: unsafeInterleaveIO, within: []}
106 - {name: unsafeDupablePerformIO, within: []}
98 - {name: unsafeDupablePerformIO, within: []}
107 - {name: unsafeCoerce, within: []}
99 - {name: unsafeCoerce, within: []}
108− # Things that are a bit dangerous in the GHC API
109− - {name: nameModule, within: []}
110
100
111# Add custom hints for this project
101# Add custom hints for this project
112#
102#
CHANGELOG.md−57
@@ -1,62 +1,5 @@
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−
60### 0.0.5 (2019-12-12)
3### 0.0.5 (2019-12-12)
61
4
62* Support for GHC plugins (see #192)
5* Support for GHC plugins (see #192)
README.md+6−87
@@ -25,40 +25,13 @@ 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−
45## Using it
28## Using it
46
29
47### Install `ghcide`
30### Install `ghcide`
48
31
49#### With Nix
32#### With Nix
50
33
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−
60−2. If your `ghc` does not match nixpkgs you should try the [ghcide-nix repository](https://github.com/cachix/ghcide-nix)
34+[See ghcide-nix repository](https://github.com/hercules-ci/ghcide-nix)
61− which provides a `ghcide` via the `haskell.nix` infrastructure.
62
35
63#### With Cabal or Stack
36#### With Cabal or Stack
64
37
@@ -91,39 +64,11 @@ The `ghcide` executable mostly relies on [`hie-bios`](https://github.com/mpicker
91
64
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.
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.
93
66
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−
98### Using with VS Code
67### Using with VS Code
99
68
100You can install the VSCode extension from the [VSCode
69You can install the VSCode extension from the [VSCode
101marketplace](https://marketplace.visualstudio.com/items?itemName=DigitalAssetHoldingsLLC.ghcide).
70marketplace](https://marketplace.visualstudio.com/items?itemName=DigitalAssetHoldingsLLC.ghcide).
102
71
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−
127### Using with Emacs
72### Using with Emacs
128
73
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).
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).
@@ -234,11 +179,7 @@ Add this to your coc-settings.json (which you can edit with :CocConfig):
234```
179```
235
180
236Here's a nice article on setting up neovim and coc: [Vim and Haskell in
181Here's a nice article on setting up neovim and coc: [Vim and Haskell in
237−2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/) (this is actually for haskell-ide, not ghcide)
182+2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/)
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/).
242
183
243### SpaceVim
184### SpaceVim
244
185
@@ -259,8 +200,10 @@ Add this to your coc-settings.json (which you can edit with :CocConfig):
259{
200{
260 "languageserver": {
201 "languageserver": {
261 "haskell": {
202 "haskell": {
262− "command": "ghcide",
203+ "command": "stack",
263 "args": [
204 "args": [
205+ "exec",
206+ "ghcide",
264 "--lsp"
207 "--lsp"
265 ],
208 ],
266 "rootPatterns": [
209 "rootPatterns": [
@@ -283,32 +226,10 @@ Add this to your coc-settings.json (which you can edit with :CocConfig):
283This example above describes a setup in which `ghcide` is installed
226This example above describes a setup in which `ghcide` is installed
284using `stack install ghcide` within a project.
227using `stack install ghcide` within a project.
285
228
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−
300## Hacking on ghcide
229## Hacking on ghcide
301
230
302To build and work on `ghcide` itself, you can use Stack or cabal, e.g.,
231To build and work on `ghcide` itself, you can use Stack or cabal, e.g.,
303running `stack test` will execute the test suite.
232running `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.
312
233
313### Building the extension
234### Building the extension
314
235
@@ -325,10 +246,8 @@ Now opening a `.hs` file should work with `ghcide`.
325
246
326## History and relationship to other Haskell IDE's
247## History and relationship to other Haskell IDE's
327
248
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−
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).
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).
331
250
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.
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.
333
252
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/).
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/).
azure-pipelines.yml+184−3
@@ -4,7 +4,6 @@ trigger:
4 branches:
4 branches:
5 include:
5 include:
6 - master
6 - master
7− - azure*
8
7
9# Enable PR triggers that target the master branch
8# Enable PR triggers that target the master branch
10pr:
9pr:
@@ -14,5 +13,187 @@ pr:
14 - master
13 - master
15
14
16jobs:
15jobs:
17− - template: ./.azure/linux-stack.yml
16+ - job: ghcide_stack_86
18− - template: ./.azure/windows-stack.yml
17+ timeoutInMinutes: 60
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.hsdeleted−287
@@ -1,287 +0,0 @@
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+1−38
@@ -54,21 +54,8 @@ 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−
68## ghc: readCreateProcess: does not exist
57## ghc: readCreateProcess: does not exist
69
58
70−On Linux: try `stack exec ghcide`` instead of `ghcide` directly.
71−
72I was getting this in Windows: `ghcide.exe: ghc: readCreateProcess: does not exist (No such file or directory)`
59I was getting this in Windows: `ghcide.exe: ghc: readCreateProcess: does not exist (No such file or directory)`
73
60
74And we figured a hack around for this:
61And we figured a hack around for this:
@@ -82,21 +69,7 @@ Since I use stack. Required if you don't have a `ghc` on your path.
82
69
83## Could not find module ...
70## Could not find module ...
84
71
85−Try adding an explicit `hie.yaml` file and see if that helps.
72+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"}}
100
73
101## Works in `ghcide` but not my editor
74## Works in `ghcide` but not my editor
102
75
@@ -133,13 +106,3 @@ find ~/.emacs.d -name '*.elc' -exec rm {} \;
133## Docker stack builds
106## Docker stack builds
134
107
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).
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).
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,9 +11,6 @@ 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
17 }
14 }
18
15
19getArguments :: IO Arguments
16getArguments :: IO Arguments
@@ -30,6 +27,3 @@ arguments = Arguments
30 <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")
27 <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")
31 <*> many (argument str (metavar "FILES/DIRS..."))
28 <*> many (argument str (metavar "FILES/DIRS..."))
32 <*> switch (long "version" <> help "Show ghcide and GHC versions")
29 <*> 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+81−566
@@ -2,32 +2,18 @@
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 #-}
7
5
8module Main(main) where
6module Main(main) where
9
7
10−import Linker (initDynLinker)
11−import Data.IORef
12−import NameCache
13−import Packages
14−import Module
15import Arguments
8import Arguments
16−import Control.Concurrent.Async
9+import Data.Maybe
10+import Data.List.Extra
11+import System.FilePath
17import Control.Concurrent.Extra
12import Control.Concurrent.Extra
18import Control.Exception
13import Control.Exception
19import Control.Monad.Extra
14import Control.Monad.Extra
20−import Control.Monad.IO.Class
21import Data.Default
15import Data.Default
22−import Data.Either
16+import System.Time.Extra
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
31import Development.IDE.Core.FileStore
17import Development.IDE.Core.FileStore
32import Development.IDE.Core.OfInterest
18import Development.IDE.Core.OfInterest
33import Development.IDE.Core.Service
19import Development.IDE.Core.Service
@@ -40,53 +26,34 @@ import Development.IDE.Types.Diagnostics
40import Development.IDE.Types.Options
26import Development.IDE.Types.Options
41import Development.IDE.Types.Logger
27import Development.IDE.Types.Logger
42import Development.IDE.GHC.Util
28import Development.IDE.GHC.Util
43−import Development.IDE.Plugin
29+import qualified Data.Text as T
44−import Development.IDE.Plugin.Completions as Completions
45−import Development.IDE.Plugin.CodeAction as CodeAction
46−import qualified Language.Haskell.LSP.Core as LSP
30+import qualified Data.Text.IO as T
47import Language.Haskell.LSP.Messages
31import Language.Haskell.LSP.Messages
48−import Language.Haskell.LSP.Types
32+import Language.Haskell.LSP.Types (LspId(IdInt))
33+import Linker
49−import Data.Aeson (ToJSON(toJSON))
34+import Data.Version
50import Development.IDE.LSP.LanguageServer
35import Development.IDE.LSP.LanguageServer
51−import qualified System.Directory.Extra as IO
36+import System.Directory.Extra as IO
52import System.Environment
37import System.Environment
53import System.IO
38import System.IO
54import System.Exit
39import System.Exit
55−import System.FilePath
56−import System.Directory
57−import System.Time.Extra
58−import HIE.Bios.Environment (addCmdOpts, makeDynFlagsAbsolute)
59import Paths_ghcide
40import Paths_ghcide
60−import Development.GitRev
41+import Development.Shake hiding (Env)
61−import Development.Shake (Action, action)
62−import qualified Data.HashSet as HashSet
42+import qualified Data.Set as Set
63−import qualified Data.HashMap.Strict as HM
64import qualified Data.Map.Strict as Map
43import qualified Data.Map.Strict as Map
65−import qualified Crypto.Hash.SHA1 as H
44+
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)
71import GHC hiding (def)
45import GHC hiding (def)
72−import GHC.Check ( VersionCheck(..), makeGhcVersionChecker )
46+import qualified GHC.Paths
73−import Data.Either.Extra
74
47
75−import HIE.Bios.Cradle
48+import HIE.Bios
76−import HIE.Bios.Types
77
49
78−import Utils
50+-- Set the GHC libdir to the nix libdir if it's present.
51+getLibdir :: IO FilePath
52+getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
79
53
80−ghcideVersion :: IO String
54+ghcideVersion :: String
81−ghcideVersion = do
82− path <- getExecutablePath
83− let gitHashSection = case $(gitHash) of
84− x | x == "UNKNOWN" -> ""
85− x -> " (GIT hash: " <> x <> ")"
86− return $ "ghcide version: " <> showVersion version
55+ghcideVersion = "ghcide version: " <> showVersion version
87− <> " (GHC: " <> VERSION_ghc
56+ <> " (GHC: " <> VERSION_ghc <> ")"
88− <> ") (PATH: " <> path <> ")"
89− <> gitHashSection
90
57
91main :: IO ()
58main :: IO ()
92main = do
59main = do
@@ -94,76 +61,72 @@ main = do
94 -- then the language server will not work
61 -- then the language server will not work
95 Arguments{..} <- getArguments
62 Arguments{..} <- getArguments
96
63
97− if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess
64+ if argsVersion then putStrLn ghcideVersion >> exitSuccess
98− else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion
65+ else hPutStrLn stderr {- see WARNING above -} ghcideVersion
99
66
100 -- lock to avoid overlapping output on stdout
67 -- lock to avoid overlapping output on stdout
101 lock <- newLock
68 lock <- newLock
102 let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
69 let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
103 T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
70 T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
104
71
105− whenJust argsCwd IO.setCurrentDirectory
72+ whenJust argsCwd setCurrentDirectory
106
73
107− dir <- IO.getCurrentDirectory
74+ dir <- 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− }
116
75
117 if argLSP then do
76 if argLSP then do
118 t <- offsetTime
77 t <- offsetTime
119 hPutStrLn stderr "Starting LSP server..."
78 hPutStrLn stderr "Starting LSP server..."
120− hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
79+ hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcidie WITHOUT the --lsp option!"
121− runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do
80+ runLanguageServer def def $ \getLspId event vfs caps -> do
122 t <- t
81 t <- t
123 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
82 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
124− let options = (defaultIdeOptions $ loadSessionShake dir)
85+ let options = (defaultIdeOptions $ return session)
125− { optReportProgress = clientSupportsProgress caps
86+ { optReportProgress = clientSupportsProgress caps }
126− , optShakeProfiling = argsShakeProfiling
127− , optTesting = argsTesting
128− , optThreads = argsThreads
129− }
130− debouncer <- newAsyncDebouncer
131− initialise caps (mainRule >> pluginRules plugins >> action kick)
132− getLspId event (logger minBound) debouncer options vfs
87+ initialise (mainRule >> action kick) getLspId event (logger minBound) options vfs
133 else do
88 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−
138 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
89 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
139 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
90 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
140
91
141− putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir
92+ putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir
142− files <- expandFiles (argFiles ++ ["." | null argFiles])
93+ files <- nubOrd <$> expandFiles (argFiles ++ ["." | null argFiles])
143− -- LSP works with absolute file paths, so try and behave similarly
144− files <- nubOrd <$> mapM IO.canonicalizePath files
145 putStrLn $ "Found " ++ show (length files) ++ " files"
94 putStrLn $ "Found " ++ show (length files) ++ " files"
146
95
147− putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup"
96+ putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"
148 cradles <- mapM findCradle files
97 cradles <- mapM findCradle files
149 let ucradles = nubOrd cradles
98 let ucradles = nubOrd cradles
150 let n = length ucradles
99 let n = length ucradles
151 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
100 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+
152− putStrLn "\nStep 3/4: Initializing the IDE"
109+ putStrLn "\nStep 5/6: Initializing the IDE"
153 vfs <- makeVFSHandle
110 vfs <- makeVFSHandle
154− debouncer <- newAsyncDebouncer
111+ let cradlesToSessions = Map.fromList $ zip ucradles sessions
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
155− ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs
116+ ide <- initialise mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) (defaultIdeOptions $ return $ return . grab) vfs
156−
117+
157− putStrLn "\nStep 4/4: Type checking the files"
118+ putStrLn "\nStep 6/6: Type checking the files"
158− setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
119+ setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files
159− results <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath' files)
120+ results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files
160 let (worked, failed) = partition fst $ zip (map isJust results) files
121 let (worked, failed) = partition fst $ zip (map isJust results) files
161 when (failed /= []) $
122 when (failed /= []) $
162 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
123 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
163
124
164 let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
125 let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
165 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
126 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
166− return ()
127+
128+ unless (null failed) exitFailure
129+
167
130
168expandFiles :: [FilePath] -> IO [FilePath]
131expandFiles :: [FilePath] -> IO [FilePath]
169expandFiles = concatMapM $ \x -> do
132expandFiles = concatMapM $ \x -> do
@@ -172,7 +135,7 @@ expandFiles = concatMapM $ \x -> do
172 let recurse "." = True
135 let recurse "." = True
173 recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
136 recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
174 recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
137 recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
175− files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x
138+ files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> listFilesInside (return . recurse) x
176 when (null files) $
139 when (null files) $
177 fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
140 fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
178 return files
141 return files
@@ -181,414 +144,42 @@ expandFiles = concatMapM $ \x -> do
181kick :: Action ()
144kick :: Action ()
182kick = do
145kick = do
183 files <- getFilesOfInterest
146 files <- getFilesOfInterest
184− void $ uses TypeCheck $ HashSet.toList files
147+ void $ uses TypeCheck $ Set.toList files
185
148
186-- | Print an LSP event.
149-- | Print an LSP event.
187showEvent :: Lock -> FromServerMessage -> IO ()
150showEvent :: Lock -> FromServerMessage -> IO ()
188showEvent _ (EventFileDiagnostics _ []) = return ()
151showEvent _ (EventFileDiagnostics _ []) = return ()
189−showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =
152+showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
190− withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
153+ withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,) diags
191showEvent lock e = withLock lock $ print e
154showEvent lock e = withLock lock $ print e
192
155
193
156
194−-- | Run the specific cradle on a specific FilePath via hie-bios.
157+cradleToSession :: Cradle -> IO HscEnvEq
195−cradleToSessionOpts :: Cradle a -> FilePath -> IO (Either [CradleError] ComponentOptions)
158+cradleToSession cradle = do
196−cradleToSessionOpts cradle file = do
159+ opts <- either throwIO return =<< getCompilerOptions "" cradle
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
208 libdir <- getLibdir
160 libdir <- getLibdir
209− env <- runGhc (Just libdir) getSession
161+ env <- runGhc (Just libdir) $ do
162+ _targets <- initSession opts
163+ getSession
210 initDynLinker env
164 initDynLinker env
211− pure env
165+ newHscEnvEq 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
386
166
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)
403
167
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
404
181
405
182
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−
592-- | Memoize an IO function, with the characteristics:
183-- | Memoize an IO function, with the characteristics:
593--
184--
594-- * If multiple people ask for a result simultaneously, make sure you only compute it once.
185-- * If multiple people ask for a result simultaneously, make sure you only compute it once.
@@ -605,79 +196,3 @@ memoIO op = do
605 res <- onceFork $ op k
196 res <- onceFork $ op k
606 return (Map.insert k res mp, res)
197 return (Map.insert k res mp, res)
607 Just res -> return (mp, res)
198 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.hsdeleted−9
@@ -1,9 +0,0 @@
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 . --with-group=extra
3+curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s .
ghcide.cabal+19−156
@@ -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.2.0
5+version: 0.0.5
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-2020
10+copyright: Digital Asset 2018-2019
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,13 +15,7 @@ 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/hover/*.hs
18+ test/data/GotoHover.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
25
19
26source-repository head
20source-repository head
27 type: git
21 type: git
@@ -36,7 +30,6 @@ library
36 default-language: Haskell2010
30 default-language: Haskell2010
37 build-depends:
31 build-depends:
38 aeson,
32 aeson,
39− array,
40 async,
33 async,
41 base == 4.*,
34 base == 4.*,
42 binary,
35 binary,
@@ -46,28 +39,25 @@ library
46 deepseq,
39 deepseq,
47 directory,
40 directory,
48 extra,
41 extra,
49− fuzzy,
50 filepath,
42 filepath,
51− haddock-library >= 1.8,
52 hashable,
43 hashable,
53− haskell-lsp-types == 0.22.*,
44+ haskell-lsp-types >= 0.18,
54− haskell-lsp == 0.22.*,
45+ haskell-lsp >= 0.18,
55 mtl,
46 mtl,
56 network-uri,
47 network-uri,
57 prettyprinter-ansi-terminal,
48 prettyprinter-ansi-terminal,
58 prettyprinter-ansi-terminal,
49 prettyprinter-ansi-terminal,
59 prettyprinter,
50 prettyprinter,
60− regex-tdfa >= 1.3.1.0,
61 rope-utf16-splay,
51 rope-utf16-splay,
62 safe-exceptions,
52 safe-exceptions,
63− shake >= 0.18.4,
53+ shake >= 0.17.5,
64 sorted-list,
54 sorted-list,
65 stm,
55 stm,
66 syb,
56 syb,
67 text,
57 text,
68 time,
58 time,
69 transformers,
59 transformers,
70− unordered-containers >= 0.2.10.0,
60+ unordered-containers,
71 utf8-string,
61 utf8-string,
72 hslogger
62 hslogger
73 if flag(ghc-lib)
63 if flag(ghc-lib)
@@ -80,10 +70,7 @@ library
80 ghc-boot-th,
70 ghc-boot-th,
81 ghc-boot,
71 ghc-boot,
82 ghc >= 8.4
72 ghc >= 8.4
83− if os(windows)
73+ if !os(windows)
84− build-depends:
85− Win32
86− else
87 build-depends:
74 build-depends:
88 unix
75 unix
89 c-sources:
76 c-sources:
@@ -109,133 +96,72 @@ library
109 include-dirs:
96 include-dirs:
110 include
97 include
111 exposed-modules:
98 exposed-modules:
112− Development.IDE.Compat
113− Development.IDE.Core.Debouncer
114 Development.IDE.Core.FileStore
99 Development.IDE.Core.FileStore
115− Development.IDE.Core.IdeConfiguration
116 Development.IDE.Core.OfInterest
100 Development.IDE.Core.OfInterest
117 Development.IDE.Core.PositionMapping
101 Development.IDE.Core.PositionMapping
118 Development.IDE.Core.Rules
102 Development.IDE.Core.Rules
119 Development.IDE.Core.RuleTypes
103 Development.IDE.Core.RuleTypes
120 Development.IDE.Core.Service
104 Development.IDE.Core.Service
121 Development.IDE.Core.Shake
105 Development.IDE.Core.Shake
122− Development.IDE.GHC.Error
123 Development.IDE.GHC.Util
106 Development.IDE.GHC.Util
124 Development.IDE.Import.DependencyInformation
107 Development.IDE.Import.DependencyInformation
125− Development.IDE.LSP.HoverDefinition
126 Development.IDE.LSP.LanguageServer
108 Development.IDE.LSP.LanguageServer
127− Development.IDE.LSP.Outline
128 Development.IDE.LSP.Protocol
109 Development.IDE.LSP.Protocol
129 Development.IDE.LSP.Server
110 Development.IDE.LSP.Server
130− Development.IDE.Spans.Common
131 Development.IDE.Types.Diagnostics
111 Development.IDE.Types.Diagnostics
132 Development.IDE.Types.Location
112 Development.IDE.Types.Location
133 Development.IDE.Types.Logger
113 Development.IDE.Types.Logger
134 Development.IDE.Types.Options
114 Development.IDE.Types.Options
135− Development.IDE.Plugin
136− Development.IDE.Plugin.Completions
137− Development.IDE.Plugin.CodeAction
138 other-modules:
115 other-modules:
116+ Development.IDE.Core.Debouncer
139 Development.IDE.Core.Compile
117 Development.IDE.Core.Compile
140 Development.IDE.Core.Preprocessor
118 Development.IDE.Core.Preprocessor
141− Development.IDE.Core.FileExists
142 Development.IDE.GHC.Compat
119 Development.IDE.GHC.Compat
143 Development.IDE.GHC.CPP
120 Development.IDE.GHC.CPP
121+ Development.IDE.GHC.Error
144 Development.IDE.GHC.Orphans
122 Development.IDE.GHC.Orphans
145 Development.IDE.GHC.Warnings
123 Development.IDE.GHC.Warnings
146− Development.IDE.GHC.WithDynFlags
147 Development.IDE.Import.FindImports
124 Development.IDE.Import.FindImports
125+ Development.IDE.LSP.CodeAction
126+ Development.IDE.LSP.Definition
127+ Development.IDE.LSP.Hover
148 Development.IDE.LSP.Notifications
128 Development.IDE.LSP.Notifications
149 Development.IDE.Spans.AtPoint
129 Development.IDE.Spans.AtPoint
150 Development.IDE.Spans.Calculate
130 Development.IDE.Spans.Calculate
151 Development.IDE.Spans.Documentation
131 Development.IDE.Spans.Documentation
152 Development.IDE.Spans.Type
132 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
166 ghc-options: -Wall -Wno-name-shadowing
133 ghc-options: -Wall -Wno-name-shadowing
167
134
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−
176executable ghcide
135executable ghcide
177 if flag(ghc-lib)
136 if flag(ghc-lib)
178 buildable: False
137 buildable: False
179 default-language: Haskell2010
138 default-language: Haskell2010
180 hs-source-dirs: exe
139 hs-source-dirs: exe
181− ghc-options:
182− -threaded
183− -Wall
184− -Wno-name-shadowing
140+ ghc-options: -threaded -Wall -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"
191 main-is: Main.hs
141 main-is: Main.hs
192 build-depends:
142 build-depends:
193− time,
194− async,
195 hslogger,
143 hslogger,
196− aeson,
197 base == 4.*,
144 base == 4.*,
198− binary,
199− base16-bytestring >=0.1.1 && <0.2,
200− bytestring,
201 containers,
145 containers,
202− cryptohash-sha1 >=0.11.100 && <0.12,
203 data-default,
146 data-default,
204− deepseq,
205 directory,
147 directory,
206 extra,
148 extra,
207 filepath,
149 filepath,
208− ghc-check >= 0.3.0.1 && < 0.4,
209 ghc-paths,
150 ghc-paths,
210 ghc,
151 ghc,
211− gitrev,
212− hashable,
213 haskell-lsp,
152 haskell-lsp,
214− haskell-lsp-types,
215− hie-bios >= 0.5.0 && < 0.6,
153+ hie-bios >= 0.2 && < 0.3,
216 ghcide,
154 ghcide,
217 optparse-applicative,
155 optparse-applicative,
218 shake,
156 shake,
219− text,
157+ text
220− unordered-containers
221 other-modules:
158 other-modules:
222− Utils
223 Arguments
159 Arguments
224 Paths_ghcide
160 Paths_ghcide
225
161
226 default-extensions:
162 default-extensions:
227− BangPatterns
228− DeriveFunctor
229− DeriveGeneric
230− GeneralizedNewtypeDeriving
231− LambdaCase
232− NamedFieldPuns
233− OverloadedStrings
234 RecordWildCards
163 RecordWildCards
235− ScopedTypeVariables
236− StandaloneDeriving
237 TupleSections
164 TupleSections
238− TypeApplications
239 ViewPatterns
165 ViewPatterns
240
166
241test-suite ghcide-tests
167test-suite ghcide-tests
@@ -244,10 +170,8 @@ test-suite ghcide-tests
244 type: exitcode-stdio-1.0
170 type: exitcode-stdio-1.0
245 default-language: Haskell2010
171 default-language: Haskell2010
246 build-tool-depends:
172 build-tool-depends:
247− ghcide:ghcide,
173+ ghcide:ghcide
248− ghcide:ghcide-test-preprocessor
249 build-depends:
174 build-depends:
250− aeson,
251 base,
175 base,
252 bytestring,
176 bytestring,
253 containers,
177 containers,
@@ -264,22 +188,13 @@ test-suite ghcide-tests
264 --------------------------------------------------------------
188 --------------------------------------------------------------
265 ghcide,
189 ghcide,
266 ghc-typelits-knownnat,
190 ghc-typelits-knownnat,
267− haddock-library,
268− haskell-lsp,
269 haskell-lsp-types,
191 haskell-lsp-types,
270− network-uri,
271 lens,
192 lens,
272− lsp-test >= 0.11.0.1 && < 0.12,
193+ lsp-test >= 0.8,
273 parser-combinators,
194 parser-combinators,
274− QuickCheck,
275− quickcheck-instances,
276− rope-utf16-splay,
277− shake,
278 tasty,
195 tasty,
279− tasty-expected-failure,
280 tasty-hunit,
196 tasty-hunit,
281− tasty-quickcheck,
197+ tasty-expected-failure,
282− tasty-rerun,
283 text
198 text
284 hs-source-dirs: test/cabal test/exe test/src
199 hs-source-dirs: test/cabal test/exe test/src
285 include-dirs: include
200 include-dirs: include
@@ -289,56 +204,4 @@ test-suite ghcide-tests
289 Development.IDE.Test
204 Development.IDE.Test
290 Development.IDE.Test.Runfiles
205 Development.IDE.Test.Runfiles
291 default-extensions:
206 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
338 OverloadedStrings
207 OverloadedStrings
339− RecordWildCards
340− ScopedTypeVariables
341− StandaloneDeriving
342− TupleSections
343− TypeApplications
344− ViewPatterns
hie.yaml+1−12
@@ -1,12 +1 @@
1−cradle:
1+cradle: {stack}
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.hsdeleted−1928
@@ -1,1928 +0,0 @@
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.hsdeleted−1789
@@ -1,1789 +0,0 @@
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.hsdeleted−19
@@ -1,19 +0,0 @@
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+105−322
@@ -9,7 +9,6 @@
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(..)
13 , compileModule
12 , compileModule
14 , parseModule
13 , parseModule
15 , typecheckModule
14 , typecheckModule
@@ -17,18 +16,10 @@ module Development.IDE.Core.Compile
17 , addRelativeImport
16 , addRelativeImport
18 , mkTcModuleResult
17 , mkTcModuleResult
19 , generateByteCode
18 , generateByteCode
20− , generateAndWriteHieFile
21− , generateAndWriteHiFile
22− , getModSummaryFromImports
23− , loadHieFile
24− , loadInterface
25− , loadDepModule
26− , loadModuleHome
27 ) where
19 ) where
28
20
29import Development.IDE.Core.RuleTypes
21import Development.IDE.Core.RuleTypes
30import Development.IDE.Core.Preprocessor
22import Development.IDE.Core.Preprocessor
31−import Development.IDE.Core.Shake
32import Development.IDE.GHC.Error
23import Development.IDE.GHC.Error
33import Development.IDE.GHC.Warnings
24import Development.IDE.GHC.Warnings
34import Development.IDE.Types.Diagnostics
25import Development.IDE.Types.Diagnostics
@@ -37,7 +28,6 @@ import Development.IDE.GHC.Util
37import qualified GHC.LanguageExtensions.Type as GHC
28import qualified GHC.LanguageExtensions.Type as GHC
38import Development.IDE.Types.Options
29import Development.IDE.Types.Options
39import Development.IDE.Types.Location
30import Development.IDE.Types.Location
40−import Outputable
41
31
42#if MIN_GHC_API_VERSION(8,6,0)
32#if MIN_GHC_API_VERSION(8,6,0)
43import DynamicLoading (initializePlugins)
33import DynamicLoading (initializePlugins)
@@ -46,60 +36,42 @@ import DynamicLoading (initializePlugins)
46import GHC hiding (parseModule, typecheckModule)
36import GHC hiding (parseModule, typecheckModule)
47import qualified Parser
37import qualified Parser
48import Lexer
38import Lexer
49−#if MIN_GHC_API_VERSION(8,10,0)
50−#else
51import ErrUtils
39import ErrUtils
52−#endif
53
40
54−import Finder
41+import qualified GHC
55−import qualified Development.IDE.GHC.Compat as GHC
56−import qualified Development.IDE.GHC.Compat as Compat
57import GhcMonad
42import GhcMonad
58import GhcPlugins as GHC hiding (fst3, (<>))
43import GhcPlugins as GHC hiding (fst3, (<>))
59import qualified HeaderInfo as Hdr
44import qualified HeaderInfo as Hdr
60−import HscMain (hscInteractive, hscSimplify)
45+import HscMain (hscInteractive)
61−import LoadIface (readIface)
62−import qualified Maybes
63import MkIface
46import MkIface
64−import NameCache
65import StringBuffer as SB
47import StringBuffer as SB
66−import TcRnMonad (initIfaceLoad, tcg_th_coreplugins)
67−import TcIface (typecheckIface)
68import TidyPgm
48import TidyPgm
69
49
70−import Control.Exception.Safe
71import Control.Monad.Extra
50import Control.Monad.Extra
72import Control.Monad.Except
51import Control.Monad.Except
73import Control.Monad.Trans.Except
52import Control.Monad.Trans.Except
74−import Data.Bifunctor (first, second)
53+import Data.Function
54+import Data.Ord
75import qualified Data.Text as T
55import qualified Data.Text as T
76import Data.IORef
56import Data.IORef
77import Data.List.Extra
57import Data.List.Extra
78import Data.Maybe
58import Data.Maybe
59+import Data.Tuple.Extra
79import qualified Data.Map.Strict as Map
60import qualified Data.Map.Strict as Map
80import System.FilePath
61import 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)
87
62
88
63
89−-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
64+-- | Given a string buffer, return a pre-processed @ParsedModule@.
90parseModule
65parseModule
91 :: IdeOptions
66 :: IdeOptions
92 -> HscEnv
67 -> HscEnv
93− -> [PackageName]
94 -> FilePath
68 -> FilePath
95 -> Maybe SB.StringBuffer
69 -> Maybe SB.StringBuffer
96− -> IO (IdeResult (StringBuffer, ParsedModule))
70+ -> IO ([FileDiagnostic], Maybe ParsedModule)
97−parseModule IdeOptions{..} env comp_pkgs filename mbContents =
71+parseModule IdeOptions{..} env file =
98− fmap (either (, Nothing) id) $
72+ fmap (either (, Nothing) (second Just)) .
99− evalGhcEnv env $ runExceptT $ do
73+ -- We need packages since imports fail to resolve otherwise.
100− (contents, dflags) <- preprocessor filename mbContents
101− (diag, modu) <- parseFileContents optPreprocessor dflags comp_pkgs filename contents
74+ runGhcEnv env . runExceptT . parseFileContents optPreprocessor file
102− return (diag, Just (contents, modu))
103
75
104
76
105-- | Given a package identifier, what packages does it depend on
77-- | Given a package identifier, what packages does it depend on
@@ -110,39 +82,31 @@ computePackageDeps
110computePackageDeps env pkg = do
82computePackageDeps env pkg = do
111 let dflags = hsc_dflags env
83 let dflags = hsc_dflags env
112 case lookupInstalledPackage dflags pkg of
84 case lookupInstalledPackage dflags pkg of
113− Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $
85+ Nothing -> return $ Left [ideErrorText (toNormalizedFilePath noFilePath) $
114 T.pack $ "unknown package: " ++ show pkg]
86 T.pack $ "unknown package: " ++ show pkg]
115 Just pkgInfo -> return $ Right $ depends pkgInfo
87 Just pkgInfo -> return $ Right $ depends pkgInfo
116
88
89+
90+-- | Typecheck a single module using the supplied dependencies and packages.
91+typecheckModule
117−typecheckModule :: IdeDefer
92+ :: IdeDefer
118− -> HscEnv
93+ -> HscEnv
119− -> [(ModSummary, (ModIface, Maybe Linkable))]
94+ -> [TcModuleResult]
120− -> ParsedModule
95+ -> ParsedModule
121− -> IO (IdeResult (HscEnv, TcModuleResult))
96+ -> IO ([FileDiagnostic], Maybe TcModuleResult)
122−typecheckModule (IdeDefer defer) hsc depsIn pm = do
97+typecheckModule (IdeDefer defer) packageState deps pm =
98+ let demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
99+ in
123− fmap (either (, Nothing) (second Just . sequence) . sequence) $
100+ fmap (either (, Nothing) (second Just)) $
124− runGhcEnv hsc $
101+ runGhcEnv packageState $
125− catchSrcErrors "typecheck" $ do
102+ catchSrcErrors "typecheck" $ do
126− -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.
103+ setupEnv deps
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−
133− let modSummary = pm_mod_summary pm
104+ let modSummary = pm_mod_summary pm
134− dflags = ms_hspp_opts modSummary
135−
136− mapM_ (uncurry loadDepModule . snd) deps
137− modSummary' <- initPlugins modSummary
105+ modSummary' <- initPlugins modSummary
138− (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
106+ (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
139− GHC.typecheckModule $ enableTopLevelWarnings
140− $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
107+ GHC.typecheckModule $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
141− tcm2 <- mkTcModuleResult tcm
108+ tcm2 <- mkTcModuleResult tcm
142− let errorPipeline = unDefer . hideDiag dflags
143− return (map errorPipeline warnings, tcm2)
109+ return (map unDefer warnings, tcm2)
144− where
145− demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
146
110
147initPlugins :: GhcMonad m => ModSummary -> m ModSummary
111initPlugins :: GhcMonad m => ModSummary -> m ModSummary
148initPlugins modSummary = do
112initPlugins modSummary = do
@@ -154,25 +118,18 @@ initPlugins modSummary = do
154 return modSummary
118 return modSummary
155#endif
119#endif
156
120
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−
163-- | Compile a single type-checked module to a 'CoreModule' value, or
121-- | Compile a single type-checked module to a 'CoreModule' value, or
164-- provide errors.
122-- provide errors.
165compileModule
123compileModule
166− :: RunSimplifier
167− -> HscEnv
124+ :: HscEnv
168− -> [(ModSummary, HomeModInfo)]
125+ -> [TcModuleResult]
169 -> TcModuleResult
126 -> TcModuleResult
170− -> IO (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
127+ -> IO ([FileDiagnostic], Maybe (SafeHaskellMode, CgGuts, ModDetails))
171−compileModule (RunSimplifier simplify) packageState deps tmr =
128+compileModule packageState deps tmr =
172 fmap (either (, Nothing) (second Just)) $
129 fmap (either (, Nothing) (second Just)) $
173− evalGhcEnv packageState $
130+ runGhcEnv packageState $
174 catchSrcErrors "compile" $ do
131 catchSrcErrors "compile" $ do
175− setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])
132+ setupEnv (deps ++ [tmr])
176
133
177 let tm = tmrModule tmr
134 let tm = tmrModule tmr
178 session <- getSession
135 session <- getSession
@@ -181,30 +138,20 @@ compileModule (RunSimplifier simplify) packageState deps tmr =
181 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
138 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
182 let tm' = tm{tm_parsed_module = pm'}
139 let tm' = tm{tm_parsed_module = pm'}
183 GHC.dm_core_module <$> GHC.desugarModule tm'
140 GHC.dm_core_module <$> GHC.desugarModule tm'
184− let tc_result = fst (tm_internals_ (tmrModule tmr))
141+
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
191 -- give variables unique OccNames
142 -- give variables unique OccNames
192− (guts, details) <- liftIO $ tidyProgram session desugared_guts
143+ (guts, details) <- liftIO $ tidyProgram session desugar
193 return (map snd warnings, (mg_safe_haskell desugar, guts, details))
144 return (map snd warnings, (mg_safe_haskell desugar, guts, details))
194
145
195−generateByteCode :: HscEnv -> [(ModSummary, HomeModInfo)] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable)
146+generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO ([FileDiagnostic], Maybe Linkable)
196generateByteCode hscEnv deps tmr guts =
147generateByteCode hscEnv deps tmr guts =
197 fmap (either (, Nothing) (second Just)) $
148 fmap (either (, Nothing) (second Just)) $
198− evalGhcEnv hscEnv $
149+ runGhcEnv hscEnv $
199 catchSrcErrors "bytecode" $ do
150 catchSrcErrors "bytecode" $ do
200− setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])
151+ setupEnv (deps ++ [tmr])
201 session <- getSession
152 session <- getSession
202 (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->
153 (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->
203−#if MIN_GHC_API_VERSION(8,10,0)
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)
154+ liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)
207−#endif
208 let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr
155 let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr
209 let unlinked = BCOs bytecode sptEntries
156 let unlinked = BCOs bytecode sptEntries
210 let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
157 let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
@@ -223,20 +170,12 @@ demoteTypeErrorsToWarnings =
223 . (`gopt_set` Opt_DeferTypedHoles)
170 . (`gopt_set` Opt_DeferTypedHoles)
224 . (`gopt_set` Opt_DeferOutOfScopeVariables)
171 . (`gopt_set` Opt_DeferOutOfScopeVariables)
225
172
226−enableTopLevelWarnings :: ParsedModule -> ParsedModule
173+ update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary
227−enableTopLevelWarnings =
174+ update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}
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)))
233
175
234−update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary
235−update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}
236−
237−update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule
176+ update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule
238−update_pm_mod_summary up pm =
177+ update_pm_mod_summary up pm =
239− pm{pm_mod_summary = up $ pm_mod_summary pm}
178+ pm{pm_mod_summary = up $ pm_mod_summary pm}
240
179
241unDefer :: (WarnReason, FileDiagnostic) -> FileDiagnostic
180unDefer :: (WarnReason, FileDiagnostic) -> FileDiagnostic
242unDefer (Reason Opt_WarnDeferredTypeErrors , fd) = upgradeWarningToError fd
181unDefer (Reason Opt_WarnDeferredTypeErrors , fd) = upgradeWarningToError fd
@@ -245,17 +184,12 @@ unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = upgradeWarningToError
245unDefer ( _ , fd) = fd
184unDefer ( _ , fd) = fd
246
185
247upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
186upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
248−upgradeWarningToError (nfp, sh, fd) =
187+upgradeWarningToError (nfp, fd) =
249− (nfp, sh, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where
188+ (nfp, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where
250 warn2err :: T.Text -> T.Text
189 warn2err :: T.Text -> T.Text
251 warn2err = T.intercalate ": error:" . T.splitOn ": warning:"
190 warn2err = T.intercalate ": error:" . T.splitOn ": warning:"
252
191
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−
258−addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags
192+addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags
259addRelativeImport fp modu dflags = dflags
193addRelativeImport fp modu dflags = dflags
260 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
194 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
261
195
@@ -265,81 +199,25 @@ mkTcModuleResult
265 -> m TcModuleResult
199 -> m TcModuleResult
266mkTcModuleResult tcm = do
200mkTcModuleResult tcm = do
267 session <- getSession
201 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
272− (iface, _) <- liftIO $ mkIfaceTc session Nothing sf details tcGblEnv
202+ (iface, _) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv
273−#endif
274 let mod_info = HomeModInfo iface details Nothing
203 let mod_info = HomeModInfo iface details Nothing
275 return $ TcModuleResult tcm mod_info
204 return $ TcModuleResult tcm mod_info
276 where
205 where
277 (tcGblEnv, details) = tm_internals_ tcm
206 (tcGblEnv, details) = tm_internals_ tcm
278
207
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−
325-- | Setup the environment that GHC needs according to our
208-- | Setup the environment that GHC needs according to our
326-- best understanding (!)
209-- best understanding (!)
327−--
328−-- This involves setting up the finder cache and populating the
329−-- HPT.
330−setupEnv :: GhcMonad m => [(ModSummary, HomeModInfo)] -> m ()
210+setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
331−setupEnv tms = do
211+setupEnv tmsIn = do
332− setupFinderCache (map fst tms)
212+ -- if both a .hs-boot file and a .hs file appear here, we want to make sure that the .hs file
333− -- load dependent modules, which must be in topological order.
213+ -- takes precedence, so put the .hs-boot file earlier in the list
334− modifySession $ \e ->
214+ let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule
335− foldl' (\e (_, hmi) -> loadModuleHome hmi e) e tms
215+ tms = sortBy (compare `on` Down . isSourceFile) tmsIn
336
216
337−-- | Initialise the finder cache, dependencies should be topologically
338−-- sorted.
339−setupFinderCache :: GhcMonad m => [ModSummary] -> m ()
340−setupFinderCache mss = do
341 session <- getSession
217 session <- getSession
342
218
219+ let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
220+
343 -- set the target and module graph in the session
221 -- set the target and module graph in the session
344 let graph = mkModuleGraph mss
222 let graph = mkModuleGraph mss
345 setSession session { hsc_mod_graph = graph }
223 setSession session { hsc_mod_graph = graph }
@@ -358,40 +236,26 @@ setupFinderCache mss = do
358 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache
236 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache
359 modifySession $ \s -> s { hsc_FC = newFinderCacheVar }
237 modifySession $ \s -> s { hsc_FC = newFinderCacheVar }
360
238
239+ -- load dependent modules, which must be in topological order.
240+ mapM_ loadModuleHome tms
241+
361
242
362-- | Load a module, quickly. Input doesn't need to be desugared.
243-- | Load a module, quickly. Input doesn't need to be desugared.
363-- A module must be loaded before dependent modules can be typechecked.
244-- A module must be loaded before dependent modules can be typechecked.
364-- This variant of loadModuleHome will *never* cause recompilation, it just
245-- This variant of loadModuleHome will *never* cause recompilation, it just
365-- modifies the session.
246-- 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.
370loadModuleHome
247loadModuleHome
371− :: HomeModInfo
248+ :: (GhcMonad m)
372− -> HscEnv
249+ => TcModuleResult
373− -> HscEnv
250+ -> m ()
374−loadModuleHome mod_info e =
251+loadModuleHome tmr = modifySession $ \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
383− let hsc' = hsc { hsc_HPT = addToHpt (hsc_HPT hsc) mod (HomeModInfo iface details linkable) }
252+ e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
384− initIfaceLoad hsc' (typecheckIface iface)
253+ where
385− let mod_info = HomeModInfo iface details linkable
254+ ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
386− return $ loadModuleHome mod_info hsc
255+ mod_info = tmrModInfo tmr
387− where
256+ mod = ms_mod_name ms
388− mod = moduleName $ mi_module iface
257+
389
258
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'
395
259
396-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's
260-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's
397-- name and its imports.
261-- name and its imports.
@@ -412,18 +276,30 @@ getImportsParsed dflags (L loc parsed) = do
412 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
276 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
413 ])
277 ])
414
278
279+
415-- | Produce a module summary from a StringBuffer.
280-- | Produce a module summary from a StringBuffer.
416getModSummaryFromBuffer
281getModSummaryFromBuffer
417 :: GhcMonad m
282 :: GhcMonad m
418 => FilePath
283 => FilePath
284+ -> SB.StringBuffer
419 -> DynFlags
285 -> DynFlags
420 -> GHC.ParsedSource
286 -> GHC.ParsedSource
421 -> ExceptT [FileDiagnostic] m ModSummary
287 -> ExceptT [FileDiagnostic] m ModSummary
422−getModSummaryFromBuffer fp dflags parsed = do
288+getModSummaryFromBuffer fp contents dflags parsed = do
423 (modName, imports) <- liftEither $ getImportsParsed dflags parsed
289 (modName, imports) <- liftEither $ getImportsParsed dflags parsed
424
290
425− modLoc <- liftIO $ mkHomeModLocation dflags modName fp
291+ let modLoc = ModLocation
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+ }
426− let InstalledUnitId unitId = thisInstalledUnitId dflags
302+ InstalledUnitId unitId = thisInstalledUnitId dflags
427 return $ ModSummary
303 return $ ModSummary
428 { ms_mod = mkModule (fsToUnitId unitId) modName
304 { ms_mod = mkModule (fsToUnitId unitId) modName
429 , ms_location = modLoc
305 , ms_location = modLoc
@@ -435,7 +311,7 @@ getModSummaryFromBuffer fp dflags parsed = do
435 , ms_textual_imps = [imp | (False, imp) <- imports]
311 , ms_textual_imps = [imp | (False, imp) <- imports]
436 , ms_hspp_file = fp
312 , ms_hspp_file = fp
437 , ms_hspp_opts = dflags
313 , ms_hspp_opts = dflags
438− , ms_hspp_buf = Nothing
314+ , ms_hspp_buf = Just contents
439
315
440 -- defaults:
316 -- defaults:
441 , ms_hsc_src = sourceType
317 , ms_hsc_src = sourceType
@@ -448,71 +324,27 @@ getModSummaryFromBuffer fp dflags parsed = do
448 , ms_parsed_mod = Nothing
324 , ms_parsed_mod = Nothing
449 }
325 }
450 where
326 where
451− sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile
327+ (sourceType, derivedFile) =
452−
328+ let (stem, ext) = splitExtension fp in
453−-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports.
329+ if "-boot" `isSuffixOf` ext
454−-- Runs preprocessors as needed.
330+ then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")
455−getModSummaryFromImports
331+ else (HsSrcFile , \newExt -> stem <.> newExt)
456− :: (HasDynFlags m, ExceptionMonad m, MonadIO m)
332+
457− => FilePath
333+
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−
497−-- | Given a buffer, flags, and file path, produce a
334+-- | Given a buffer, flags, file path and module summary, produce a
498−-- parsed module (or errors) and any parse warnings. Does not run any preprocessors
335+-- parsed module (or errors) and any parse warnings.
499parseFileContents
336parseFileContents
500 :: GhcMonad m
337 :: GhcMonad m
501 => (GHC.ParsedSource -> IdePreprocessedSource)
338 => (GHC.ParsedSource -> IdePreprocessedSource)
502− -> DynFlags -- ^ flags to use
503− -> [PackageName] -- ^ The package imports to ignore
504 -> FilePath -- ^ the filename (for source locations)
339 -> FilePath -- ^ the filename (for source locations)
505− -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
340+ -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
506 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
341 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
507−parseFileContents customPreprocessor dflags comp_pkgs filename contents = do
342+parseFileContents customPreprocessor filename mbContents = do
343+ (contents, dflags) <- preprocessor filename mbContents
508 let loc = mkRealSrcLoc (mkFastString filename) 1 1
344 let loc = mkRealSrcLoc (mkFastString filename) 1 1
509 case unP Parser.parseModule (mkPState dflags contents loc) of
345 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
513 PFailed _ locErr msgErr ->
346 PFailed _ locErr msgErr ->
514 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
347 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
515−#endif
516 POk pst rdr_module ->
348 POk pst rdr_module ->
517 let hpm_annotations =
349 let hpm_annotations =
518 (Map.fromListWith (++) $ annotations pst,
350 (Map.fromListWith (++) $ annotations pst,
@@ -536,63 +368,14 @@ parseFileContents customPreprocessor dflags comp_pkgs filename contents = do
536 -- Ok, we got here. It's safe to continue.
368 -- Ok, we got here. It's safe to continue.
537 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
369 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
538 unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs
370 unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs
539− let parsed' = removePackageImports comp_pkgs parsed
540 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
371 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
541− ms <- getModSummaryFromBuffer filename dflags parsed'
372+ ms <- getModSummaryFromBuffer filename contents dflags parsed
542 let pm =
373 let pm =
543 ParsedModule {
374 ParsedModule {
544 pm_mod_summary = ms
375 pm_mod_summary = ms
545− , pm_parsed_source = parsed'
376+ , pm_parsed_source = parsed
546 , pm_extra_src_files=[] -- src imports not allowed
377 , pm_extra_src_files=[] -- src imports not allowed
547 , pm_annotations = hpm_annotations
378 , pm_annotations = hpm_annotations
548 }
379 }
549 warnings = diagFromErrMsgs "parser" dflags warns
380 warnings = diagFromErrMsgs "parser" dflags warns
550 pure (warnings ++ preproc_warnings, pm)
381 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+11−18
@@ -3,18 +3,16 @@
3
3
4module Development.IDE.Core.Debouncer
4module Development.IDE.Core.Debouncer
5 ( Debouncer
5 ( Debouncer
6+ , newDebouncer
6 , registerEvent
7 , registerEvent
7− , newAsyncDebouncer
8− , noopDebouncer
9 ) where
8 ) where
10
9
11import Control.Concurrent.Extra
10import Control.Concurrent.Extra
12import Control.Concurrent.Async
11import Control.Concurrent.Async
13import Control.Exception
12import Control.Exception
14import Control.Monad.Extra
13import Control.Monad.Extra
15−import Data.Hashable
14+import Data.Map.Strict (Map)
16−import Data.HashMap.Strict (HashMap)
17−import qualified Data.HashMap.Strict as Map
15+import qualified Data.Map.Strict as Map
18import System.Time.Extra
16import System.Time.Extra
19
17
20-- | A debouncer can be used to avoid triggering many events
18-- | A debouncer can be used to avoid triggering many events
@@ -23,14 +21,13 @@ import System.Time.Extra
23-- by delaying each event for a given time. If another event
21-- by delaying each event for a given time. If another event
24-- is registered for the same key within that timeframe,
22-- is registered for the same key within that timeframe,
25-- only the new event will fire.
23-- 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.
29−newtype Debouncer k = Debouncer { registerEvent :: Seconds -> k -> IO () -> IO () }
24+newtype Debouncer k = Debouncer (Var (Map k (Async ())))
30
25
31−-- | Debouncer used in the IDE that delays events as expected.
26+-- | Create a new empty debouncer.
32−newAsyncDebouncer :: (Eq k, Hashable k) => IO (Debouncer k)
27+newDebouncer :: IO (Debouncer k)
33−newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty
28+newDebouncer = do
29+ m <- newVar Map.empty
30+ pure $ Debouncer m
34
31
35-- | Register an event that will fire after the given delay if no other event
32-- | Register an event that will fire after the given delay if no other event
36-- for the same key gets registered until then.
33-- for the same key gets registered until then.
@@ -38,15 +35,11 @@ newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty
38-- If there is a pending event for the same key, the pending event will be killed.
35-- If there is a pending event for the same key, the pending event will be killed.
39-- Events are run unmasked so it is up to the user of `registerEvent`
36-- Events are run unmasked so it is up to the user of `registerEvent`
40-- to mask if required.
37-- to mask if required.
41−asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()
38+registerEvent :: Ord k => Debouncer k -> Seconds -> k -> IO () -> IO ()
42−asyncRegisterEvent d delay k fire = modifyVar_ d $ \m -> mask_ $ do
39+registerEvent (Debouncer d) delay k fire = modifyVar_ d $ \m -> mask_ $ do
43 whenJust (Map.lookup k m) cancel
40 whenJust (Map.lookup k m) cancel
44 a <- asyncWithUnmask $ \unmask -> unmask $ do
41 a <- asyncWithUnmask $ \unmask -> unmask $ do
45 sleep delay
42 sleep delay
46 fire
43 fire
47 modifyVar_ d (pure . Map.delete k)
44 modifyVar_ d (pure . Map.delete k)
48 pure $ Map.insert k a m
45 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.hsdeleted−181
@@ -1,181 +0,0 @@
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+69−21
@@ -4,25 +4,32 @@
4{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE TypeFamilies #-}
5
5
6module Development.IDE.Core.FileStore(
6module Development.IDE.Core.FileStore(
7− getFileContents,
7+ getFileExists, getFileContents,
8− getVirtualFile,
9 setBufferModified,
8 setBufferModified,
10 setSomethingModified,
9 setSomethingModified,
11 fileStoreRules,
10 fileStoreRules,
12 VFSHandle,
11 VFSHandle,
13 makeVFSHandle,
12 makeVFSHandle,
14− makeLSPVFSHandle
13+ makeLSPVFSHandle,
14+ getSourceFingerprint
15 ) where
15 ) where
16
16
17+import Foreign.Ptr
18+import Foreign.ForeignPtr
19+import Fingerprint
20+import StringBuffer
17import Development.IDE.GHC.Orphans()
21import Development.IDE.GHC.Orphans()
18−import Development.IDE.Core.Shake
22+import Development.IDE.GHC.Util
23+
19import Control.Concurrent.Extra
24import Control.Concurrent.Extra
20import qualified Data.Map.Strict as Map
25import qualified Data.Map.Strict as Map
21import Data.Maybe
26import Data.Maybe
22import qualified Data.Text as T
27import qualified Data.Text as T
23import Control.Monad.Extra
28import Control.Monad.Extra
29+import qualified System.Directory as Dir
24import Development.Shake
30import Development.Shake
25import Development.Shake.Classes
31import Development.Shake.Classes
32+import Development.IDE.Core.Shake
26import Control.Exception
33import Control.Exception
27import GHC.Generics
34import GHC.Generics
28import Data.Either.Extra
35import Data.Either.Extra
@@ -34,9 +41,7 @@ import qualified Data.Rope.UTF16 as Rope
34
41
35#ifdef mingw32_HOST_OS
42#ifdef mingw32_HOST_OS
36import Data.Time
43import Data.Time
37−import qualified System.Directory as Dir
38#else
44#else
39−import Foreign.Ptr
40import Foreign.C.String
45import Foreign.C.String
41import Foreign.C.Types
46import Foreign.C.Types
42import Foreign.Marshal (alloca)
47import Foreign.Marshal (alloca)
@@ -71,8 +76,7 @@ makeVFSHandle = do
71 modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $
76 modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $
72 case content of
77 case content of
73 Nothing -> Map.delete uri vfs
78 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.
75− Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) vfs
79+ Just content -> Map.insert uri (VirtualFile nextVersion (Rope.fromText content)) vfs
76 }
80 }
77
81
78makeLSPVFSHandle :: LspFuncs c -> VFSHandle
82makeLSPVFSHandle :: LspFuncs c -> VFSHandle
@@ -83,7 +87,18 @@ makeLSPVFSHandle lspFuncs = VFSHandle
83
87
84
88
85-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
89-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
86−type instance RuleResult GetFileContents = (FileVersion, Maybe T.Text)
90+type instance RuleResult GetFileContents = (FileVersion, Maybe StringBuffer)
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
87
102
88data GetFileContents = GetFileContents
103data GetFileContents = GetFileContents
89 deriving (Eq, Show, Generic)
104 deriving (Eq, Show, Generic)
@@ -91,16 +106,40 @@ instance Hashable GetFileContents
91instance NFData GetFileContents
106instance NFData GetFileContents
92instance Binary GetFileContents
107instance Binary GetFileContents
93
108
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+
94getModificationTimeRule :: VFSHandle -> Rules ()
134getModificationTimeRule :: VFSHandle -> Rules ()
95getModificationTimeRule vfs =
135getModificationTimeRule vfs =
96 defineEarlyCutoff $ \GetModificationTime file -> do
136 defineEarlyCutoff $ \GetModificationTime file -> do
97 let file' = fromNormalizedFilePath file
137 let file' = fromNormalizedFilePath file
98− let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s))
138+ let wrap time = (Just time, ([], Just $ ModificationTime time))
99 alwaysRerun
139 alwaysRerun
100 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
140 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
101 case mbVirtual of
141 case mbVirtual of
102− Just (virtualFileVersion -> ver) ->
103− pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
142+ Just (VirtualFile ver _) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
104 Nothing -> liftIO $ fmap wrap (getModTime file')
143 Nothing -> liftIO $ fmap wrap (getModTime file')
105 `catch` \(e :: IOException) -> do
144 `catch` \(e :: IOException) -> do
106 let err | isDoesNotExistError e = "File does not exist: " ++ file'
145 let err | isDoesNotExistError e = "File does not exist: " ++ file'
@@ -114,15 +153,11 @@ getModificationTimeRule vfs =
114 -- time spent checking file modifications (which happens on every change)
153 -- time spent checking file modifications (which happens on every change)
115 -- from > 0.5s to ~0.15s.
154 -- from > 0.5s to ~0.15s.
116 -- We might also want to try speeding this up on Windows at some point.
155 -- 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
119− getModTime :: FilePath -> IO (Int,Int)
156+ getModTime :: FilePath -> IO BS.ByteString
120 getModTime f =
157 getModTime f =
121#ifdef mingw32_HOST_OS
158#ifdef mingw32_HOST_OS
122 do time <- Dir.getModificationTime f
159 do time <- Dir.getModificationTime f
123− let !day = fromInteger $ toModifiedJulianDay $ utctDay time
124− !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time
160+ pure $! BS.pack $ show (toModifiedJulianDay $ utctDay time, diffTimeToPicoseconds $ utctDayTime time)
125− pure (day, dayTime)
126#else
161#else
127 withCString f $ \f' ->
162 withCString f $ \f' ->
128 alloca $ \secPtr ->
163 alloca $ \secPtr ->
@@ -130,13 +165,16 @@ getModificationTimeRule vfs =
130 Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr
165 Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr
131 sec <- peek secPtr
166 sec <- peek secPtr
132 nsec <- peek nsecPtr
167 nsec <- peek nsecPtr
133− pure (fromEnum sec, fromIntegral nsec)
168+ pure $! BS.pack $ show sec <> "." <> show nsec
134
169
135-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow
170-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow
136-- as doing the FFI call ourselves :(.
171-- as doing the FFI call ourselves :(.
137foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int
172foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int
138#endif
173#endif
139
174
175+getSourceFingerprint :: NormalizedFilePath -> Action Fingerprint
176+getSourceFingerprint = use_ FingerprintSource
177+
140getFileContentsRule :: VFSHandle -> Rules ()
178getFileContentsRule :: VFSHandle -> Rules ()
141getFileContentsRule vfs =
179getFileContentsRule vfs =
142 define $ \GetFileContents file -> do
180 define $ \GetFileContents file -> do
@@ -144,7 +182,7 @@ getFileContentsRule vfs =
144 time <- use_ GetModificationTime file
182 time <- use_ GetModificationTime file
145 res <- liftIO $ ideTryIOException file $ do
183 res <- liftIO $ ideTryIOException file $ do
146 mbVirtual <- getVirtualFile vfs $ filePathToUri' file
184 mbVirtual <- getVirtualFile vfs $ filePathToUri' file
147− pure $ Rope.toText . _text <$> mbVirtual
185+ pure $ textToStringBuffer . Rope.toText . _text <$> mbVirtual
148 case res of
186 case res of
149 Left err -> return ([err], Nothing)
187 Left err -> return ([err], Nothing)
150 Right contents -> return ([], Just (time, contents))
188 Right contents -> return ([], Just (time, contents))
@@ -156,14 +194,24 @@ ideTryIOException fp act =
156 <$> try act
194 <$> try act
157
195
158
196
159−getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe T.Text)
197+getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe StringBuffer)
160getFileContents = use_ GetFileContents
198getFileContents = use_ GetFileContents
161
199
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+
162fileStoreRules :: VFSHandle -> Rules ()
208fileStoreRules :: VFSHandle -> Rules ()
163fileStoreRules vfs = do
209fileStoreRules vfs = do
164 addIdeGlobal vfs
210 addIdeGlobal vfs
165 getModificationTimeRule vfs
211 getModificationTimeRule vfs
166 getFileContentsRule vfs
212 getFileContentsRule vfs
213+ getFileExistsRule vfs
214+ fingerprintSourceRule
167
215
168
216
169-- | Notify the compiler service that a particular file has been modified.
217-- | Notify the compiler service that a particular file has been modified.
src/Development/IDE/Core/IdeConfiguration.hsdeleted−71
@@ -1,71 +0,0 @@
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,17 +1,19 @@
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+
4−{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
6
7
7−-- | Utilities and state for the files of interest - those which are currently
8+-- | A Shake implementation of the compiler service, built
8−-- open in the editor. The useful function is 'getFilesOfInterest'.
9+-- using the "Shaker" abstraction layer for in-memory use.
10+--
9module Development.IDE.Core.OfInterest(
11module Development.IDE.Core.OfInterest(
10 ofInterestRules,
12 ofInterestRules,
11 getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,
13 getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,
12 ) where
14 ) where
13
15
14−import Control.Concurrent.Extra
16+import Control.Concurrent.Extra
15import Data.Binary
17import Data.Binary
16import Data.Hashable
18import Data.Hashable
17import Control.DeepSeq
19import Control.DeepSeq
@@ -19,22 +21,25 @@ import GHC.Generics
19import Data.Typeable
21import Data.Typeable
20import qualified Data.ByteString.UTF8 as BS
22import qualified Data.ByteString.UTF8 as BS
21import Control.Exception
23import Control.Exception
22−import Data.HashSet (HashSet)
24+import Development.IDE.Types.Location
25+import Development.IDE.Types.Logger
26+import Data.Set (Set)
23−import qualified Data.HashSet as HashSet
27+import qualified Data.Set as Set
24import qualified Data.Text as T
28import qualified Data.Text as T
25import Data.Tuple.Extra
29import Data.Tuple.Extra
26import Data.Functor
30import Data.Functor
27−import Development.Shake
31+import Development.Shake
32+
33+import Development.IDE.Core.Shake
28
34
29−import Development.IDE.Types.Location
30−import Development.IDE.Types.Logger
31−import Development.IDE.Core.Shake
32
35
33
36
34−newtype OfInterestVar = OfInterestVar (Var (HashSet NormalizedFilePath))
37+newtype OfInterestVar = OfInterestVar (Var (Set NormalizedFilePath))
35instance IsIdeGlobal OfInterestVar
38instance IsIdeGlobal OfInterestVar
36
39
40+
37−type instance RuleResult GetFilesOfInterest = HashSet NormalizedFilePath
41+type instance RuleResult GetFilesOfInterest = Set NormalizedFilePath
42+
38
43
39data GetFilesOfInterest = GetFilesOfInterest
44data GetFilesOfInterest = GetFilesOfInterest
40 deriving (Eq, Show, Typeable, Generic)
45 deriving (Eq, Show, Typeable, Generic)
@@ -43,18 +48,16 @@ instance NFData GetFilesOfInterest
43instance Binary GetFilesOfInterest
48instance Binary GetFilesOfInterest
44
49
45
50
46−-- | The rule that initialises the files of interest state.
47ofInterestRules :: Rules ()
51ofInterestRules :: Rules ()
48ofInterestRules = do
52ofInterestRules = do
49− addIdeGlobal . OfInterestVar =<< liftIO (newVar HashSet.empty)
53+ addIdeGlobal . OfInterestVar =<< liftIO (newVar Set.empty)
50 defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do
54 defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do
51 alwaysRerun
55 alwaysRerun
52 filesOfInterest <- getFilesOfInterestUntracked
56 filesOfInterest <- getFilesOfInterestUntracked
53 pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest))
57 pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest))
54
58
55
59
56−-- | Get the files that are open in the IDE.
57−getFilesOfInterest :: Action (HashSet NormalizedFilePath)
60+getFilesOfInterest :: Action (Set NormalizedFilePath)
58getFilesOfInterest = useNoFile_ GetFilesOfInterest
61getFilesOfInterest = useNoFile_ GetFilesOfInterest
59
62
60
63
@@ -62,21 +65,18 @@ getFilesOfInterest = useNoFile_ GetFilesOfInterest
62------------------------------------------------------------
65------------------------------------------------------------
63-- Exposed API
66-- Exposed API
64
67
65−-- | Set the files-of-interest - not usually necessary or advisable.
68+-- | Set the files-of-interest which will be built and kept-up-to-date.
66−-- The LSP client will keep this information up to date.
67−setFilesOfInterest :: IdeState -> HashSet NormalizedFilePath -> IO ()
69+setFilesOfInterest :: IdeState -> Set NormalizedFilePath -> IO ()
68setFilesOfInterest state files = modifyFilesOfInterest state (const files)
70setFilesOfInterest state files = modifyFilesOfInterest state (const files)
69
71
70−getFilesOfInterestUntracked :: Action (HashSet NormalizedFilePath)
72+getFilesOfInterestUntracked :: Action (Set NormalizedFilePath)
71getFilesOfInterestUntracked = do
73getFilesOfInterestUntracked = do
72 OfInterestVar var <- getIdeGlobalAction
74 OfInterestVar var <- getIdeGlobalAction
73 liftIO $ readVar var
75 liftIO $ readVar var
74
76
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 -> (HashSet NormalizedFilePath -> HashSet NormalizedFilePath) -> IO ()
77+modifyFilesOfInterest :: IdeState -> (Set NormalizedFilePath -> Set 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 $ HashSet.toList files)
81+ logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ Set.toList files)
82 void $ shakeRun state []
82 void $ shakeRun state []
src/Development/IDE/Core/PositionMapping.hs+10−48
@@ -2,15 +2,10 @@
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
10 , toCurrentRange
5 , toCurrentRange
11 , fromCurrentRange
6 , fromCurrentRange
12 , applyChange
7 , applyChange
13− , zeroMapping
8+ , idMapping
14 -- toCurrent and fromCurrent are mainly exposed for testing
9 -- toCurrent and fromCurrent are mainly exposed for testing
15 , toCurrent
10 , toCurrent
16 , fromCurrent
11 , fromCurrent
@@ -19,25 +14,12 @@ module Development.IDE.Core.PositionMapping
19import Control.Monad
14import Control.Monad
20import qualified Data.Text as T
15import qualified Data.Text as T
21import Language.Haskell.LSP.Types
16import Language.Haskell.LSP.Types
22−import Data.List
23
17
24−-- The position delta is the difference between two versions
18+data PositionMapping = PositionMapping
25−data PositionDelta = PositionDelta
26− { toDelta :: !(Position -> Maybe Position)
19+ { toCurrentPosition :: !(Position -> Maybe Position)
27− , fromDelta :: !(Position -> Maybe Position)
20+ , fromCurrentPosition :: !(Position -> Maybe Position)
28 }
21 }
29
22
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−
41toCurrentRange :: PositionMapping -> Range -> Maybe Range
23toCurrentRange :: PositionMapping -> Range -> Maybe Range
42toCurrentRange mapping (Range a b) =
24toCurrentRange mapping (Range a b) =
43 Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b
25 Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b
@@ -46,33 +28,13 @@ fromCurrentRange :: PositionMapping -> Range -> Maybe Range
46fromCurrentRange mapping (Range a b) =
28fromCurrentRange mapping (Range a b) =
47 Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b
29 Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b
48
30
49−zeroMapping :: PositionMapping
31+idMapping :: PositionMapping
50−zeroMapping = PositionMapping idDelta
32+idMapping = PositionMapping Just Just
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)
71
33
72−applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta
34+applyChange :: PositionMapping -> TextDocumentContentChangeEvent -> PositionMapping
73−applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta
35+applyChange posMapping (TextDocumentContentChangeEvent (Just r) _ t) = PositionMapping
74− { toDelta = toCurrent r t <=< toDelta
36+ { toCurrentPosition = toCurrent r t <=< toCurrentPosition posMapping
75− , fromDelta = fromDelta <=< fromCurrent r t
37+ , fromCurrentPosition = fromCurrentPosition posMapping <=< fromCurrent r t
76 }
38 }
77applyChange posMapping _ = posMapping
39applyChange posMapping _ = posMapping
78
40
src/Development/IDE/Core/Preprocessor.hs+8−104
@@ -8,6 +8,7 @@ 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
11import GhcMonad
12import GhcMonad
12import StringBuffer as SB
13import StringBuffer as SB
13
14
@@ -18,26 +19,16 @@ import Data.Char
18import DynFlags
19import DynFlags
19import qualified HeaderInfo as Hdr
20import qualified HeaderInfo as Hdr
20import Development.IDE.Types.Diagnostics
21import 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, runPp)
23+import SysTools (Option (..), runUnlit)
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)
36
27
37
28
38-- | Given a file and some contents, apply any necessary preprocessors,
29-- | Given a file and some contents, apply any necessary preprocessors,
39-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.
30-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.
40−preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)
31+preprocessor :: GhcMonad m => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)
41preprocessor filename mbContents = do
32preprocessor filename mbContents = do
42 -- Perform unlit
33 -- Perform unlit
43 (isOnDisk, contents) <-
34 (isOnDisk, contents) <-
@@ -52,79 +43,12 @@ preprocessor filename mbContents = do
52
43
53 -- Perform cpp
44 -- Perform cpp
54 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
45 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
55− (isOnDisk, contents, dflags) <-
56− if not $ xopt LangExt.Cpp dflags then
46+ 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
76 return (contents, dflags)
47 return (contents, dflags)
77 else do
48 else do
78− contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents
49+ contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents
79 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
50 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents
80 return (contents, dflags)
51 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− }
128
52
129
53
130isLiterate :: FilePath -> Bool
54isLiterate :: FilePath -> Bool
@@ -133,17 +57,13 @@ isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]
133
57
134-- | This reads the pragma information directly from the provided buffer.
58-- | This reads the pragma information directly from the provided buffer.
135parsePragmasIntoDynFlags
59parsePragmasIntoDynFlags
136− :: (ExceptionMonad m, HasDynFlags m, MonadIO m)
60+ :: GhcMonad m
137 => FilePath
61 => FilePath
138 -> SB.StringBuffer
62 -> SB.StringBuffer
139 -> m (Either [FileDiagnostic] DynFlags)
63 -> m (Either [FileDiagnostic] DynFlags)
140parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do
64parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do
141− dflags0 <- getDynFlags
65+ dflags0 <- getSessionDynFlags
142 let opts = Hdr.getOptions dflags0 contents fp
66 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−
147 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
67 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
148 return dflags
68 return dflags
149
69
@@ -175,12 +95,11 @@ runLhs dflags filename contents = withTempDir $ \dir -> do
175 escape (c:cs) = c : escape cs
95 escape (c:cs) = c : escape cs
176 escape [] = []
96 escape [] = []
177
97
98+
178-- | Run CPP on a file
99-- | Run CPP on a file
179runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
100runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
180runCpp dflags filename contents = withTempDir $ \dir -> do
101runCpp dflags filename contents = withTempDir $ \dir -> do
181 let out = dir </> takeFileName filename <.> "out"
102 let out = dir </> takeFileName filename <.> "out"
182− dflags <- pure $ addOptP "-D__GHCIDE__" dflags
183−
184 case contents of
103 case contents of
185 Nothing -> do
104 Nothing -> do
186 -- Happy case, file is not modified, so run CPP on it in-place
105 -- Happy case, file is not modified, so run CPP on it in-place
@@ -213,18 +132,3 @@ runCpp dflags filename contents = withTempDir $ \dir -> do
213 = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""
132 = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""
214 | otherwise = x
133 | otherwise = x
215 stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out
134 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+12−51
@@ -15,6 +15,7 @@ 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
18import Data.Hashable
19import Data.Hashable
19import Data.Typeable
20import Data.Typeable
20import qualified Data.Set as S
21import qualified Data.Set as S
@@ -24,9 +25,9 @@ import GHC.Generics (Generic)
24import GHC
25import GHC
25import Module (InstalledUnitId)
26import Module (InstalledUnitId)
26import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)
27import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)
28+import Development.IDE.GHC.Compat
27
29
28import Development.IDE.Spans.Type
30import Development.IDE.Spans.Type
29−import Development.IDE.Import.FindImports (ArtifactsLocation)
30
31
31
32
32-- NOTATION
33-- NOTATION
@@ -57,27 +58,11 @@ instance Show TcModuleResult where
57instance NFData TcModuleResult where
58instance NFData TcModuleResult where
58 rnf = rwhnf
59 rnf = rwhnf
59
60
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−
76-- | The type checked version of this file, requires TypeCheck+
61-- | The type checked version of this file, requires TypeCheck+
77type instance RuleResult TypeCheck = TcModuleResult
62type instance RuleResult TypeCheck = TcModuleResult
78
63
79-- | Information about what spans occur where, requires TypeCheck
64-- | Information about what spans occur where, requires TypeCheck
80−type instance RuleResult GetSpanInfo = SpansInfo
65+type instance RuleResult GetSpanInfo = [SpanInfo]
81
66
82-- | Convert to Core, requires TypeCheck*
67-- | Convert to Core, requires TypeCheck*
83type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)
68type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)
@@ -90,24 +75,16 @@ type instance RuleResult GhcSession = HscEnvEq
90
75
91-- | Resolve the imports in a module to the file path of a module
76-- | Resolve the imports in a module to the file path of a module
92-- in the same package or the package id of another package.
77-- in the same package or the package id of another package.
93−type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId)
78+type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe NormalizedFilePath)], S.Set InstalledUnitId)
94
79
95-- | This rule is used to report import cycles. It depends on GetDependencyInformation.
80-- | This rule is used to report import cycles. It depends on GetDependencyInformation.
96-- We cannot report the cycles directly from GetDependencyInformation since
81-- We cannot report the cycles directly from GetDependencyInformation since
97-- we can only report diagnostics for the current file.
82-- we can only report diagnostics for the current file.
98type instance RuleResult ReportImportCycles = ()
83type instance RuleResult ReportImportCycles = ()
99
84
100−-- | Read the module interface file
85+-- | Read the given HIE file.
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
86+type instance RuleResult GetHieFile = HieFile
105
87
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
111
88
112data GetParsedModule = GetParsedModule
89data GetParsedModule = GetParsedModule
113 deriving (Eq, Show, Typeable, Generic)
90 deriving (Eq, Show, Typeable, Generic)
@@ -169,26 +146,10 @@ instance Hashable GhcSession
169instance NFData GhcSession
146instance NFData GhcSession
170instance Binary GhcSession
147instance Binary GhcSession
171
148
172−data GetHiFile = GetHiFile
149+-- Note that we embed the filepath here instead of using the filepath associated with Shake keys.
173− deriving (Eq, Show, Typeable, Generic)
150+-- Otherwise we will garbage collect the result since files in package dependencies will not be declared reachable.
174−instance Hashable GetHiFile
151+data GetHieFile = GetHieFile FilePath
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
191 deriving (Eq, Show, Typeable, Generic)
152 deriving (Eq, Show, Typeable, Generic)
192−instance Hashable GetModSummary
153+instance Hashable GetHieFile
193−instance NFData GetModSummary
154+instance NFData GetHieFile
194−instance Binary GetModSummary
155+instance Binary GetHieFile
src/Development/IDE/Core/Rules.hs+123−426
@@ -1,18 +1,16 @@
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−{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE TypeFamilies #-}
6−{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE DuplicateRecordFields #-}
6{-# LANGUAGE DuplicateRecordFields #-}
8−#include "ghc-api-version.h"
9
7
10-- | A Shake implementation of the compiler service, built
8-- | A Shake implementation of the compiler service, built
11-- using the "Shaker" abstraction layer for in-memory use.
9-- using the "Shaker" abstraction layer for in-memory use.
12--
10--
13module Development.IDE.Core.Rules(
11module Development.IDE.Core.Rules(
14 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
12 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
15− Priority(..), GhcSessionIO(..), GhcSessionFun(..),
13+ Priority(..),
16 priorityTypeCheck,
14 priorityTypeCheck,
17 priorityGenerateCore,
15 priorityGenerateCore,
18 priorityFilesOfInterest,
16 priorityFilesOfInterest,
@@ -23,59 +21,51 @@ module Development.IDE.Core.Rules(
23 getDefinition,
21 getDefinition,
24 getDependencies,
22 getDependencies,
25 getParsedModule,
23 getParsedModule,
24+ fileFromParsedModule,
26 generateCore,
25 generateCore,
27 ) where
26 ) where
28
27
29import Fingerprint
28import Fingerprint
30
29
31−import Data.Binary hiding (get, put)
30+import Data.Binary
32−import Data.Bifunctor (first, second)
33−import Control.Monad.Extra
31+import Control.Monad
34import Control.Monad.Trans.Class
32import Control.Monad.Trans.Class
35import Control.Monad.Trans.Maybe
33import Control.Monad.Trans.Maybe
36import Development.IDE.Core.Compile
34import Development.IDE.Core.Compile
37−import Development.IDE.Core.OfInterest
38import Development.IDE.Types.Options
35import Development.IDE.Types.Options
39import Development.IDE.Spans.Calculate
36import Development.IDE.Spans.Calculate
40import Development.IDE.Import.DependencyInformation
37import Development.IDE.Import.DependencyInformation
41import Development.IDE.Import.FindImports
38import Development.IDE.Import.FindImports
42−import Development.IDE.Core.FileExists
39+import Development.IDE.Core.FileStore
43−import Development.IDE.Core.FileStore (getFileContents)
44import Development.IDE.Types.Diagnostics
40import Development.IDE.Types.Diagnostics
45import Development.IDE.Types.Location
41import Development.IDE.Types.Location
46−import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)
47import Development.IDE.GHC.Util
42import Development.IDE.GHC.Util
48−import Development.IDE.GHC.WithDynFlags
43+import Data.Coerce
49import Data.Either.Extra
44import Data.Either.Extra
50import Data.Maybe
45import Data.Maybe
51import Data.Foldable
46import Data.Foldable
52import qualified Data.IntMap.Strict as IntMap
47import qualified Data.IntMap.Strict as IntMap
53−import Data.IntMap.Strict (IntMap)
48+import qualified Data.IntSet as IntSet
54import Data.List
49import Data.List
55−import Data.Ord
56import qualified Data.Set as Set
50import qualified Data.Set as Set
57import qualified Data.Text as T
51import qualified Data.Text as T
58import Development.IDE.GHC.Error
52import Development.IDE.GHC.Error
59import Development.Shake hiding (Diagnostic)
53import Development.Shake hiding (Diagnostic)
60import Development.IDE.Core.RuleTypes
54import Development.IDE.Core.RuleTypes
61−import Development.IDE.Spans.Type
62−import qualified Data.ByteString.Char8 as BS
63
55
56+import GHC hiding (parseModule, typecheckModule)
64import qualified GHC.LanguageExtensions as LangExt
57import qualified GHC.LanguageExtensions as LangExt
58+import Development.IDE.GHC.Compat
59+import UniqSupply
60+import NameCache
65import HscTypes
61import HscTypes
66−import PackageConfig
67−import DynFlags (gopt_set, xopt)
62+import DynFlags (xopt)
68import GHC.Generics(Generic)
63import GHC.Generics(Generic)
69
64
70import qualified Development.IDE.Spans.AtPoint as AtPoint
65import qualified Development.IDE.Spans.AtPoint as AtPoint
71import Development.IDE.Core.Service
66import Development.IDE.Core.Service
72import Development.IDE.Core.Shake
67import Development.IDE.Core.Shake
73−import Development.Shake.Classes hiding (get, put)
68+import Development.Shake.Classes
74−import Control.Monad.Trans.Except (runExceptT)
75−import Data.ByteString (ByteString)
76−import Control.Concurrent.Async (concurrently)
77−
78−import Control.Monad.State
79
69
80-- | This is useful for rules to convert rules that can only produce errors or
70-- | This is useful for rules to convert rules that can only produce errors or
81-- a result into the more general IdeResult type that supports producing
71-- a result into the more general IdeResult type that supports producing
@@ -89,14 +79,14 @@ useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v
89useE k = MaybeT . use k
79useE k = MaybeT . use k
90
80
91useNoFileE :: IdeRule k v => k -> MaybeT Action v
81useNoFileE :: IdeRule k v => k -> MaybeT Action v
92−useNoFileE k = useE k emptyFilePath
82+useNoFileE k = useE k ""
93
83
94usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
84usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
95usesE k = MaybeT . fmap sequence . uses k
85usesE k = MaybeT . fmap sequence . uses k
96
86
97defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
87defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
98defineNoFile f = define $ \k file -> do
88defineNoFile f = define $ \k file -> do
99− if file == emptyFilePath then do res <- f k; return ([], Just res) else
89+ if file == "" then do res <- f k; return ([], Just res) else
100 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
90 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
101
91
102
92
@@ -112,66 +102,19 @@ getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file
112getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text]))
102getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text]))
113getAtPoint file pos = fmap join $ runMaybeT $ do
103getAtPoint file pos = fmap join $ runMaybeT $ do
114 opts <- lift getIdeOptions
104 opts <- lift getIdeOptions
105+ files <- transitiveModuleDeps <$> useE GetDependencies file
106+ tms <- usesE TypeCheck (file : files)
115 spans <- useE GetSpanInfo file
107 spans <- useE GetSpanInfo file
116− return $ AtPoint.atPoint opts spans pos
108+ return $ AtPoint.atPoint opts (map tmrModule tms) spans pos
117
109
118-- | Goto Definition.
110-- | Goto Definition.
119getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
111getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
120getDefinition file pos = fmap join $ runMaybeT $ do
112getDefinition file pos = fmap join $ runMaybeT $ do
121− opts <- lift getIdeOptions
122 spans <- useE GetSpanInfo file
113 spans <- useE GetSpanInfo file
114+ pkgState <- hscEnv <$> useE GhcSession file
115+ opts <- lift getIdeOptions
116+ let getHieFile x = useNoFile (GetHieFile x)
123− lift $ AtPoint.gotoDefinition (getHieFile file) opts (spansExprs spans) pos
117+ lift $ AtPoint.gotoDefinition getHieFile opts pkgState 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
175
118
176-- | Parse the contents of a daml file.
119-- | Parse the contents of a daml file.
177getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
120getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
@@ -191,60 +134,26 @@ priorityFilesOfInterest :: Priority
191priorityFilesOfInterest = Priority (-2)
134priorityFilesOfInterest = Priority (-2)
192
135
193getParsedModuleRule :: Rules ()
136getParsedModuleRule :: Rules ()
137+getParsedModuleRule =
194−getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
138+ defineEarlyCutoff $ \GetParsedModule file -> do
139+ (_, contents) <- getFileContents file
195− sess <- use_ GhcSession file
140+ packageState <- hscEnv <$> 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)
200− opt <- getIdeOptions
141+ 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
227− (diag, res) <- parseModule opt packageState comp_pkgs (fromNormalizedFilePath file) (fmap textToStringBuffer contents)
142+ r <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents
228− case res of
143+ mbFingerprint <- traverse (const $ getSourceFingerprint file) (optShakeFiles opt)
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
234− pure (mbFingerprint, (diag, Just modu))
144+ pure (fingerprintToBS <$> mbFingerprint, r)
235
145
236getLocatedImportsRule :: Rules ()
146getLocatedImportsRule :: Rules ()
237getLocatedImportsRule =
147getLocatedImportsRule =
238 define $ \GetLocatedImports file -> do
148 define $ \GetLocatedImports file -> do
239− ms <- use_ GetModSummary file
149+ pm <- use_ GetParsedModule file
150+ let ms = pm_mod_summary pm
240 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
151 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
241− env_eq <- use_ GhcSession file
152+ env <- hscEnv <$> use_ GhcSession file
242− let env = hscEnv env_eq
243− let import_dirs = deps env_eq
244− let dflags = addRelativeImport file (moduleName $ ms_mod ms) $ hsc_dflags env
153+ let dflags = addRelativeImport file pm $ hsc_dflags env
245 opt <- getIdeOptions
154 opt <- getIdeOptions
246 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
155 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
247− diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getFileExists modName mbPkgName isSource
156+ diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource
248 case diagOrImp of
157 case diagOrImp of
249 Left diags -> pure (diags, Left (modName, Nothing))
158 Left diags -> pure (diags, Left (modName, Nothing))
250 Right (FileImport path) -> pure ([], Left (modName, Just path))
159 Right (FileImport path) -> pure ([], Left (modName, Just path))
@@ -258,109 +167,48 @@ getLocatedImportsRule =
258 Nothing -> pure (concat diags, Nothing)
167 Nothing -> pure (concat diags, Nothing)
259 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))
168 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))
260
169
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− )
269
170
270-- | Given a target file path, construct the raw dependency results by following
171-- | Given a target file path, construct the raw dependency results by following
271-- imports recursively.
172-- imports recursively.
272−rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation
173+rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation
273−rawDependencyInformation fs = do
174+rawDependencyInformation f = do
274− (rdi, ss) <- execRawDepM (mapM_ go fs)
175+ let (initialId, initialMap) = getPathId f emptyPathIdMap
275− let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss
176+ go (IntSet.singleton $ getFilePathId initialId)
276− return (rdi { rawBootMap = bm })
177+ (RawDependencyInformation IntMap.empty initialMap)
277 where
178 where
278− go :: NormalizedFilePath -- ^ Current module being processed
179+ go fs rawDepInfo =
279− -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId
180+ case IntSet.minView fs of
280− go f = do
181+ -- Queue is empty
281− -- First check to see if we have already processed the FilePath
182+ Nothing -> pure rawDepInfo
282− -- If we have, just return its Id but don't update any of the state.
183+ -- Pop f from the queue and process it
283− -- Otherwise, we need to process its imports.
184+ Just (f, fs) -> do
284− checkAlreadyProcessed f $ do
185+ let fId = FilePathId f
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
292− importsOrErr <- lift $ use GetLocatedImports f
186+ importsOrErr <- use GetLocatedImports $ idToPath (rawPathIdMap rawDepInfo) fId
293− case importsOrErr of
187+ case importsOrErr of
294− Nothing -> do
188+ Nothing ->
295− -- File doesn't parse so add the module as a failure into the
189+ -- File doesn’t parse
296− -- dependency information, continue processing the other
297− -- elements in the queue
298− modifyRawDepInfo (insertImport fId (Left ModuleParseError))
190+ let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo
299− return fId
191+ in go fs rawDepInfo'
300− Just (modImports, pkgImports) -> do
192+ Just (modImports, pkgImports) -> do
301− -- Get NFPs of the imports which have corresponding files
193+ let f :: PathIdMap -> (a, Maybe NormalizedFilePath) -> (PathIdMap, (a, Maybe FilePathId))
302− -- Imports either come locally from a file or from a package.
194+ f pathMap (imp, mbPath) = case mbPath of
303− let (no_file, with_file) = splitImports modImports
195+ Nothing -> (pathMap, (imp, Nothing))
304− (mns, ls) = unzip with_file
196+ Just path ->
305− -- Recursively process all the imports we just learnt about
197+ let (pathId, pathMap') = getPathId path pathMap
306− -- and get back a list of their FilePathIds
198+ in (pathMap', (imp, Just pathId))
307− fids <- mapM (go . artifactFilePath) ls
199+ -- Convert paths in imports to ids and update the path map
308− -- Associate together the ModuleName with the FilePathId
200+ let (pathIdMap, modImports') = mapAccumL f (rawPathIdMap rawDepInfo) modImports
309− let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids)
201+ -- Files that we haven’t seen before are added to the queue.
310− -- Insert into the map the information about this modules
202+ let newFiles =
311− -- imports.
203+ IntSet.fromList (coerce $ mapMaybe snd modImports')
204+ IntSet.\\ IntMap.keysSet (rawImports rawDepInfo)
312− modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports' pkgImports)
205+ let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo
313− return fId
206+ go (newFiles `IntSet.union` fs) (rawDepInfo' { rawPathIdMap = pathIdMap })
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"
359
207
360getDependencyInformationRule :: Rules ()
208getDependencyInformationRule :: Rules ()
361getDependencyInformationRule =
209getDependencyInformationRule =
362 define $ \GetDependencyInformation file -> do
210 define $ \GetDependencyInformation file -> do
363− rawDepInfo <- rawDependencyInformation [file]
211+ rawDepInfo <- rawDependencyInformation file
364 pure ([], Just $ processDependencyInformation rawDepInfo)
212 pure ([], Just $ processDependencyInformation rawDepInfo)
365
213
366reportImportCyclesRule :: Rules ()
214reportImportCyclesRule :: Rules ()
@@ -381,20 +229,19 @@ reportImportCyclesRule =
381 where cycleErrorInFile f (PartOfCycle imp fs)
229 where cycleErrorInFile f (PartOfCycle imp fs)
382 | f `elem` fs = Just (imp, fs)
230 | f `elem` fs = Just (imp, fs)
383 cycleErrorInFile _ _ = Nothing
231 cycleErrorInFile _ _ = Nothing
384− toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic
232+ toDiag imp mods = (fp ,) $ Diagnostic
385 { _range = (_range :: Location -> Range) loc
233 { _range = (_range :: Location -> Range) loc
386 , _severity = Just DsError
234 , _severity = Just DsError
387 , _source = Just "Import cycle detection"
235 , _source = Just "Import cycle detection"
388 , _message = "Cyclic module dependency between " <> showCycle mods
236 , _message = "Cyclic module dependency between " <> showCycle mods
389 , _code = Nothing
237 , _code = Nothing
390 , _relatedInformation = Nothing
238 , _relatedInformation = Nothing
391− , _tags = Nothing
392 }
239 }
393 where loc = srcSpanToLocation (getLoc imp)
240 where loc = srcSpanToLocation (getLoc imp)
394− fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp)
241+ fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)
395 getModuleName file = do
242 getModuleName file = do
396− ms <- use_ GetModSummary file
243+ pm <- use_ GetParsedModule file
397− pure (moduleNameString . moduleName . ms_mod $ ms)
244+ pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)
398 showCycle mods = T.intercalate ", " (map T.pack mods)
245 showCycle mods = T.intercalate ", " (map T.pack mods)
399
246
400-- returns all transitive dependencies in topological order.
247-- returns all transitive dependencies in topological order.
@@ -402,7 +249,7 @@ reportImportCyclesRule =
402getDependenciesRule :: Rules ()
249getDependenciesRule :: Rules ()
403getDependenciesRule =
250getDependenciesRule =
404 defineEarlyCutoff $ \GetDependencies file -> do
251 defineEarlyCutoff $ \GetDependencies file -> do
405− depInfo <- use_ GetDependencyInformation file
252+ depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file
406 let allFiles = reachableModules depInfo
253 let allFiles = reachableModules depInfo
407 _ <- uses_ ReportImportCycles allFiles
254 _ <- uses_ ReportImportCycles allFiles
408 opts <- getIdeOptions
255 opts <- getIdeOptions
@@ -414,101 +261,48 @@ getSpanInfoRule :: Rules ()
414getSpanInfoRule =
261getSpanInfoRule =
415 define $ \GetSpanInfo file -> do
262 define $ \GetSpanInfo file -> do
416 tc <- use_ TypeCheck file
263 tc <- use_ TypeCheck 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
264 (fileImports, _) <- use_ GetLocatedImports file
431− let imports = second (fmap artifactFilePath) <$> fileImports
265+ packageState <- hscEnv <$> use_ GhcSession file
432− x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps (map hirModIface ifaces)
266+ x <- liftIO $ getSrcSpanInfos packageState fileImports tc
433 return ([], Just x)
267 return ([], Just x)
434
268
435-- Typechecks a module.
269-- Typechecks a module.
436typeCheckRule :: Rules ()
270typeCheckRule :: Rules ()
271+typeCheckRule =
437−typeCheckRule = define $ \TypeCheck file -> do
272+ define $ \TypeCheck file -> do
438− pm <- use_ GetParsedModule file
273+ 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
458− deps <- use_ GetDependencies file
274+ deps <- use_ GetDependencies file
459− hsc <- hscEnv <$> use_ GhcSession file
275+ packageState <- hscEnv <$> use_ GhcSession file
460− -- Figure out whether we need TemplateHaskell or QuasiQuotes support
276+ -- Figure out whether we need TemplateHaskell or QuasiQuotes support
461− let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc
277+ let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph packageState
462− file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)
278+ file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)
463− any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq
279+ any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq
464− mirs <- uses_ GetModIface (transitiveModuleDeps deps)
465− bytecodes <- if any_uses_th_qq
280+ tms <- if any_uses_th_qq
466− then -- If we use TH or QQ, we must obtain the bytecode
281+ -- If we use TH or QQ, we must obtain the bytecode
282+ then do
467− fmap Just <$> uses_ GenerateByteCode (transitiveModuleDeps deps)
283+ bytecodes <- uses_ GenerateByteCode (transitiveModuleDeps deps)
468− else
284+ tmrs <- uses_ TypeCheck (transitiveModuleDeps deps)
469− pure $ repeat Nothing
285+ pure (zipWith addByteCode bytecodes tmrs)
470−
286+ else uses_ TypeCheck (transitiveModuleDeps deps)
471− setPriority priorityTypeCheck
287+ setPriority priorityTypeCheck
472− IdeOptions { optDefer = defer } <- getIdeOptions
288+ IdeOptions{ optDefer = defer} <- getIdeOptions
473−
474− addUsageDependencies $ liftIO $ do
475− res <- typecheckModule defer hsc (zipWith unpack mirs bytecodes) pm
289+ liftIO $ typecheckModule defer packageState tms 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)
483− where
290+ where
484− unpack HiFileResult{..} bc = (hirModSummary, (hirModIface, bc))
485− uses_th_qq dflags =
486− xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
291+ uses_th_qq dflags = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
487−
488− addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)
292+ addByteCode :: Linkable -> TcModuleResult -> TcModuleResult
489− addUsageDependencies a = do
293+ addByteCode lm tmr = tmr { tmrModInfo = (tmrModInfo tmr) { hm_linkable = Just lm } }
490− r@(_, mtc) <- a
294+
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−
501−generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
295+generateCore :: NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
502−generateCore runSimplifier file = do
296+generateCore file = do
503 deps <- use_ GetDependencies file
297 deps <- use_ GetDependencies file
504 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
298 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
505 setPriority priorityGenerateCore
299 setPriority priorityGenerateCore
506 packageState <- hscEnv <$> use_ GhcSession file
300 packageState <- hscEnv <$> use_ GhcSession file
507− liftIO $ compileModule runSimplifier packageState [(tmrModSummary x, tmrModInfo x) | x <- tms] tm
301+ liftIO $ compileModule packageState tms tm
508
302
509generateCoreRule :: Rules ()
303generateCoreRule :: Rules ()
510generateCoreRule =
304generateCoreRule =
511− define $ \GenerateCore -> generateCore (RunSimplifier True)
305+ define $ \GenerateCore -> generateCore
512
306
513generateByteCodeRule :: Rules ()
307generateByteCodeRule :: Rules ()
514generateByteCodeRule =
308generateByteCodeRule =
@@ -517,7 +311,7 @@ generateByteCodeRule =
517 (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)
311 (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)
518 session <- hscEnv <$> use_ GhcSession file
312 session <- hscEnv <$> use_ GhcSession file
519 (_, guts, _) <- use_ GenerateCore file
313 (_, guts, _) <- use_ GenerateCore file
520− liftIO $ generateByteCode session [(tmrModSummary x, tmrModInfo x) | x <- tms] tm guts
314+ liftIO $ generateByteCode session tms tm guts
521
315
522-- A local rule type to get caching. We want to use newCache, but it has
316-- A local rule type to get caching. We want to use newCache, but it has
523-- thread killed exception issues, so we lift it to a full rule.
317-- thread killed exception issues, so we lift it to a full rule.
@@ -529,7 +323,7 @@ instance Hashable GhcSessionIO
529instance NFData GhcSessionIO
323instance NFData GhcSessionIO
530instance Binary GhcSessionIO
324instance Binary GhcSessionIO
531
325
532−newtype GhcSessionFun = GhcSessionFun (FilePath -> Action (IdeResult HscEnvEq))
326+newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq)
533instance Show GhcSessionFun where show _ = "GhcSessionFun"
327instance Show GhcSessionFun where show _ = "GhcSessionFun"
534instance NFData GhcSessionFun where rnf !_ = ()
328instance NFData GhcSessionFun where rnf !_ = ()
535
329
@@ -538,119 +332,20 @@ loadGhcSession :: Rules ()
538loadGhcSession = do
332loadGhcSession = do
539 defineNoFile $ \GhcSessionIO -> do
333 defineNoFile $ \GhcSessionIO -> do
540 opts <- getIdeOptions
334 opts <- getIdeOptions
541− GhcSessionFun <$> optGhcSession opts
335+ liftIO $ 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
546 defineEarlyCutoff $ \GhcSession file -> do
336 defineEarlyCutoff $ \GhcSession file -> do
547 GhcSessionFun fun <- useNoFile_ GhcSessionIO
337 GhcSessionFun fun <- useNoFile_ GhcSessionIO
548− alwaysRerun
549 val <- fun $ fromNormalizedFilePath file
338 val <- fun $ fromNormalizedFilePath file
550−
551− -- TODO: What was this doing before?
552 opts <- getIdeOptions
339 opts <- getIdeOptions
553− let cutoffHash =
554− case optShakeFiles opts of
340+ return ("" <$ optShakeFiles opts, ([], Just val))
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)
648
341
649−isFileOfInterestRule :: Rules ()
342+
650−isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do
343+getHieFileRule :: Rules ()
651− filesOfInterest <- getFilesOfInterest
344+getHieFileRule =
652− let res = f `elem` filesOfInterest
345+ defineNoFile $ \(GetHieFile f) -> do
653− return (Just (if res then "1" else ""), ([], Just res))
346+ u <- liftIO $ mkSplitUniqSupply 'a'
347+ let nameCache = initNameCache u []
348+ liftIO $ fmap (hie_file_result . fst) $ readHieFile nameCache f
654
349
655-- | A rule that wires per-file rules together
350-- | A rule that wires per-file rules together
656mainRule :: Rules ()
351mainRule :: Rules ()
@@ -665,7 +360,9 @@ mainRule = do
665 generateCoreRule
360 generateCoreRule
666 generateByteCodeRule
361 generateByteCodeRule
667 loadGhcSession
362 loadGhcSession
668− getHiFileRule
363+ getHieFileRule
669− getModIfaceRule
364+
670− isFileOfInterestRule
365+------------------------------------------------------------
671− getModSummaryRule
366+
367+fileFromParsedModule :: ParsedModule -> NormalizedFilePath
368+fileFromParsedModule = toNormalizedFilePath . ms_hspp_file . pm_mod_summary
src/Development/IDE/Core/Service.hs+3−10
@@ -23,16 +23,13 @@ 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
27−import Development.IDE.Core.FileStore (VFSHandle, fileStoreRules)
26+import Development.IDE.Core.FileStore
28−import Development.IDE.Core.FileExists (fileExistsRules)
29import Development.IDE.Core.OfInterest
27import Development.IDE.Core.OfInterest
30import Development.IDE.Types.Logger
28import Development.IDE.Types.Logger
31import Development.Shake
29import Development.Shake
32import Data.Either.Extra
30import Data.Either.Extra
33import qualified Language.Haskell.LSP.Messages as LSP
31import qualified Language.Haskell.LSP.Messages as LSP
34import qualified Language.Haskell.LSP.Types as LSP
32import qualified Language.Haskell.LSP.Types as LSP
35−import qualified Language.Haskell.LSP.Types.Capabilities as LSP
36
33
37import Development.IDE.Core.Shake
34import Development.IDE.Core.Shake
38
35
@@ -45,21 +42,18 @@ instance IsIdeGlobal GlobalIdeOptions
45-- Exposed API
42-- Exposed API
46
43
47-- | Initialise the Compiler Service.
44-- | Initialise the Compiler Service.
48−initialise :: LSP.ClientCapabilities
49− -> Rules ()
45+initialise :: Rules ()
50 -> IO LSP.LspId
46 -> IO LSP.LspId
51 -> (LSP.FromServerMessage -> IO ())
47 -> (LSP.FromServerMessage -> IO ())
52 -> Logger
48 -> Logger
53− -> Debouncer LSP.NormalizedUri
54 -> IdeOptions
49 -> IdeOptions
55 -> VFSHandle
50 -> VFSHandle
56 -> IO IdeState
51 -> IO IdeState
57−initialise caps mainRule getLspId toDiags logger debouncer options vfs =
52+initialise mainRule getLspId toDiags logger options vfs =
58 shakeOpen
53 shakeOpen
59 getLspId
54 getLspId
60 toDiags
55 toDiags
61 logger
56 logger
62− debouncer
63 (optShakeProfiling options)
57 (optShakeProfiling options)
64 (optReportProgress options)
58 (optReportProgress options)
65 shakeOptions
59 shakeOptions
@@ -69,7 +63,6 @@ initialise caps mainRule getLspId toDiags logger debouncer options vfs =
69 addIdeGlobal $ GlobalIdeOptions options
63 addIdeGlobal $ GlobalIdeOptions options
70 fileStoreRules vfs
64 fileStoreRules vfs
71 ofInterestRules
65 ofInterestRules
72− fileExistsRules getLspId caps vfs
73 mainRule
66 mainRule
74
67
75writeProfile :: IdeState -> FilePath -> IO ()
68writeProfile :: IdeState -> FilePath -> IO ()
src/Development/IDE/Core/Shake.hs+152−214
@@ -19,28 +19,25 @@
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, shakeExtras,
22+ IdeState,
23− ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
24 IdeRule, IdeResult, GetModificationTime(..),
23 IdeRule, IdeResult, GetModificationTime(..),
25 shakeOpen, shakeShut,
24 shakeOpen, shakeShut,
26 shakeRun,
25 shakeRun,
27 shakeProfile,
26 shakeProfile,
28 use, useWithStale, useNoFile, uses, usesWithStale,
27 use, useWithStale, useNoFile, uses, usesWithStale,
29 use_, useNoFile_, uses_,
28 use_, useNoFile_, uses_,
30− define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,
29+ define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, fingerprintToBS,
31 getDiagnostics, unsafeClearDiagnostics,
30 getDiagnostics, unsafeClearDiagnostics,
32− getHiddenDiagnostics,
33− IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,
31+ IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
34 garbageCollect,
32 garbageCollect,
35 setPriority,
33 setPriority,
36 sendEvent,
34 sendEvent,
37 ideLogger,
35 ideLogger,
38 actionLogger,
36 actionLogger,
39− FileVersion(..), modificationTime,
37+ FileVersion(..),
40 Priority(..),
38 Priority(..),
41 updatePositionMapping,
39 updatePositionMapping,
42− deleteValue,
43− OnDiskRule(..),
40+ OnDiskRule(..)
44 ) where
41 ) where
45
42
46import Development.Shake hiding (ShakeValue, doesFileExist)
43import Development.Shake hiding (ShakeValue, doesFileExist)
@@ -49,27 +46,30 @@ import Development.Shake.Classes
49import Development.Shake.Rule
46import Development.Shake.Rule
50import qualified Data.HashMap.Strict as HMap
47import qualified Data.HashMap.Strict as HMap
51import qualified Data.Map.Strict as Map
48import qualified Data.Map.Strict as Map
49+import qualified Data.Map.Merge.Strict as Map
52import qualified Data.ByteString.Char8 as BS
50import qualified Data.ByteString.Char8 as BS
51+import qualified Data.ByteString.Internal as BS
53import Data.Dynamic
52import Data.Dynamic
54import Data.Maybe
53import Data.Maybe
55import Data.Map.Strict (Map)
54import Data.Map.Strict (Map)
56−import Data.List.Extra (partition, takeEnd)
55+import Data.List.Extra
57import qualified Data.Set as Set
56import qualified Data.Set as Set
58import qualified Data.Text as T
57import qualified Data.Text as T
59−import Data.Traversable (for)
60import Data.Tuple.Extra
58import Data.Tuple.Extra
61import Data.Unique
59import Data.Unique
62import Development.IDE.Core.Debouncer
60import Development.IDE.Core.Debouncer
63import Development.IDE.Core.PositionMapping
61import Development.IDE.Core.PositionMapping
64import Development.IDE.Types.Logger hiding (Priority)
62import Development.IDE.Types.Logger hiding (Priority)
63+import Foreign.Ptr
64+import Foreign.Storable
65+import GHC.Fingerprint
65import Language.Haskell.LSP.Diagnostics
66import Language.Haskell.LSP.Diagnostics
66import qualified Data.SortedList as SL
67import qualified Data.SortedList as SL
67import Development.IDE.Types.Diagnostics
68import Development.IDE.Types.Diagnostics
68import Development.IDE.Types.Location
69import Development.IDE.Types.Location
69import Development.IDE.Types.Options
70import Development.IDE.Types.Options
70−import Control.Concurrent.Async
71import Control.Concurrent.Extra
71import Control.Concurrent.Extra
72−import Control.Exception.Extra
72+import Control.Exception
73import Control.DeepSeq
73import Control.DeepSeq
74import System.Time.Extra
74import System.Time.Extra
75import Data.Typeable
75import Data.Typeable
@@ -93,17 +93,12 @@ 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
97− ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])
96+ ,publishedDiagnostics :: Var (Map NormalizedUri [Diagnostic])
98 -- ^ This represents the set of diagnostics that we have published.
97 -- ^ This represents the set of diagnostics that we have published.
99 -- Due to debouncing not every change might get published.
98 -- Due to debouncing not every change might get published.
100− ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))
99+ ,positionMapping :: Var (Map NormalizedUri (Map TextDocumentVersion PositionMapping))
101 -- ^ Map from a text document version to a PositionMapping that describes how to map
100 -- ^ Map from a text document version to a PositionMapping that describes how to map
102 -- positions in a version of that document to positions in the latest version
101 -- 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
107 }
102 }
108
103
109getShakeExtras :: Action ShakeExtras
104getShakeExtras :: Action ShakeExtras
@@ -116,29 +111,22 @@ getShakeExtrasRules = do
116 Just x <- getShakeExtraRules @ShakeExtras
111 Just x <- getShakeExtraRules @ShakeExtras
117 return x
112 return x
118
113
114+
115+
119class Typeable a => IsIdeGlobal a where
116class Typeable a => IsIdeGlobal a where
120
117
121addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
118addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
122−addIdeGlobal x = do
119+addIdeGlobal x@(typeOf -> ty) = do
123− extras <- getShakeExtrasRules
124− liftIO $ addIdeGlobalExtras extras x
125−
126−addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()
127−addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =
120+ ShakeExtras{globals} <- getShakeExtrasRules
128 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
121 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
129− Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty
122+ Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty
130 Nothing -> return $! HMap.insert ty (toDyn x) mp
123 Nothing -> return $! HMap.insert ty (toDyn x) mp
131
124
132
125
133getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
126getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
134getIdeGlobalExtras ShakeExtras{globals} = do
127getIdeGlobalExtras ShakeExtras{globals} = do
135− let typ = typeRep (Proxy :: Proxy a)
136− x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
128+ Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
137− case x of
129+ return $ fromDyn x $ error "Serious error, corrupt globals"
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
142
130
143getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
131getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
144getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
132getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
@@ -161,7 +149,7 @@ instance Eq Key where
161 | otherwise = False
149 | otherwise = False
162
150
163instance Hashable Key where
151instance Hashable Key where
164− hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)
152+ hashWithSalt salt (Key key) = hashWithSalt salt key
165
153
166-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,
154-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,
167-- and a value is in the Maybe. For operations that throw an error you
155-- and a value is in the Maybe. For operations that throw an error you
@@ -171,6 +159,9 @@ instance Hashable Key where
171-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh
159-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh
172-- errors but still failed.
160-- errors but still failed.
173--
161--
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)
174
165
175data Value v
166data Value v
176 = Succeeded TextDocumentVersion v
167 = Succeeded TextDocumentVersion v
@@ -205,14 +196,14 @@ valueVersion = \case
205 Failed -> Nothing
196 Failed -> Nothing
206
197
207mappingForVersion
198mappingForVersion
208− :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
199+ :: Map NormalizedUri (Map TextDocumentVersion PositionMapping)
209 -> NormalizedFilePath
200 -> NormalizedFilePath
210 -> TextDocumentVersion
201 -> TextDocumentVersion
211 -> PositionMapping
202 -> PositionMapping
212mappingForVersion allMappings file ver =
203mappingForVersion allMappings file ver =
213− maybe zeroMapping snd $
204+ fromMaybe idMapping $
214 Map.lookup ver =<<
205 Map.lookup ver =<<
215− HMap.lookup (filePathToUri' file) allMappings
206+ Map.lookup (filePathToUri' file) allMappings
216
207
217type IdeRule k v =
208type IdeRule k v =
218 ( Shake.RuleResult k ~ v
209 ( Shake.RuleResult k ~ v
@@ -234,15 +225,15 @@ data IdeState = IdeState
234
225
235
226
236-- This is debugging code that generates a series of profiles, if the Boolean is true
227-- This is debugging code that generates a series of profiles, if the Boolean is true
237−shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO ([a], Maybe FilePath)
228+shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO [a]
238shakeRunDatabaseProfile mbProfileDir shakeDb acts = do
229shakeRunDatabaseProfile mbProfileDir shakeDb acts = do
239 (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts
230 (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts
240− proFile <- for mbProfileDir $ \dir -> do
231+ whenJust mbProfileDir $ \dir -> do
241− count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)
232+ count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)
242− let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"
233+ let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"
243− shakeProfileDatabase shakeDb $ dir </> file
234+ shakeProfileDatabase shakeDb $ dir </> file
244− return (dir </> file)
245− return (res, proFile)
235+ return res
236+ where
246
237
247{-# NOINLINE profileStartTime #-}
238{-# NOINLINE profileStartTime #-}
248profileStartTime :: String
239profileStartTime :: String
@@ -262,16 +253,6 @@ setValues state key file val = modifyVar_ state $ \vals -> do
262 -- Force to make sure the old HashMap is not retained
253 -- Force to make sure the old HashMap is not retained
263 evaluate $ HMap.insert (file, Key key) (fmap toDyn val) vals
254 evaluate $ HMap.insert (file, Key key) (fmap toDyn val) vals
264
255
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−
275-- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.
256-- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.
276getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
257getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
277getValues state key file = do
258getValues state key file = do
@@ -298,40 +279,33 @@ seqValue v b = case v of
298shakeOpen :: IO LSP.LspId
279shakeOpen :: IO LSP.LspId
299 -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
280 -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
300 -> Logger
281 -> Logger
301− -> Debouncer NormalizedUri
302 -> Maybe FilePath
282 -> Maybe FilePath
303 -> IdeReportProgress
283 -> IdeReportProgress
304 -> ShakeOptions
284 -> ShakeOptions
305 -> Rules ()
285 -> Rules ()
306 -> IO IdeState
286 -> IO IdeState
307−shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) opts rules = do
287+shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do
308− inProgress <- newVar HMap.empty
309 shakeExtras <- do
288 shakeExtras <- do
310 globals <- newVar HMap.empty
289 globals <- newVar HMap.empty
311 state <- newVar HMap.empty
290 state <- newVar HMap.empty
312 diagnostics <- newVar mempty
291 diagnostics <- newVar mempty
313− hiddenDiagnostics <- newVar mempty
314 publishedDiagnostics <- newVar mempty
292 publishedDiagnostics <- newVar mempty
293+ debouncer <- newDebouncer
315− positionMapping <- newVar HMap.empty
294+ positionMapping <- newVar Map.empty
316 pure ShakeExtras{..}
295 pure ShakeExtras{..}
317 (shakeDb, shakeClose) <-
296 (shakeDb, shakeClose) <-
318 shakeOpenDatabase
297 shakeOpenDatabase
319 opts
298 opts
320 { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts
299 { 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
323− , shakeProgress = const $ if reportProgress then lspShakeProgress getLspId eventer inProgress else pure ()
300+ , shakeProgress = if reportProgress then lspShakeProgress getLspId eventer else const (pure ())
324 }
301 }
325 rules
302 rules
326 shakeAbort <- newMVar $ return ()
303 shakeAbort <- newMVar $ return ()
327 shakeDb <- shakeDb
304 shakeDb <- shakeDb
328 return IdeState{..}
305 return IdeState{..}
329
306
330−lspShakeProgress :: Hashable a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (HMap.HashMap a Int) -> IO ()
307+lspShakeProgress :: IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> IO Progress -> IO ()
331−lspShakeProgress getLspId sendMsg inProgress = do
308+lspShakeProgress getLspId sendMsg prog = 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
335 lspId <- getLspId
309 lspId <- getLspId
336 u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique
310 u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique
337 sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest
311 sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest
@@ -359,9 +333,9 @@ lspShakeProgress getLspId sendMsg inProgress = do
359 sample = 0.1
333 sample = 0.1
360 loop id prev = do
334 loop id prev = do
361 sleep sample
335 sleep sample
362− current <- readVar inProgress
336+ p <- prog
363− let done = length $ filter (== 0) $ HMap.elems current
337+ let done = countSkipped p + countBuilt p
364− let todo = HMap.size current
338+ let todo = done + countUnknown p + countTodo p
365 let next = Just $ T.pack $ show done <> "/" <> show todo
339 let next = Just $ T.pack $ show done <> "/" <> show todo
366 when (next /= prev) $
340 when (next /= prev) $
367 sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification
341 sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification
@@ -387,11 +361,11 @@ shakeShut IdeState{..} = withMVar shakeAbort $ \stop -> do
387
361
388-- | This is a variant of withMVar where the first argument is run unmasked and if it throws
362-- | This is a variant of withMVar where the first argument is run unmasked and if it throws
389-- an exception, the previous value is restored while the second argument is executed masked.
363-- an exception, the previous value is restored while the second argument is executed masked.
390−withMVar' :: MVar a -> (a -> IO ()) -> IO (a, c) -> IO c
364+withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
391withMVar' var unmasked masked = mask $ \restore -> do
365withMVar' var unmasked masked = mask $ \restore -> do
392 a <- takeMVar var
366 a <- takeMVar var
393− restore (unmasked a) `onException` putMVar var a
367+ b <- restore (unmasked a) `onException` putMVar var a
394− (a', c) <- masked
368+ (a', c) <- masked b
395 putMVar var a'
369 putMVar var a'
396 pure c
370 pure c
397
371
@@ -403,44 +377,29 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =
403 (\stop -> do
377 (\stop -> do
404 (stopTime,_) <- duration stop
378 (stopTime,_) <- duration stop
405 logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
379 logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
406− )
380+ bar <- newBarrier
381+ start <- offsetTime
382+ pure (start, bar))
407 -- It is crucial to be masked here, otherwise we can get killed
383 -- It is crucial to be masked here, otherwise we can get killed
408 -- between spawning the new thread and updating shakeAbort.
384 -- between spawning the new thread and updating shakeAbort.
409 -- See https://github.com/digital-asset/ghcide/issues/79
385 -- See https://github.com/digital-asset/ghcide/issues/79
410− (do
411− start <- offsetTime
386+ (\(start, bar) -> do
412− aThread <- asyncWithUnmask $ \restore -> do
413− res <- try (restore $ shakeRunDatabaseProfile shakeProfileDir shakeDb acts)
387+ thread <- forkFinally (shakeRunDatabaseProfile shakeProfileDir shakeDb acts) $ \res -> do
414− runTime <- start
388+ runTime <- start
415− let res' = case res of
389+ let res' = case res of
416− Left e -> "exception: " <> displayException e
390+ Left e -> "exception: " <> displayException e
417− Right _ -> "completed"
391+ 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− _ -> ""
424− let logMsg = logDebug logger $ T.pack $
392+ logDebug logger $ T.pack $
425− "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ profile ++ ")"
393+ "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ ")"
426− return (fst <$> res, logMsg)
394+ signalBarrier bar res
427− let wrapUp (res, _) = do
395+ -- important: we send an async exception to the thread, then wait for it to die, before continuing
428− either (throwIO @SomeException) return res
396+ pure (killThread thread >> void (waitBarrier bar), either throwIO return =<< waitBarrier bar))
429− _ <- async $ do
430− (_, logMsg) <- wait aThread
431− logMsg
432− pure (cancel aThread, wrapUp =<< wait aThread))
433
397
434getDiagnostics :: IdeState -> IO [FileDiagnostic]
398getDiagnostics :: IdeState -> IO [FileDiagnostic]
435getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
399getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
436 val <- readVar diagnostics
400 val <- readVar diagnostics
437 return $ getAllDiagnostics val
401 return $ getAllDiagnostics val
438
402
439−getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic]
440−getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do
441− val <- readVar hiddenDiagnostics
442− return $ getAllDiagnostics val
443−
444-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
403-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
445unsafeClearDiagnostics :: IdeState -> IO ()
404unsafeClearDiagnostics :: IdeState -> IO ()
446unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
405unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
@@ -449,16 +408,15 @@ unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
449-- | Clear the results for all files that do not match the given predicate.
408-- | Clear the results for all files that do not match the given predicate.
450garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
409garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
451garbageCollect keep = do
410garbageCollect keep = do
452− ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras
411+ ShakeExtras{state, diagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras
453 liftIO $
412 liftIO $
454 do newState <- modifyVar state $ \values -> do
413 do newState <- modifyVar state $ \values -> do
455 values <- evaluate $ HMap.filterWithKey (\(file, _) _ -> keep file) values
414 values <- evaluate $ HMap.filterWithKey (\(file, _) _ -> keep file) values
456 return $! dupe values
415 return $! dupe values
457 modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags
416 modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags
458− modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags
459− modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags
417+ modifyVar_ publishedDiagnostics $ \diags -> return $! Map.filterWithKey (\uri _ -> keep (fromUri uri)) diags
460 let versionsForFile =
418 let versionsForFile =
461− HMap.fromListWith Set.union $
419+ Map.fromListWith Set.union $
462 mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
420 mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
463 HMap.toList newState
421 HMap.toList newState
464 modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings
422 modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings
@@ -476,25 +434,25 @@ useWithStale :: IdeRule k v
476useWithStale key file = head <$> usesWithStale key [file]
434useWithStale key file = head <$> usesWithStale key [file]
477
435
478useNoFile :: IdeRule k v => k -> Action (Maybe v)
436useNoFile :: IdeRule k v => k -> Action (Maybe v)
479−useNoFile key = use key emptyFilePath
437+useNoFile key = use key ""
480
438
481use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
439use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
482use_ key file = head <$> uses_ key [file]
440use_ key file = head <$> uses_ key [file]
483
441
484useNoFile_ :: IdeRule k v => k -> Action v
442useNoFile_ :: IdeRule k v => k -> Action v
485−useNoFile_ key = use_ key emptyFilePath
443+useNoFile_ key = use_ key ""
486
444
487uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
445uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
488uses_ key files = do
446uses_ key files = do
489 res <- uses key files
447 res <- uses key files
490 case sequence res of
448 case sequence res of
491− Nothing -> liftIO $ throwIO $ BadDependency (show key)
449+ Nothing -> liftIO $ throwIO BadDependency
492 Just v -> return v
450 Just v -> return v
493
451
494
452
495-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
453-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
496-- which short-circuits the rest of the action
454-- which short-circuits the rest of the action
497−data BadDependency = BadDependency String deriving Show
455+data BadDependency = BadDependency deriving Show
498instance Exception BadDependency
456instance Exception BadDependency
499
457
500isBadDependency :: SomeException -> Bool
458isBadDependency :: SomeException -> Bool
@@ -513,10 +471,12 @@ instance Show k => Show (Q k) where
513
471
514-- | Invariant: the 'v' must be in normal form (fully evaluated).
472-- | Invariant: the 'v' must be in normal form (fully evaluated).
515-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database
473-- 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?
516−newtype A v = A (Value v)
476+data A v = A (Value v) ShakeValue
517 deriving Show
477 deriving Show
518
478
519−instance NFData (A v) where rnf (A v) = v `seq` ()
479+instance NFData (A v) where rnf (A v x) = v `seq` rnf x
520
480
521-- In the Shake database we only store one type of key/result pairs,
481-- In the Shake database we only store one type of key/result pairs,
522-- namely Q (question) / A (answer).
482-- namely Q (question) / A (answer).
@@ -526,70 +486,59 @@ type instance RuleResult (Q k) = A (RuleResult k)
526-- | Return up2date results. Stale results will be ignored.
486-- | Return up2date results. Stale results will be ignored.
527uses :: IdeRule k v
487uses :: IdeRule k v
528 => k -> [NormalizedFilePath] -> Action [Maybe v]
488 => k -> [NormalizedFilePath] -> Action [Maybe v]
529−uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files)
489+uses key files = map (\(A value _) -> currentValue value) <$> apply (map (Q . (key,)) files)
530
490
531-- | Return the last computed result which might be stale.
491-- | Return the last computed result which might be stale.
532usesWithStale :: IdeRule k v
492usesWithStale :: IdeRule k v
533 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
493 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
534usesWithStale key files = do
494usesWithStale key files = do
535− values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files)
495+ values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
536− zipWithM lastValue files values
496+ mapM (uncurry lastValue) (zip 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−
546
497
547defineEarlyCutoff
498defineEarlyCutoff
548 :: IdeRule k v
499 :: IdeRule k v
549 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
500 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
550 -> Rules ()
501 -> Rules ()
551defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do
502defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do
552− extras@ShakeExtras{state, inProgress} <- getShakeExtras
503+ extras@ShakeExtras{state} <- 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
555− val <- case old of
504+ val <- case old of
556− Just old | mode == RunDependenciesSame -> do
505+ Just old | mode == RunDependenciesSame -> do
557− v <- liftIO $ getValues state key file
506+ v <- liftIO $ getValues state key file
558− case v of
507+ case v of
559− -- No changes in the dependencies and we have
508+ -- No changes in the dependencies and we have
560− -- an existing result.
509+ -- an existing result.
561− Just v -> return $ Just $ RunResult ChangedNothing old $ A v
510+ Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)
562− _ -> return Nothing
511+ _ -> return Nothing
563− _ -> return Nothing
512+ _ -> return Nothing
564− case val of
513+ case val of
565− Just res -> return res
514+ Just res -> return res
566− Nothing -> do
515+ Nothing -> do
567− (bs, (diags, res)) <- actionCatch
516+ (bs, (diags, res)) <- actionCatch
568− (do v <- op key file; liftIO $ evaluate $ force v) $
517+ (do v <- op key file; liftIO $ evaluate $ force $ v) $
569− \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
518+ \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
570− modTime <- liftIO $ (currentValue =<<) <$> getValues state GetModificationTime file
519+ modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file
571− (bs, res) <- case res of
520+ (bs, res) <- case res of
572− Nothing -> do
521+ Nothing -> do
573− staleV <- liftIO $ getValues state key file
522+ staleV <- liftIO $ getValues state key file
574− pure $ case staleV of
523+ pure $ case staleV of
575− Nothing -> (toShakeValue ShakeResult bs, Failed)
524+ Nothing -> (toShakeValue ShakeResult bs, Failed)
576− Just v -> case v of
525+ Just v -> case v of
577− Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
526+ Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
578− Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
527+ Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
579− Failed -> (toShakeValue ShakeResult bs, Failed)
528+ Failed -> (toShakeValue ShakeResult bs, Failed)
580− Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
529+ Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
581− liftIO $ setValues state key file res
530+ liftIO $ setValues state key file res
582− updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
531+ updateFileDiagnostics file (Key key) extras $ map snd diags
583− let eq = case (bs, fmap decodeShakeValue old) of
532+ let eq = case (bs, fmap decodeShakeValue old) of
584− (ShakeResult a, Just (ShakeResult b)) -> a == b
533+ (ShakeResult a, Just (ShakeResult b)) -> a == b
585− (ShakeStale a, Just (ShakeStale b)) -> a == b
534+ (ShakeStale a, Just (ShakeStale b)) -> a == b
586− -- If we do not have a previous result
535+ -- If we do not have a previous result
587− -- or we got ShakeNoCutoff we always return False.
536+ -- or we got ShakeNoCutoff we always return False.
588− _ -> False
537+ _ -> False
589− return $ RunResult
538+ return $ RunResult
590− (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
539+ (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
591− (encodeShakeValue bs) $
540+ (encodeShakeValue bs) $
592− A res
541+ A res bs
593
542
594
543
595-- | Rule type, input file
544-- | Rule type, input file
@@ -640,7 +589,7 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $
640 case mbOld of
589 case mbOld of
641 Nothing -> do
590 Nothing -> do
642 (diags, mbHash) <- runAct
591 (diags, mbHash) <- runAct
643− updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
592+ updateFileDiagnostics file (Key key) extras $ map snd diags
644 pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash)
593 pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash)
645 Just old -> do
594 Just old -> do
646 current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "")
595 current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "")
@@ -651,21 +600,27 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $
651 pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current)
600 pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current)
652 else do
601 else do
653 (diags, mbHash) <- runAct
602 (diags, mbHash) <- runAct
654− updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
603+ updateFileDiagnostics file (Key key) extras $ map snd diags
655 let change
604 let change
656 | mbHash == Just old = ChangedRecomputeSame
605 | mbHash == Just old = ChangedRecomputeSame
657 | otherwise = ChangedRecomputeDiff
606 | otherwise = ChangedRecomputeDiff
658 pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)
607 pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)
659
608
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+
660needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()
615needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()
661needOnDisk k file = do
616needOnDisk k file = do
662 successfull <- apply1 (QDisk k file)
617 successfull <- apply1 (QDisk k file)
663− liftIO $ unless successfull $ throwIO $ BadDependency (show k)
618+ liftIO $ unless successfull $ throwIO BadDependency
664
619
665needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()
620needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()
666needOnDisks k files = do
621needOnDisks k files = do
667 successfulls <- apply $ map (QDisk k) files
622 successfulls <- apply $ map (QDisk k) files
668− liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k)
623+ liftIO $ unless (and successfulls) $ throwIO BadDependency
669
624
670toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue
625toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue
671toShakeValue = maybe ShakeNoCutoff
626toShakeValue = maybe ShakeNoCutoff
@@ -701,38 +656,29 @@ updateFileDiagnostics ::
701 NormalizedFilePath
656 NormalizedFilePath
702 -> Key
657 -> Key
703 -> ShakeExtras
658 -> ShakeExtras
704− -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
659+ -> [Diagnostic] -- ^ current results
705 -> Action ()
660 -> Action ()
706−updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
661+updateFileDiagnostics fp k ShakeExtras{diagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
707− modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp
662+ modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp
708− let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
709 mask_ $ do
663 mask_ $ do
710 -- Mask async exceptions to ensure that updated diagnostics are always
664 -- Mask async exceptions to ensure that updated diagnostics are always
711 -- published. Otherwise, we might never publish certain diagnostics if
665 -- published. Otherwise, we might never publish certain diagnostics if
712 -- an exception strikes between modifyVar but before
666 -- an exception strikes between modifyVar but before
713 -- publishDiagnosticsNotification.
667 -- publishDiagnosticsNotification.
714 newDiags <- modifyVar diagnostics $ \old -> do
668 newDiags <- modifyVar diagnostics $ \old -> do
715− let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
669+ let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime) (T.pack $ show k) current old
716− (T.pack $ show k) (map snd currentShown) old
717 let newDiags = getFileDiagnostics fp newDiagsStore
670 let newDiags = getFileDiagnostics fp newDiagsStore
718 _ <- evaluate newDiagsStore
671 _ <- evaluate newDiagsStore
719 _ <- evaluate newDiags
672 _ <- evaluate newDiags
720− pure (newDiagsStore, newDiags)
673+ 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
728 let uri = filePathToUri' fp
674 let uri = filePathToUri' fp
729 let delay = if null newDiags then 0.1 else 0
675 let delay = if null newDiags then 0.1 else 0
730 registerEvent debouncer delay uri $ do
676 registerEvent debouncer delay uri $ do
731 mask_ $ modifyVar_ publishedDiagnostics $ \published -> do
677 mask_ $ modifyVar_ publishedDiagnostics $ \published -> do
732− let lastPublish = HMap.lookupDefault [] uri published
678+ let lastPublish = Map.findWithDefault [] uri published
733 when (lastPublish /= newDiags) $
679 when (lastPublish /= newDiags) $
734 eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags
680 eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags
735− pure $! HMap.insert uri newDiags published
681+ pure $! Map.insert uri newDiags published
736
682
737publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage
683publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage
738publishDiagnosticsNotification uri diags =
684publishDiagnosticsNotification uri diags =
@@ -743,7 +689,7 @@ publishDiagnosticsNotification uri diags =
743newtype Priority = Priority Double
689newtype Priority = Priority Double
744
690
745setPriority :: Priority -> Action ()
691setPriority :: Priority -> Action ()
746−setPriority (Priority p) = reschedule p
692+setPriority (Priority p) = deprioritize p
747
693
748sendEvent :: LSP.FromServerMessage -> Action ()
694sendEvent :: LSP.FromServerMessage -> Action ()
749sendEvent e = do
695sendEvent e = do
@@ -768,22 +714,19 @@ instance Binary GetModificationTime
768-- | Get the modification time of a file.
714-- | Get the modification time of a file.
769type instance RuleResult GetModificationTime = FileVersion
715type instance RuleResult GetModificationTime = FileVersion
770
716
771−data FileVersion
717+-- | We store the modification time as a ByteString since we need
772− = VFSVersion !Int
718+-- a ByteString anyway for Shake and we do not care about how times
719+-- are represented.
773− | ModificationTime
720+data FileVersion = VFSVersion Int | ModificationTime BS.ByteString
774− !Int -- ^ Large unit (platform dependent, do not make assumptions)
775− !Int -- ^ Small unit (platform dependent, do not make assumptions)
776 deriving (Show, Generic)
721 deriving (Show, Generic)
777
722
778instance NFData FileVersion
723instance NFData FileVersion
779
724
780vfsVersion :: FileVersion -> Maybe Int
725vfsVersion :: FileVersion -> Maybe Int
781vfsVersion (VFSVersion i) = Just i
726vfsVersion (VFSVersion i) = Just i
782−vfsVersion ModificationTime{} = Nothing
727+vfsVersion (ModificationTime _) = Nothing
728+
783
729
784−modificationTime :: FileVersion -> Maybe (Int, Int)
785−modificationTime VFSVersion{} = Nothing
786−modificationTime (ModificationTime large small) = Just (large, small)
787
730
788getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
731getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
789getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
732getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
@@ -808,7 +751,7 @@ getAllDiagnostics ::
808 DiagnosticStore ->
751 DiagnosticStore ->
809 [FileDiagnostic]
752 [FileDiagnostic]
810getAllDiagnostics =
753getAllDiagnostics =
811− concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList
754+ concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList
812
755
813getFileDiagnostics ::
756getFileDiagnostics ::
814 NormalizedFilePath ->
757 NormalizedFilePath ->
@@ -816,34 +759,29 @@ getFileDiagnostics ::
816 [LSP.Diagnostic]
759 [LSP.Diagnostic]
817getFileDiagnostics fp ds =
760getFileDiagnostics fp ds =
818 maybe [] getDiagnosticsFromStore $
761 maybe [] getDiagnosticsFromStore $
819− HMap.lookup (filePathToUri' fp) ds
762+ Map.lookup (filePathToUri' fp) ds
820
763
821filterDiagnostics ::
764filterDiagnostics ::
822 (NormalizedFilePath -> Bool) ->
765 (NormalizedFilePath -> Bool) ->
823 DiagnosticStore ->
766 DiagnosticStore ->
824 DiagnosticStore
767 DiagnosticStore
825filterDiagnostics keep =
768filterDiagnostics keep =
826− HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri)
769+ Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)
827
770
828filterVersionMap
771filterVersionMap
829− :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)
772+ :: Map NormalizedUri (Set.Set TextDocumentVersion)
830− -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
773+ -> Map NormalizedUri (Map TextDocumentVersion a)
831− -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
774+ -> Map NormalizedUri (Map TextDocumentVersion a)
832filterVersionMap =
775filterVersionMap =
776+ Map.merge Map.dropMissing Map.dropMissing $
833− HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
777+ Map.zipWithMatched $ \_ versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
834
778
835updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
779updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
836−updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do
780+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do
837 modifyVar_ positionMapping $ \allMappings -> do
781 modifyVar_ positionMapping $ \allMappings -> do
838 let uri = toNormalizedUri _uri
782 let uri = toNormalizedUri _uri
839− let mappingForUri = HMap.lookupDefault Map.empty uri allMappings
783+ let mappingForUri = Map.findWithDefault Map.empty uri allMappings
840− let (_, updatedMapping) =
784+ let updatedMapping =
841− -- Very important to use mapAccum here so that the tails of
785+ Map.insert _version idMapping $
842− -- each mapping can be shared, otherwise quadratic space is
786+ Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri
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)
847− pure $! HMap.insert uri updatedMapping allMappings
787+ pure $! Map.insert uri updatedMapping allMappings
848− where
849− shared_change = mkDelta changes
src/Development/IDE/GHC/CPP.hs+3−34
@@ -19,8 +19,7 @@
19--
19--
20-----------------------------------------------------------------------------
20-----------------------------------------------------------------------------
21
21
22−module Development.IDE.GHC.CPP(doCpp, addOptP)
22+module Development.IDE.GHC.CPP(doCpp) where
23−where
24
23
25import Development.IDE.GHC.Compat
24import Development.IDE.GHC.Compat
26import Packages
25import Packages
@@ -29,15 +28,9 @@ import Module
29import DynFlags
28import DynFlags
30import Panic
29import Panic
31import FileCleanup
30import FileCleanup
32−#if MIN_GHC_API_VERSION(8,8,2)
31+#if MIN_GHC_API_VERSION(8,8,0)
33−import LlvmCodeGen (llvmVersionList)
34−#elif MIN_GHC_API_VERSION(8,8,0)
35import LlvmCodeGen (LlvmVersion (..))
32import LlvmCodeGen (LlvmVersion (..))
36#endif
33#endif
37−#if MIN_GHC_API_VERSION (8,10,0)
38−import Fingerprint
39−import ToolSettings
40−#endif
41
34
42import System.Directory
35import System.Directory
43import System.FilePath
36import System.FilePath
@@ -64,11 +57,7 @@ doCpp dflags raw input_fn output_fn = do
64 let verbFlags = getVerbFlags dflags
57 let verbFlags = getVerbFlags dflags
65
58
66 let cpp_prog args | raw = SysTools.runCpp dflags args
59 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
70 | otherwise = SysTools.runCc
60 | otherwise = SysTools.runCc
71−#endif
72 dflags (SysTools.Option "-E" : args)
61 dflags (SysTools.Option "-E" : args)
73
62
74 let target_defs =
63 let target_defs =
@@ -148,11 +137,7 @@ getBackendDefs :: DynFlags -> IO [String]
148getBackendDefs dflags | hscTarget dflags == HscLlvm = do
137getBackendDefs dflags | hscTarget dflags == HscLlvm = do
149 llvmVer <- figureLlvmVersion dflags
138 llvmVer <- figureLlvmVersion dflags
150 return $ case llvmVer of
139 return $ case llvmVer of
151−#if MIN_GHC_API_VERSION(8,8,2)
140+#if MIN_GHC_API_VERSION(8,8,0)
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)
156 Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]
141 Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]
157 Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
142 Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
158#else
143#else
@@ -167,22 +152,6 @@ getBackendDefs dflags | hscTarget dflags == HscLlvm = do
167getBackendDefs _ =
152getBackendDefs _ =
168 return []
153 return []
169
154
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−
186-- ---------------------------------------------------------------------------
155-- ---------------------------------------------------------------------------
187-- Macros (cribbed from Cabal)
156-- Macros (cribbed from Cabal)
188
157
src/Development/IDE/GHC/Compat.hs+27−251
@@ -2,106 +2,62 @@
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 #-}
6#include "ghc-api-version.h"
5#include "ghc-api-version.h"
7
6
8-- | Attempt at hiding the GHC version differences we can.
7-- | Attempt at hiding the GHC version differences we can.
9module Development.IDE.GHC.Compat(
8module Development.IDE.GHC.Compat(
10− getHeaderImports,
11 HieFileResult(..),
9 HieFileResult(..),
12− HieFile,
10+ HieFile(..),
13− hieExportNames,
14− hie_module,
15 mkHieFile,
11 mkHieFile,
16 writeHieFile,
12 writeHieFile,
17 readHieFile,
13 readHieFile,
18− supportsHieFiles,
19− setDefaultHieDir,
20− dontWriteHieFiles,
21−#if !MIN_GHC_API_VERSION(8,8,0)
22− ml_hie_file,
23−#endif
24 hPutStringBuffer,
14 hPutStringBuffer,
25 includePathsGlobal,
15 includePathsGlobal,
26 includePathsQuote,
16 includePathsQuote,
27 addIncludePathsQuote,
17 addIncludePathsQuote,
28− getModuleHash,
18+ ghcEnumerateExtensions
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
44 ) where
19 ) where
45
20
46import StringBuffer
21import StringBuffer
47import DynFlags
22import DynFlags
48−import FieldLabel
23+import GHC.LanguageExtensions.Type
49−import Fingerprint (Fingerprint)
50−import qualified Module
51−import Packages
52−
53−import qualified GHC
54−import GHC hiding (
55− ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation
56−#if MIN_GHC_API_VERSION(8,6,0)
57− , getConArgs
58−#endif
59− )
60−import qualified HeaderInfo as Hdr
61−import Avail
62−import ErrUtils (ErrorMessages)
63−import FastString (FastString)
64
24
65−#if MIN_GHC_API_VERSION(8,10,0)
25+#if MIN_GHC_API_VERSION(8,8,0)
66−import HscTypes (mi_mod_hash)
26+import Data.List.Extra (enumerate)
67#endif
27#endif
68
28
69#if MIN_GHC_API_VERSION(8,8,0)
29#if MIN_GHC_API_VERSION(8,8,0)
70−import Control.Applicative ((<|>))
30+import HieAst
71−import Development.IDE.GHC.HieAst (mkHieFile)
72import HieBin
31import HieBin
73import HieTypes
32import HieTypes
74−
75−supportsHieFiles :: Bool
76−supportsHieFiles = True
77−
78−hieExportNames :: HieFile -> [(SrcSpan, Name)]
79−hieExportNames = nameListFromAvails . hie_exports
80−
81#else
33#else
82−
83−#if MIN_GHC_API_VERSION(8,6,0)
84−import BinIface
34+import GHC
85−import Data.IORef
86−import IfaceEnv
87−#endif
88−
89−import Binary
90−import Control.Exception (catch)
91−import Data.ByteString (ByteString)
92−import GhcPlugins hiding (ModLocation)
35+import GhcPlugins
93import NameCache
36import NameCache
37+import Avail
94import TcRnTypes
38import TcRnTypes
95import System.IO
39import System.IO
96import Foreign.ForeignPtr
40import Foreign.ForeignPtr
97−import MkIface
98
41
99
42
43+#if !MIN_GHC_API_VERSION(8,8,0)
100hPutStringBuffer :: Handle -> StringBuffer -> IO ()
44hPutStringBuffer :: Handle -> StringBuffer -> IO ()
101hPutStringBuffer hdl (StringBuffer buf len cur)
45hPutStringBuffer hdl (StringBuffer buf len cur)
102 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->
46 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->
103 hPutBuf hdl ptr len
47 hPutBuf hdl ptr len
48+#endif
104
49
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 }
105#endif
61#endif
106
62
107#if !MIN_GHC_API_VERSION(8,6,0)
63#if !MIN_GHC_API_VERSION(8,6,0)
@@ -119,191 +75,11 @@ addIncludePathsQuote path x = x{includePaths = f $ includePaths x}
119addIncludePathsQuote path x = x{includePaths = path : includePaths x}
75addIncludePathsQuote path x = x{includePaths = path : includePaths x}
120#endif
76#endif
121
77
122−pattern DerivD :: DerivDecl p -> HsDecl p
78+ghcEnumerateExtensions :: [Extension]
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 <-
180#if MIN_GHC_API_VERSION(8,8,0)
79#if MIN_GHC_API_VERSION(8,8,0)
181− GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c ""
80+ghcEnumerateExtensions = enumerate
81+#elif MIN_GHC_API_VERSION(8,6,0)
82+ghcEnumerateExtensions = [Cpp .. StarIsType]
182#else
83#else
183− GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c
84+ghcEnumerateExtensions = [Cpp .. EmptyDataDeriving]
184#endif
85#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+4−37
@@ -9,19 +9,12 @@ module Development.IDE.GHC.Error
9 , diagFromStrings
9 , diagFromStrings
10 , diagFromGhcException
10 , diagFromGhcException
11 , catchSrcErrors
11 , catchSrcErrors
12− , mergeDiagnostics
13
12
14 -- * utilities working with spans
13 -- * utilities working with spans
15 , srcSpanToLocation
14 , srcSpanToLocation
16− , srcSpanToRange
17 , srcSpanToFilename
15 , srcSpanToFilename
18 , zeroSpan
16 , zeroSpan
19 , realSpan
17 , realSpan
20− , isInsideSrcSpan
21− , noSpan
22−
23− -- * utilities working with severities
24− , toDSeverity
25 ) where
18 ) where
26
19
27import Development.IDE.Types.Diagnostics as D
20import Development.IDE.Types.Diagnostics as D
@@ -37,12 +30,11 @@ import Panic
37import ErrUtils
30import ErrUtils
38import SrcLoc
31import SrcLoc
39import qualified Outputable as Out
32import qualified Outputable as Out
40−import Exception (ExceptionMonad)
41
33
42
34
43
35
44diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
36diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
45−diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename loc,ShowDiag,)
37+diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,)
46 Diagnostic
38 Diagnostic
47 { _range = srcSpanToRange loc
39 { _range = srcSpanToRange loc
48 , _severity = Just sev
40 , _severity = Just sev
@@ -50,39 +42,18 @@ diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename
50 , _message = msg
42 , _message = msg
51 , _code = Nothing
43 , _code = Nothing
52 , _relatedInformation = Nothing
44 , _relatedInformation = Nothing
53− , _tags = Nothing
54 }
45 }
55
46
56-- | Produce a GHC-style error from a source span and a message.
47-- | Produce a GHC-style error from a source span and a message.
57diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]
48diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]
58diagFromErrMsg diagSource dflags e =
49diagFromErrMsg diagSource dflags e =
59− [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $
50+ [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $ ErrUtils.pprLocErrMsg e
60− ErrUtils.formatErrDoc dflags $ ErrUtils.errMsgDoc e
61 | Just sev <- [toDSeverity $ errMsgSeverity e]]
51 | Just sev <- [toDSeverity $ errMsgSeverity e]]
62
52
63
53
64diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
54diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
65diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList
55diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList
66
56
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
86
57
87-- | Convert a GHC SrcSpan to a DAML compiler Range
58-- | Convert a GHC SrcSpan to a DAML compiler Range
88srcSpanToRange :: SrcSpan -> Range
59srcSpanToRange :: SrcSpan -> Range
@@ -103,11 +74,7 @@ srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real
103srcSpanToLocation :: SrcSpan -> Location
74srcSpanToLocation :: SrcSpan -> Location
104srcSpanToLocation src =
75srcSpanToLocation src =
105 -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code
76 -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code
106− Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ srcSpanToFilename src) (srcSpanToRange src)
77+ 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
111
78
112-- | Convert a GHC severity to a DAML compiler Severity. Severities below
79-- | Convert a GHC severity to a DAML compiler Severity. Severities below
113-- "Warning" level are dropped (returning Nothing).
80-- "Warning" level are dropped (returning Nothing).
@@ -150,7 +117,7 @@ realSpan = \case
150
117
151-- | Run something in a Ghc monad and catch the errors (SourceErrors and
118-- | Run something in a Ghc monad and catch the errors (SourceErrors and
152-- compiler-internal exceptions like Panic or InstallationError).
119-- compiler-internal exceptions like Panic or InstallationError).
153−catchSrcErrors :: (HasDynFlags m, ExceptionMonad m) => T.Text -> m a -> m (Either [FileDiagnostic] a)
120+catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)
154catchSrcErrors fromWhere ghcM = do
121catchSrcErrors fromWhere ghcM = do
155 dflags <- getDynFlags
122 dflags <- getDynFlags
156 handleGhcException (ghcExceptionToDiagnostics dflags) $
123 handleGhcException (ghcExceptionToDiagnostics dflags) $
src/Development/IDE/GHC/Orphans.hs+3−10
@@ -1,10 +1,8 @@
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{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
6{-# OPTIONS_GHC -Wno-orphans #-}
5{-# OPTIONS_GHC -Wno-orphans #-}
7−#include "ghc-api-version.h"
8
6
9-- | Orphan instances for GHC.
7-- | Orphan instances for GHC.
10-- Note that the 'NFData' instances may not be law abiding.
8-- Note that the 'NFData' instances may not be law abiding.
@@ -33,7 +31,7 @@ instance NFData Linkable where rnf = rwhnf
33instance Show InstalledUnitId where
31instance Show InstalledUnitId where
34 show = installedUnitIdString
32 show = installedUnitIdString
35
33
36−instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS
34+instance NFData InstalledUnitId where rnf = rwhnf
37
35
38instance NFData SB.StringBuffer where rnf = rwhnf
36instance NFData SB.StringBuffer where rnf = rwhnf
39
37
@@ -42,8 +40,8 @@ instance Show Module where
42
40
43instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint
41instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint
44
42
45−instance (NFData l, NFData e) => NFData (GenLocated l e) where
43+instance NFData (GenLocated SrcSpan ModuleName) where
46− rnf (L l e) = rnf l `seq` rnf e
44+ rnf = rwhnf
47
45
48instance Show ModSummary where
46instance Show ModSummary where
49 show = show . ms_mod
47 show = show . ms_mod
@@ -54,11 +52,6 @@ instance Show ParsedModule where
54instance NFData ModSummary where
52instance NFData ModSummary where
55 rnf = rwhnf
53 rnf = rwhnf
56
54
57−#if !MIN_GHC_API_VERSION(8,10,0)
58−instance NFData FastString where
59− rnf = rwhnf
60−#endif
61−
62instance NFData ParsedModule where
55instance NFData ParsedModule where
63 rnf = rwhnf
56 rnf = rwhnf
64
57
src/Development/IDE/GHC/Util.hs+70−151
@@ -1,83 +1,65 @@
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−-- | General utility functions, mostly focused around GHC operations.
4+{-# OPTIONS_GHC -Wno-missing-fields #-} -- to enable prettyPrint
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.
5module Development.IDE.GHC.Util(
13module Development.IDE.GHC.Util(
6− -- * HcsEnv and environment
14+ lookupPackageConfig,
7− HscEnvEq(GhcVersionMismatch, compileTime, runTime), hscEnv, newHscEnvEq,
8 modifyDynFlags,
15 modifyDynFlags,
9− evalGhcEnv,
16+ fakeDynFlags,
10− runGhcEnv,
11− deps,
12− -- * GHC wrappers
13 prettyPrint,
17 prettyPrint,
14− printRdrName,
18+ runGhcEnv,
15− printName,
16− ParseResult(..), runParser,
17− lookupPackageConfig,
18 textToStringBuffer,
19 textToStringBuffer,
19− stringBufferToByteString,
20 moduleImportPath,
20 moduleImportPath,
21− cgGutsToCoreModule,
21+ HscEnvEq, hscEnv, newHscEnvEq,
22− fingerprintToBS,
23− fingerprintFromStringBuffer,
24− -- * General utilities
25 readFileUtf8,
22 readFileUtf8,
26− hDuplicateTo',
23+ hDuplicateTo,
27− setDefaultHieDir,
24+ cgGutsToCoreModule
28− dontWriteHieFiles
29 ) where
25 ) where
30
26
27+import Config
31import Control.Concurrent
28import Control.Concurrent
32import Data.List.Extra
29import Data.List.Extra
33−import Data.ByteString.Internal (ByteString(..))
34import Data.Maybe
30import Data.Maybe
35import Data.Typeable
31import Data.Typeable
36−import qualified Data.ByteString.Internal as BS
32+#if MIN_GHC_API_VERSION(8,6,0)
37import Fingerprint
33import Fingerprint
34+#endif
35+import GHC
38import GhcMonad
36import GhcMonad
39−import Control.Exception
37+import GhcPlugins hiding (Unique)
40import Data.IORef
38import Data.IORef
41−import Data.Version (showVersion, Version)
39+import Control.Exception
42import FileCleanup
40import FileCleanup
43−import Foreign.Ptr
44−import Foreign.ForeignPtr
45−import Foreign.Storable
46import GHC.IO.BufferedIO (BufferedIO)
41import GHC.IO.BufferedIO (BufferedIO)
47import GHC.IO.Device as IODevice
42import GHC.IO.Device as IODevice
48import GHC.IO.Encoding
43import GHC.IO.Encoding
49import GHC.IO.Exception
44import GHC.IO.Exception
50import GHC.IO.Handle.Types
45import GHC.IO.Handle.Types
51import GHC.IO.Handle.Internals
46import GHC.IO.Handle.Internals
47+import Platform
52import Data.Unique
48import Data.Unique
53import Development.Shake.Classes
49import Development.Shake.Classes
54import qualified Data.Text as T
50import qualified Data.Text as T
55import qualified Data.Text.Encoding as T
51import qualified Data.Text.Encoding as T
56import qualified Data.Text.Encoding.Error as T
52import qualified Data.Text.Encoding.Error as T
57import qualified Data.ByteString as BS
53import qualified Data.ByteString as BS
58−import Lexer
59import StringBuffer
54import StringBuffer
60import System.FilePath
55import 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)
71
56
72−import Development.IDE.GHC.Compat as GHC
73import Development.IDE.Types.Location
57import Development.IDE.Types.Location
74
58
75
59
76----------------------------------------------------------------------
60----------------------------------------------------------------------
77-- GHC setup
61-- GHC setup
78
62
79−-- | Used to modify dyn flags in preference to calling 'setSessionDynFlags',
80−-- since that function also reloads packages (which is very slow).
81modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()
63modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()
82modifyDynFlags f = do
64modifyDynFlags f = do
83 newFlags <- f <$> getSessionDynFlags
65 newFlags <- f <$> getSessionDynFlags
@@ -86,7 +68,6 @@ modifyDynFlags f = do
86 modifySession $ \h ->
68 modifySession $ \h ->
87 h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} }
69 h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} }
88
70
89−-- | Given a 'UnitId' try and find the associated 'PackageConfig' in the environment.
90lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig
71lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig
91lookupPackageConfig unitId env =
72lookupPackageConfig unitId env =
92 lookupPackage' False pkgConfigMap unitId
73 lookupPackage' False pkgConfigMap unitId
@@ -97,134 +78,86 @@ lookupPackageConfig unitId env =
97 getPackageConfigMap $ hsc_dflags env
78 getPackageConfigMap $ hsc_dflags env
98
79
99
80
100−-- | Convert from the @text@ package to the @GHC@ 'StringBuffer'.
81+-- would be nice to do this more efficiently...
101−-- Currently implemented somewhat inefficiently (if it ever comes up in a profile).
102textToStringBuffer :: T.Text -> StringBuffer
82textToStringBuffer :: T.Text -> StringBuffer
103textToStringBuffer = stringToStringBuffer . T.unpack
83textToStringBuffer = stringToStringBuffer . T.unpack
104
84
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
115
85
116−-- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.
117prettyPrint :: Outputable a => a -> String
86prettyPrint :: Outputable a => a -> String
118−prettyPrint = showSDoc unsafeGlobalDynFlags . ppr
87+prettyPrint = showSDoc fakeDynFlags . 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
125
88
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'.
137−runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a)
89+runGhcEnv :: HscEnv -> Ghc a -> IO a
138runGhcEnv env act = do
90runGhcEnv env act = do
139 filesToClean <- newIORef emptyFilesToClean
91 filesToClean <- newIORef emptyFilesToClean
140 dirsToClean <- newIORef mempty
92 dirsToClean <- newIORef mempty
141 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}
93 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}
142 ref <- newIORef env{hsc_dflags=dflags}
94 ref <- newIORef env{hsc_dflags=dflags}
143− res <- unGhc act (Session ref) `finally` do
95+ unGhc act (Session ref) `finally` do
144 cleanTempFiles dflags
96 cleanTempFiles dflags
145 cleanTempDirs dflags
97 cleanTempDirs dflags
146− (,res) <$> readIORef ref
147
98
148−-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.
99+-- Fake DynFlags which are mostly undefined, but define enough to do a
149−-- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory
100+-- little bit.
150−-- @\/usr\/Test@ should be on the include path to find sibling modules.
101+fakeDynFlags :: DynFlags
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+
151−moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath
123+moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath
152-- The call to takeDirectory is required since DAML does not require that
124-- The call to takeDirectory is required since DAML does not require that
153-- the file name matches the module name in the last component.
125-- the file name matches the module name in the last component.
154-- Once that has changed we can get rid of this.
126-- Once that has changed we can get rid of this.
155−moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn
127+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm
156 -- This happens for single-component modules since takeDirectory "A" == "."
128 -- This happens for single-component modules since takeDirectory "A" == "."
157 | modDir == "." = Just pathDir
129 | modDir == "." = Just pathDir
158 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir
130 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir
159 where
131 where
132+ ms = GHC.pm_mod_summary pm
133+ mod' = GHC.ms_mod ms
160 -- A for module A.B
134 -- A for module A.B
161 modDir =
135 modDir =
162 takeDirectory $
136 takeDirectory $
163− fromNormalizedFilePath $ toNormalizedFilePath' $
137+ fromNormalizedFilePath $ toNormalizedFilePath $
164− moduleNameSlashes mn
138+ moduleNameSlashes $ GHC.moduleName mod'
165
139
166−-- | An 'HscEnv' with equality. Two values are considered equal
140+-- | An HscEnv with equality.
167−-- if they are created with the same call to 'newHscEnvEq'.
168−data HscEnvEq
169− = HscEnvEq !Unique !HscEnv
141+data HscEnvEq = 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− }
176
142
177−-- | Unwrap an 'HsEnvEq'.
178hscEnv :: HscEnvEq -> HscEnv
143hscEnv :: HscEnvEq -> HscEnv
179−hscEnv = either error id . hscEnv'
180−
181−hscEnv' :: HscEnvEq -> Either String HscEnv
182−hscEnv' (HscEnvEq _ x _) = Right x
144+hscEnv (HscEnvEq _ x) = 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{} = []
195
145
196−-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
197−newHscEnvEq :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
146+newHscEnvEq :: HscEnv -> IO HscEnvEq
198−newHscEnvEq e uids = do u <- newUnique; return $ HscEnvEq u e uids
147+newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e
199
148
200instance Show HscEnvEq where
149instance Show HscEnvEq where
201− show (HscEnvEq a _ _) = "HscEnvEq " ++ show (hashUnique a)
150+ show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)
202− show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)
203
151
204instance Eq HscEnvEq where
152instance Eq HscEnvEq where
205− HscEnvEq a _ _ == HscEnvEq b _ _ = a == b
153+ HscEnvEq a _ == HscEnvEq b _ = a == b
206− GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d
207− _ == _ = False
208
154
209instance NFData HscEnvEq where
155instance NFData HscEnvEq where
210− rnf (HscEnvEq a b c) = rnf (hashUnique a) `seq` b `seq` c `seq` ()
156+ rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()
211− rnf GhcVersionMismatch{} = rnf runTime
212
157
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.
224readFileUtf8 :: FilePath -> IO T.Text
158readFileUtf8 :: FilePath -> IO T.Text
225readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f
159readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f
226
160
227−-- | Convert from a 'CgGuts' to a 'CoreModule'.
228cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule
161cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule
229cgGutsToCoreModule safeMode guts modDetails = CoreModule
162cgGutsToCoreModule safeMode guts modDetails = CoreModule
230 (cg_module guts)
163 (cg_module guts)
@@ -232,24 +165,10 @@ cgGutsToCoreModule safeMode guts modDetails = CoreModule
232 (cg_binds guts)
165 (cg_binds guts)
233 safeMode
166 safeMode
234
167
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−
249−-- | A slightly modified version of 'hDuplicateTo' from GHC.
168+-- This is a slightly modified version of hDuplicateTo in GHC.
250−-- Importantly, it avoids the bug listed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2318.
169+-- See the inline comment for more details.
251−hDuplicateTo' :: Handle -> Handle -> IO ()
170+hDuplicateTo :: Handle -> Handle -> IO ()
252−hDuplicateTo' h1@(FileHandle path m1) h2@(FileHandle _ m2) = do
171+hDuplicateTo h1@(FileHandle path m1) h2@(FileHandle _ m2) = do
253 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
172 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
254 -- The implementation in base has this call to hClose_help.
173 -- The implementation in base has this call to hClose_help.
255 -- _ <- hClose_help h2_
174 -- _ <- hClose_help h2_
@@ -262,7 +181,7 @@ hDuplicateTo' h1@(FileHandle path m1) h2@(FileHandle _ m2) = do
262 -- if it happens just in the right moment.
181 -- if it happens just in the right moment.
263 withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do
182 withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do
264 dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer)
183 dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer)
265−hDuplicateTo' h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2) = do
184+hDuplicateTo h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2) = do
266 withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
185 withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
267 _ <- hClose_help w2_
186 _ <- hClose_help w2_
268 withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do
187 withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do
@@ -271,7 +190,7 @@ hDuplicateTo' h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2) = do
271 _ <- hClose_help r2_
190 _ <- hClose_help r2_
272 withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do
191 withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do
273 dupHandleTo path h1 (Just w1) r2_ r1_ Nothing
192 dupHandleTo path h1 (Just w1) r2_ r1_ Nothing
274−hDuplicateTo' h1 _ =
193+hDuplicateTo h1 _ =
275 ioe_dupHandlesNotCompatible h1
194 ioe_dupHandlesNotCompatible h1
276
195
277-- | This is copied unmodified from GHC since it is not exposed.
196-- | This is copied unmodified from GHC since it is not exposed.
src/Development/IDE/GHC/WithDynFlags.hsdeleted−30
@@ -1,30 +0,0 @@
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+34−121
@@ -9,33 +9,26 @@ module Development.IDE.Import.DependencyInformation
9 , ModuleParseError(..)
9 , ModuleParseError(..)
10 , TransitiveDependencies(..)
10 , TransitiveDependencies(..)
11 , FilePathId(..)
11 , FilePathId(..)
12− , NamedModuleDep(..)
13
12
14 , PathIdMap
13 , PathIdMap
15 , emptyPathIdMap
14 , emptyPathIdMap
16 , getPathId
15 , getPathId
17− , lookupPathToId
18 , insertImport
16 , insertImport
19 , pathToId
17 , pathToId
20 , idToPath
18 , idToPath
21 , reachableModules
19 , reachableModules
20+
22 , processDependencyInformation
21 , processDependencyInformation
23 , transitiveDeps
22 , transitiveDeps
24−
25− , BootIdMap
26− , insertBootId
27 ) where
23 ) where
28
24
29import Control.DeepSeq
25import Control.DeepSeq
30import Data.Bifunctor
26import Data.Bifunctor
31import Data.Coerce
27import Data.Coerce
32import Data.List
28import Data.List
33−import Data.Tuple.Extra hiding (first, second)
34import Development.IDE.GHC.Orphans()
29import Development.IDE.GHC.Orphans()
35import Data.Either
30import Data.Either
36import Data.Graph
31import Data.Graph
37−import Data.HashMap.Strict (HashMap)
38−import qualified Data.HashMap.Strict as HMS
39import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
32import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
40import qualified Data.List.NonEmpty as NonEmpty
33import qualified Data.List.NonEmpty as NonEmpty
41import Data.IntMap (IntMap)
34import Data.IntMap (IntMap)
@@ -43,14 +36,16 @@ import qualified Data.IntMap.Strict as IntMap
43import qualified Data.IntMap.Lazy as IntMapLazy
36import qualified Data.IntMap.Lazy as IntMapLazy
44import Data.IntSet (IntSet)
37import Data.IntSet (IntSet)
45import qualified Data.IntSet as IntSet
38import qualified Data.IntSet as IntSet
39+import Data.Map (Map)
40+import qualified Data.Map.Strict as MS
46import Data.Maybe
41import Data.Maybe
47import Data.Set (Set)
42import Data.Set (Set)
48import qualified Data.Set as Set
43import qualified Data.Set as Set
44+import Data.Tuple.Extra (fst3)
49import GHC.Generics (Generic)
45import GHC.Generics (Generic)
50
46
51import Development.IDE.Types.Diagnostics
47import Development.IDE.Types.Diagnostics
52import Development.IDE.Types.Location
48import Development.IDE.Types.Location
53−import Development.IDE.Import.FindImports (ArtifactsLocation(..))
54
49
55import GHC
50import GHC
56import Module
51import Module
@@ -62,100 +57,69 @@ data ModuleImports = ModuleImports
62 -- that module on disk (if we found it)
57 -- that module on disk (if we found it)
63 , packageImports :: !(Set InstalledUnitId)
58 , packageImports :: !(Set InstalledUnitId)
64 -- ^ Transitive package dependencies unioned for all imports.
59 -- ^ Transitive package dependencies unioned for all imports.
65− } deriving Show
60+ }
66
61
67−-- | For processing dependency information, we need lots of maps and sets of
62+-- | For processing dependency information, we need lots of maps and sets
68−-- filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet
63+-- of filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet
69−-- instead and only convert at the edges.
64+-- instead and only convert at the edges
65+-- and
70newtype FilePathId = FilePathId { getFilePathId :: Int }
66newtype FilePathId = FilePathId { getFilePathId :: Int }
71 deriving (Show, NFData, Eq, Ord)
67 deriving (Show, NFData, Eq, Ord)
72
68
73−-- | Map from 'FilePathId'
74−type FilePathIdMap = IntMap
75−
76−-- | Set of 'FilePathId's
77−type FilePathIdSet = IntSet
78−
79data PathIdMap = PathIdMap
69data PathIdMap = PathIdMap
80− { idToPathMap :: !(FilePathIdMap ArtifactsLocation)
70+ { idToPathMap :: !(IntMap NormalizedFilePath)
81− , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)
71+ , pathToIdMap :: !(Map NormalizedFilePath FilePathId)
82 }
72 }
83 deriving (Show, Generic)
73 deriving (Show, Generic)
84
74
85instance NFData PathIdMap
75instance NFData PathIdMap
86
76
87emptyPathIdMap :: PathIdMap
77emptyPathIdMap :: PathIdMap
88−emptyPathIdMap = PathIdMap IntMap.empty HMS.empty
78+emptyPathIdMap = PathIdMap IntMap.empty MS.empty
89
79
90−getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap)
80+getPathId :: NormalizedFilePath -> PathIdMap -> (FilePathId, PathIdMap)
91getPathId path m@PathIdMap{..} =
81getPathId path m@PathIdMap{..} =
92− case HMS.lookup (artifactFilePath path) pathToIdMap of
82+ case MS.lookup path pathToIdMap of
93 Nothing ->
83 Nothing ->
94− let !newId = FilePathId $ HMS.size pathToIdMap
84+ let !newId = FilePathId $ MS.size pathToIdMap
95 in (newId, insertPathId path newId m)
85 in (newId, insertPathId path newId m)
96 Just id -> (id, m)
86 Just id -> (id, m)
97
87
98−insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap
88+insertPathId :: NormalizedFilePath -> FilePathId -> PathIdMap -> PathIdMap
99insertPathId path id PathIdMap{..} =
89insertPathId path id PathIdMap{..} =
100− PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert (artifactFilePath path) id pathToIdMap)
90+ PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (MS.insert path id pathToIdMap)
101
91
102insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation
92insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation
103insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }
93insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }
104
94
105pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId
95pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId
106−pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path
96+pathToId PathIdMap{pathToIdMap} path = pathToIdMap MS.! path
107−
108−lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId
109−lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap
110
97
111idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath
98idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath
112−idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId
113−
114−idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation
115−idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id
99+idToPath 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)
121
100
122-- | Unprocessed results that we find by following imports recursively.
101-- | Unprocessed results that we find by following imports recursively.
123data RawDependencyInformation = RawDependencyInformation
102data RawDependencyInformation = RawDependencyInformation
124− { rawImports :: !(FilePathIdMap (Either ModuleParseError ModuleImports))
103+ { rawImports :: !(IntMap (Either ModuleParseError ModuleImports))
125 , rawPathIdMap :: !PathIdMap
104 , rawPathIdMap :: !PathIdMap
126− -- The rawBootMap maps the FilePathId of a hs-boot file to its
105+ }
127− -- corresponding hs file. It is used when topologically sorting as we
106+
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−
133−pkgDependencies :: RawDependencyInformation -> FilePathIdMap (Set InstalledUnitId)
107+pkgDependencies :: RawDependencyInformation -> IntMap (Set InstalledUnitId)
134pkgDependencies RawDependencyInformation{..} =
108pkgDependencies RawDependencyInformation{..} =
135 IntMap.map (either (const Set.empty) packageImports) rawImports
109 IntMap.map (either (const Set.empty) packageImports) rawImports
136
110
137data DependencyInformation =
111data DependencyInformation =
138 DependencyInformation
112 DependencyInformation
139− { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError))
113+ { depErrorNodes :: !(IntMap (NonEmpty NodeError))
140 -- ^ Nodes that cannot be processed correctly.
114 -- ^ Nodes that cannot be processed correctly.
141− , depModuleNames :: !(FilePathIdMap ShowableModuleName)
142− , depModuleDeps :: !(FilePathIdMap FilePathIdSet)
115+ , depModuleDeps :: !(IntMap IntSet)
143 -- ^ For a non-error node, this contains the set of module immediate dependencies
116 -- ^ For a non-error node, this contains the set of module immediate dependencies
144 -- in the same package.
117 -- in the same package.
145− , depPkgDeps :: !(FilePathIdMap (Set InstalledUnitId))
118+ , depPkgDeps :: !(IntMap (Set InstalledUnitId))
146 -- ^ For a non-error node, this contains the set of immediate pkg deps.
119 -- ^ For a non-error node, this contains the set of immediate pkg deps.
147 , depPathIdMap :: !PathIdMap
120 , depPathIdMap :: !PathIdMap
148− -- ^ Map from FilePath to FilePathId
149− , depBootMap :: !BootIdMap
150− -- ^ Map from hs-boot file to the corresponding hs file
151 } deriving (Show, Generic)
121 } deriving (Show, Generic)
152
122
153−newtype ShowableModuleName =
154− ShowableModuleName {showableModuleName :: ModuleName}
155− deriving NFData
156−
157−instance Show ShowableModuleName where show = moduleNameString . showableModuleName
158−
159reachableModules :: DependencyInformation -> [NormalizedFilePath]
123reachableModules :: DependencyInformation -> [NormalizedFilePath]
160reachableModules DependencyInformation{..} =
124reachableModules DependencyInformation{..} =
161 map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps
125 map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps
@@ -222,32 +186,23 @@ processDependencyInformation rawDepInfo@RawDependencyInformation{..} =
222 DependencyInformation
186 DependencyInformation
223 { depErrorNodes = IntMap.fromList errorNodes
187 { depErrorNodes = IntMap.fromList errorNodes
224 , depModuleDeps = moduleDeps
188 , depModuleDeps = moduleDeps
225− , depModuleNames = IntMap.fromList $ coerce moduleNames
226 , depPkgDeps = pkgDependencies rawDepInfo
189 , depPkgDeps = pkgDependencies rawDepInfo
227 , depPathIdMap = rawPathIdMap
190 , depPathIdMap = rawPathIdMap
228− , depBootMap = rawBootMap
229 }
191 }
230 where resultGraph = buildResultGraph rawImports
192 where resultGraph = buildResultGraph rawImports
231 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph
193 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph
232− moduleNames :: [(FilePathId, ModuleName)]
233− moduleNames =
234− [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports]
235 successEdges :: [(FilePathId, FilePathId, [FilePathId])]
194 successEdges :: [(FilePathId, FilePathId, [FilePathId])]
236 successEdges =
195 successEdges =
237− map
238− (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports))
196+ map (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports)) successNodes
239− successNodes
240 moduleDeps =
197 moduleDeps =
241− IntMap.fromList $
242− map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs))
198+ IntMap.fromList $ map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs)) successEdges
243− successEdges
244
199
245-- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:
200-- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:
246-- 1. Mark each node that is part of an import cycle as an error node.
201-- 1. Mark each node that is part of an import cycle as an error node.
247-- 2. Mark each node that has a parse error as an error node.
202-- 2. Mark each node that has a parse error as an error node.
248-- 3. Mark each node whose immediate children could not be located as an error.
203-- 3. Mark each node whose immediate children could not be located as an error.
249-- 4. Recursively propagate errors to parents if they are not already error nodes.
204-- 4. Recursively propagate errors to parents if they are not already error nodes.
250−buildResultGraph :: FilePathIdMap (Either ModuleParseError ModuleImports) -> FilePathIdMap NodeResult
205+buildResultGraph :: IntMap (Either ModuleParseError ModuleImports) -> IntMap NodeResult
251buildResultGraph g = propagatedErrors
206buildResultGraph g = propagatedErrors
252 where
207 where
253 sccs = stronglyConnComp (graphEdges g)
208 sccs = stronglyConnComp (graphEdges g)
@@ -294,7 +249,7 @@ buildResultGraph g = propagatedErrors
294 Right ModuleImports{moduleImports} ->
249 Right ModuleImports{moduleImports} ->
295 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports
250 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports
296
251
297−graphEdges :: FilePathIdMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]
252+graphEdges :: IntMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]
298graphEdges g =
253graphEdges g =
299 map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g
254 map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g
300 where deps :: Either e ModuleImports -> [FilePathId]
255 where deps :: Either e ModuleImports -> [FilePathId]
@@ -306,71 +261,29 @@ partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest
306partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest
261partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest
307partitionSCC [] = ([], [])
262partitionSCC [] = ([], [])
308
263
309−
310transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
264transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
311transitiveDeps DependencyInformation{..} file = do
265transitiveDeps DependencyInformation{..} file = do
312 let !fileId = pathToId depPathIdMap file
266 let !fileId = pathToId depPathIdMap file
313 reachableVs <-
267 reachableVs <-
314− -- Delete the starting node
315 IntSet.delete (getFilePathId fileId) .
268 IntSet.delete (getFilePathId fileId) .
316 IntSet.fromList . map (fst3 . fromVertex) .
269 IntSet.fromList . map (fst3 . fromVertex) .
317 reachable g <$> toVertex (getFilePathId fileId)
270 reachable g <$> toVertex (getFilePathId fileId)
318− let transitiveModuleDepIds =
319− filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs
271+ let transitiveModuleDepIds = filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs
320 let transitivePkgDeps =
272 let transitivePkgDeps =
321 Set.toList $ Set.unions $
273 Set.toList $ Set.unions $
322 map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $
274 map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $
323 getFilePathId fileId : transitiveModuleDepIds
275 getFilePathId fileId : transitiveModuleDepIds
324− let transitiveModuleDeps =
325− map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds
276+ let transitiveModuleDeps = 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− ]
331 pure TransitiveDependencies {..}
277 pure TransitiveDependencies {..}
332− where
333− (g, fromVertex, toVertex) = graphFromEdges edges
334− edges = map (\(f, fs) -> (f, f, IntSet.toList fs ++ boot_edge f)) $ IntMap.toList depModuleDeps
278+ where (g, fromVertex, toVertex) = graphFromEdges (map (\(f, fs) -> (f, f, IntSet.toList fs)) $ 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−
342− vs = topSort g
279+ vs = topSort g
343
280
344data TransitiveDependencies = TransitiveDependencies
281data TransitiveDependencies = TransitiveDependencies
345 { transitiveModuleDeps :: [NormalizedFilePath]
282 { transitiveModuleDeps :: [NormalizedFilePath]
346 -- ^ Transitive module dependencies in topological order.
283 -- ^ Transitive module dependencies in topological order.
347 -- The module itself is not included.
284 -- The module itself is not included.
348− , transitiveNamedModuleDeps :: [NamedModuleDep]
349− -- ^ Transitive module dependencies in topological order.
350− -- The module itself is not included.
351 , transitivePkgDeps :: [InstalledUnitId]
285 , transitivePkgDeps :: [InstalledUnitId]
352 -- ^ Transitive pkg dependencies in unspecified order.
286 -- ^ Transitive pkg dependencies in unspecified order.
353 } deriving (Eq, Show, Generic)
287 } deriving (Eq, Show, Generic)
354
288
355instance NFData TransitiveDependencies
289instance 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+17−63
@@ -7,19 +7,16 @@
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
14 ) where
10 ) where
15
11
16import Development.IDE.GHC.Error as ErrUtils
12import Development.IDE.GHC.Error as ErrUtils
17import Development.IDE.GHC.Orphans()
13import Development.IDE.GHC.Orphans()
18import Development.IDE.Types.Diagnostics
14import Development.IDE.Types.Diagnostics
19import Development.IDE.Types.Location
15import Development.IDE.Types.Location
20−import Development.IDE.GHC.Compat
21-- GHC imports
16-- GHC imports
17+import DynFlags
22import FastString
18import FastString
19+import GHC
23import qualified Module as M
20import qualified Module as M
24import Packages
21import Packages
25import Outputable (showSDoc, ppr, pprPanic)
22import Outputable (showSDoc, ppr, pprPanic)
@@ -30,107 +27,64 @@ import Control.DeepSeq
30import Control.Monad.Extra
27import Control.Monad.Extra
31import Control.Monad.IO.Class
28import Control.Monad.IO.Class
32import System.FilePath
29import System.FilePath
33−import DriverPhases
34−import Data.Maybe
35
30
36data Import
31data Import
37− = FileImport !ArtifactsLocation
32+ = FileImport !NormalizedFilePath
38 | PackageImport !M.InstalledUnitId
33 | PackageImport !M.InstalledUnitId
39 deriving (Show)
34 deriving (Show)
40
35
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−
54instance NFData Import where
36instance NFData Import where
55 rnf (FileImport x) = rnf x
37 rnf (FileImport x) = rnf x
56 rnf (PackageImport x) = rnf x
38 rnf (PackageImport x) = rnf x
57
39
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−
64
40
65-- | locate a module in the file system. Where we go from *daml to Haskell
41-- | locate a module in the file system. Where we go from *daml to Haskell
66locateModuleFile :: MonadIO m
42locateModuleFile :: MonadIO m
67− => [[FilePath]]
43+ => DynFlags
68 -> [String]
44 -> [String]
69 -> (NormalizedFilePath -> m Bool)
45 -> (NormalizedFilePath -> m Bool)
70 -> Bool
46 -> Bool
71 -> ModuleName
47 -> ModuleName
72 -> m (Maybe NormalizedFilePath)
48 -> m (Maybe NormalizedFilePath)
73−locateModuleFile import_dirss exts doesExist isSource modName = do
49+locateModuleFile dflags exts doesExist isSource modName = do
74− let candidates import_dirs =
50+ let candidates =
75− [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)
51+ [ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)
76− | prefix <- import_dirs , ext <- exts]
52+ | prefix <- importPaths dflags, ext <- exts]
77− findM doesExist (concatMap candidates import_dirss)
53+ findM doesExist candidates
78 where
54 where
79 maybeBoot ext
55 maybeBoot ext
80 | isSource = ext ++ "-boot"
56 | isSource = ext ++ "-boot"
81 | otherwise = ext
57 | otherwise = ext
82
58
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−
90-- | locate a module in either the file system or the package database. Where we go from *daml to
59-- | locate a module in either the file system or the package database. Where we go from *daml to
91-- Haskell
60-- Haskell
92locateModule
61locateModule
93 :: MonadIO m
62 :: MonadIO m
94 => DynFlags
63 => DynFlags
95− -> [(M.InstalledUnitId, DynFlags)] -- Sets import directories to look in
96 -> [String]
64 -> [String]
97 -> (NormalizedFilePath -> m Bool)
65 -> (NormalizedFilePath -> m Bool)
98 -> Located ModuleName
66 -> Located ModuleName
99 -> Maybe FastString
67 -> Maybe FastString
100 -> Bool
68 -> Bool
101 -> m (Either [FileDiagnostic] Import)
69 -> m (Either [FileDiagnostic] Import)
102−locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do
70+locateModule dflags exts doesExist modName mbPkgName isSource = do
103 case mbPkgName of
71 case mbPkgName of
104 -- "this" means that we should only look in the current package
72 -- "this" means that we should only look in the current package
105 Just "this" -> do
73 Just "this" -> do
106− lookupLocal [importPaths dflags]
74+ mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName
75+ case mbFile of
76+ Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []
77+ Just file -> return $ Right $ FileImport file
107 -- if a package name is given we only go look for a package
78 -- 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]
111− | otherwise -> lookupInPackageDB dflags
79+ Just _pkgName -> lookupInPackageDB dflags
112 Nothing -> do
80 Nothing -> do
113 -- first try to find the module as a file. If we can't find it try to find it in the package
81 -- first try to find the module as a file. If we can't find it try to find it in the package
114 -- database.
82 -- 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.
118− mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts doesExist isSource $ unLoc modName
83+ mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName
119 case mbFile of
84 case mbFile of
120 Nothing -> lookupInPackageDB dflags
85 Nothing -> lookupInPackageDB dflags
121− Just file -> toModLocation file
86+ Just file -> return $ Right $ FileImport file
122 where
87 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−
134 lookupInPackageDB dfs =
88 lookupInPackageDB dfs =
135 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of
89 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of
136 LookupFound _m pkgConfig -> return $ Right $ PackageImport $ unitId pkgConfig
90 LookupFound _m pkgConfig -> return $ Right $ PackageImport $ unitId pkgConfig
src/Development/IDE/LSP/CodeAction.hsnew file+285
@@ -0,0 +1,285 @@
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.hsnew file+43
@@ -0,0 +1,43 @@
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.hsnew file+47
@@ -0,0 +1,47 @@
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.hsdeleted−62
@@ -1,62 +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.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+32−58
@@ -28,30 +28,27 @@ 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.Core.IdeConfiguration
31+import Development.IDE.LSP.Definition
32−import Development.IDE.Core.Shake
32+import Development.IDE.LSP.Hover
33−import Development.IDE.LSP.HoverDefinition
33+import Development.IDE.LSP.CodeAction
34import Development.IDE.LSP.Notifications
34import Development.IDE.LSP.Notifications
35−import Development.IDE.LSP.Outline
35+import Development.IDE.Core.Service
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)
43− => LSP.Options
42+ :: LSP.Options
44− -> PartialHandlers config
43+ -> PartialHandlers
45− -> (InitializeRequest -> Either T.Text config)
46− -> (DidChangeConfigurationNotification -> Either T.Text config)
47 -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)
44 -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)
48 -> IO ()
45 -> IO ()
49−runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do
46+runLanguageServer options userHandlers getIdeState = do
50 -- Move stdout to another file descriptor and duplicate stderr
47 -- Move stdout to another file descriptor and duplicate stderr
51 -- to stdout. This guards against stray prints from corrupting the JSON-RPC
48 -- to stdout. This guards against stray prints from corrupting the JSON-RPC
52 -- message stream.
49 -- message stream.
53 newStdout <- hDuplicate stdout
50 newStdout <- hDuplicate stdout
54− stderr `Ghcide.hDuplicateTo'` stdout
51+ stderr `Ghcide.hDuplicateTo` stdout
55 hSetBuffering stderr NoBuffering
52 hSetBuffering stderr NoBuffering
56 hSetBuffering stdout NoBuffering
53 hSetBuffering stdout NoBuffering
57
54
@@ -63,7 +60,7 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
63
60
64 -- Send everything over a channel, since you need to wait until after initialise before
61 -- Send everything over a channel, since you need to wait until after initialise before
65 -- LspFuncs is available
62 -- LspFuncs is available
66− clientMsgChan :: Chan (Message config) <- newChan
63+ clientMsgChan :: Chan Message <- newChan
67
64
68 -- These barriers are signaled when the threads reading from these chans exit.
65 -- These barriers are signaled when the threads reading from these chans exit.
69 -- This should not happen but if it does, we will make sure that the whole server
66 -- This should not happen but if it does, we will make sure that the whole server
@@ -82,7 +79,6 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
82 let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do
79 let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do
83 atomically $ modifyTVar pendingRequests (Set.insert _id)
80 atomically $ modifyTVar pendingRequests (Set.insert _id)
84 writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f
81 writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f
85− let withInitialize f = Just $ \r -> writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x)
86 let cancelRequest reqId = atomically $ do
82 let cancelRequest reqId = atomically $ do
87 queued <- readTVar pendingRequests
83 queued <- readTVar pendingRequests
88 -- We want to avoid that the list of cancelled requests
84 -- We want to avoid that the list of cancelled requests
@@ -99,20 +95,19 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
99 cancelled <- readTVar cancelledRequests
95 cancelled <- readTVar cancelledRequests
100 unless (reqId `Set.member` cancelled) retry
96 unless (reqId `Set.member` cancelled) retry
101 let PartialHandlers parts =
97 let PartialHandlers parts =
102− initializeRequestHandler <>
103 setHandlersIgnore <> -- least important
98 setHandlersIgnore <> -- least important
104 setHandlersDefinition <> setHandlersHover <>
99 setHandlersDefinition <> setHandlersHover <>
105− setHandlersOutline <>
100+ setHandlersCodeAction <> setHandlersCodeLens <> -- useful features someone may override
106 userHandlers <>
101 userHandlers <>
107 setHandlersNotifications <> -- absolutely critical, join them with user notifications
102 setHandlersNotifications <> -- absolutely critical, join them with user notifications
108 cancelHandler cancelRequest
103 cancelHandler cancelRequest
109 -- Cancel requests are special since they need to be handled
104 -- Cancel requests are special since they need to be handled
110 -- out of order to be useful. Existing handlers are run afterwards.
105 -- out of order to be useful. Existing handlers are run afterwards.
111− handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def
106+ handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def
112
107
113 let initializeCallbacks = LSP.InitializeCallbacks
108 let initializeCallbacks = LSP.InitializeCallbacks
114− { LSP.onInitialConfiguration = onInitialConfig
109+ { LSP.onInitialConfiguration = const $ Right ()
115− , LSP.onConfigurationChange = onConfigChange
110+ , LSP.onConfigurationChange = const $ Right ()
116 , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan
111 , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan
117 }
112 }
118
113
@@ -127,11 +122,9 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
127 , void $ waitBarrier clientMsgBarrier
122 , void $ waitBarrier clientMsgBarrier
128 ]
123 ]
129 where
124 where
130− handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan (Message config) -> LSP.LspFuncs config -> IO (Maybe err)
125+ handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs () -> IO (Maybe err)
131 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
126 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
132−
133 ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities
127 ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities
134−
135 _ <- flip forkFinally (const exitClientMsg) $ forever $ do
128 _ <- flip forkFinally (const exitClientMsg) $ forever $ do
136 msg <- readChan clientMsgChan
129 msg <- readChan clientMsgChan
137 case msg of
130 case msg of
@@ -142,25 +135,17 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
142 "Message: " ++ show x ++ "\n" ++
135 "Message: " ++ show x ++ "\n" ++
143 "Exception: " ++ show e
136 "Exception: " ++ show e
144 Response x@RequestMessage{_id, _params} wrap act ->
137 Response x@RequestMessage{_id, _params} wrap act ->
145− checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
138+ checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
146− \case
147− Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)
139+ \res -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
148− Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)
149 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->
140 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->
150 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
141 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
151 \(res, newReq) -> do
142 \(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)
155− whenJust newReq $ \(rm, newReqParams) -> do
146+ Just (rm, newReqParams) -> do
156 reqId <- getNextReqId
147 reqId <- getNextReqId
157 sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams
148 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
164 pure Nothing
149 pure Nothing
165
150
166 checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =
151 checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =
@@ -175,39 +160,28 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
175 Left () -> do
160 Left () -> do
176 logDebug (ideLogger ide) $ T.pack $
161 logDebug (ideLogger ide) $ T.pack $
177 "Cancelled request " <> show _id
162 "Cancelled request " <> show _id
178− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left
163+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
179− $ ResponseError RequestCancelled "" Nothing
164+ Just $ ResponseError RequestCancelled "" Nothing
180 Right res -> k res
165 Right res -> k res
181 ) $ \(e :: SomeException) -> do
166 ) $ \(e :: SomeException) -> do
182 logError (ideLogger ide) $ T.pack $
167 logError (ideLogger ide) $ T.pack $
183 "Unexpected exception on request, please report!\n" ++
168 "Unexpected exception on request, please report!\n" ++
184 "Message: " ++ show msg ++ "\n" ++
169 "Message: " ++ show msg ++ "\n" ++
185 "Exception: " ++ show e
170 "Exception: " ++ show e
186− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left
171+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
187− $ ResponseError InternalError (T.pack $ show e) Nothing
172+ Just $ ResponseError InternalError (T.pack $ show e) Nothing
188
173
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)
200
174
201-- | Things that get sent to us, but we don't deal with.
175-- | Things that get sent to us, but we don't deal with.
202-- Set them to avoid a warning in VS Code output.
176-- Set them to avoid a warning in VS Code output.
203−setHandlersIgnore :: PartialHandlers config
177+setHandlersIgnore :: PartialHandlers
204setHandlersIgnore = PartialHandlers $ \_ x -> return x
178setHandlersIgnore = PartialHandlers $ \_ x -> return x
205 {LSP.initializedHandler = none
179 {LSP.initializedHandler = none
206 ,LSP.responseHandler = none
180 ,LSP.responseHandler = none
207 }
181 }
208 where none = Just $ const $ return ()
182 where none = Just $ const $ return ()
209
183
210−cancelHandler :: (LspId -> IO ()) -> PartialHandlers config
184+cancelHandler :: (LspId -> IO ()) -> PartialHandlers
211cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
185cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
212 {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do
186 {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do
213 cancelRequest _id
187 cancelRequest _id
@@ -217,18 +191,18 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
217
191
218-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
192-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
219-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
193-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
220−data Message c
194+data Message
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))
195+ = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO resp)
222 -- | Used for cases in which we need to send not only a response,
196 -- | Used for cases in which we need to send not only a response,
223 -- but also an additional request to the client.
197 -- but also an additional request to the client.
224 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
198 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
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)))
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)))
226− | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())
200+ | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ())
227− -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler.
201+
228− | InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
229
202
230modifyOptions :: LSP.Options -> LSP.Options
203modifyOptions :: LSP.Options -> LSP.Options
231modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS
204modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS
205+ , LSP.executeCommandCommands = Just ["typesignature.add"]
232 }
206 }
233 where
207 where
234 tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}
208 tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}
src/Development/IDE/LSP/Notifications.hs+13−39
@@ -2,37 +2,32 @@
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 Development.IDE.LSP.Server
12−import qualified Language.Haskell.LSP.Core as LSP
13import Language.Haskell.LSP.Types
11import Language.Haskell.LSP.Types
12+import Development.IDE.LSP.Server
13+import qualified Language.Haskell.LSP.Core as LSP
14−import qualified Language.Haskell.LSP.Types as LSP
14+import qualified Language.Haskell.LSP.Types as LSP
15
15
16−import Development.IDE.Core.IdeConfiguration
16+import Development.IDE.Types.Logger
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
20
19
21−import Control.Monad.Extra
20+import Control.Monad.Extra
22−import Data.Foldable as F
23−import Data.Maybe
24−import qualified Data.HashSet as S
21+import qualified Data.Set as S
25−import qualified Data.Text as Text
26
22
27−import Development.IDE.Core.FileStore (setSomethingModified)
23+import Development.IDE.Core.FileStore
28−import Development.IDE.Core.FileExists (modifyFileExists)
29−import Development.IDE.Core.OfInterest
24+import Development.IDE.Core.OfInterest
30
25
31
26
32whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
27whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
33−whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'
28+whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath
34
29
35−setHandlersNotifications :: PartialHandlers c
30+setHandlersNotifications :: PartialHandlers
36setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
31setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
37 {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $
32 {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $
38 \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do
33 \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do
@@ -57,25 +52,4 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
57 whenUriFile _uri $ \file -> do
52 whenUriFile _uri $ \file -> do
58 modifyFilesOfInterest ide (S.delete file)
53 modifyFilesOfInterest ide (S.delete file)
59 logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri
54 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))
81 }
55 }
src/Development/IDE/LSP/Outline.hsdeleted−234
@@ -1,234 +0,0 @@
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+10−11
@@ -16,32 +16,31 @@ 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+
19−data WithMessage c = WithMessage
20+data WithMessage = WithMessage
20 {withResponse :: forall m req resp . (Show m, Show req) =>
21 {withResponse :: forall m req resp . (Show m, Show req) =>
21 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
22 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
22− (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work
23+ (LSP.LspFuncs () -> IdeState -> req -> IO resp) -> -- actual work
23 Maybe (LSP.Handler (RequestMessage m req resp))
24 Maybe (LSP.Handler (RequestMessage m req resp))
24 ,withNotification :: forall m req . (Show m, Show req) =>
25 ,withNotification :: forall m req . (Show m, Show req) =>
25 Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler
26 Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler
26− (LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work
27+ (LSP.LspFuncs () -> IdeState -> req -> IO ()) -> -- actual work
27 Maybe (LSP.Handler (NotificationMessage m req))
28 Maybe (LSP.Handler (NotificationMessage m req))
28− ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody .
29+ ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
29 (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
30 (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
30 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
31 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
31 (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req
32 (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req
32− (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work
33+ (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work
33 Maybe (LSP.Handler (RequestMessage m req resp))
34 Maybe (LSP.Handler (RequestMessage m req resp))
34− , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
35− -> Maybe (LSP.Handler InitializeRequest)
36 }
35 }
37
36
38−newtype PartialHandlers c = PartialHandlers (WithMessage c -> LSP.Handlers -> IO LSP.Handlers)
37+newtype PartialHandlers = PartialHandlers (WithMessage -> LSP.Handlers -> IO LSP.Handlers)
39
38
40−instance Default (PartialHandlers c) where
39+instance Default PartialHandlers where
41 def = PartialHandlers $ \_ x -> pure x
40 def = PartialHandlers $ \_ x -> pure x
42
41
43−instance Semigroup (PartialHandlers c) where
42+instance Semigroup PartialHandlers where
44 PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w
43 PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w
45
44
46−instance Monoid (PartialHandlers c) where
45+instance Monoid PartialHandlers where
47 mempty = def
46 mempty = def
src/Development/IDE/Plugin.hsdeleted−60
@@ -1,60 +0,0 @@
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.hsdeleted−570
@@ -1,570 +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.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.hsdeleted−112
@@ -1,112 +0,0 @@
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.hsdeleted−61
@@ -1,61 +0,0 @@
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.hsdeleted−61
@@ -1,61 +0,0 @@
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.hsdeleted−103
@@ -1,103 +0,0 @@
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.hsdeleted−530
@@ -1,530 +0,0 @@
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.hsdeleted−58
@@ -1,58 +0,0 @@
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+53−87
@@ -8,24 +8,26 @@ module Development.IDE.Spans.AtPoint (
8 , gotoDefinition
8 , gotoDefinition
9 ) where
9 ) where
10
10
11+import Development.IDE.Spans.Documentation
11import Development.IDE.GHC.Error
12import Development.IDE.GHC.Error
12import Development.IDE.GHC.Orphans()
13import Development.IDE.GHC.Orphans()
13import Development.IDE.Types.Location
14import Development.IDE.Types.Location
14
15
15-- DAML compiler and infrastructure
16-- DAML compiler and infrastructure
17+import Development.Shake
18+import Development.IDE.GHC.Util
16import Development.IDE.GHC.Compat
19import Development.IDE.GHC.Compat
17import Development.IDE.Types.Options
20import Development.IDE.Types.Options
18−import Development.IDE.Spans.Type as SpanInfo
21+import Development.IDE.Spans.Type as SpanInfo
19−import Development.IDE.Spans.Common (spanDocToMarkdown)
20
22
21-- GHC API imports
23-- GHC API imports
24+import Avail
25+import GHC
22import DynFlags
26import DynFlags
23import FastString
27import FastString
24import Name
28import Name
25import Outputable hiding ((<>))
29import Outputable hiding ((<>))
26import SrcLoc
30import SrcLoc
27−import Type
28−import VarSet
29
31
30import Control.Monad.Extra
32import Control.Monad.Extra
31import Control.Monad.Trans.Maybe
33import Control.Monad.Trans.Maybe
@@ -37,134 +39,98 @@ import qualified Data.Text as T
37-- | Locate the definition of the name at a given position.
39-- | Locate the definition of the name at a given position.
38gotoDefinition
40gotoDefinition
39 :: MonadIO m
41 :: MonadIO m
40− => (Module -> m (Maybe (HieFile, FilePath)))
42+ => (FilePath -> m (Maybe HieFile))
41 -> IdeOptions
43 -> IdeOptions
44+ -> HscEnv
42 -> [SpanInfo]
45 -> [SpanInfo]
43 -> Position
46 -> Position
44 -> m (Maybe Location)
47 -> m (Maybe Location)
45−gotoDefinition getHieFile ideOpts srcSpans pos =
48+gotoDefinition getHieFile ideOpts pkgState srcSpans pos =
46− listToMaybe <$> locationsAtPoint getHieFile ideOpts pos srcSpans
49+ listToMaybe <$> locationsAtPoint getHieFile ideOpts pkgState pos srcSpans
47
50
48-- | Synopsis for the name at a given position.
51-- | Synopsis for the name at a given position.
49atPoint
52atPoint
50 :: IdeOptions
53 :: IdeOptions
51− -> SpansInfo
54+ -> [TypecheckedModule]
55+ -> [SpanInfo]
52 -> Position
56 -> Position
53 -> Maybe (Maybe Range, [T.Text])
57 -> Maybe (Maybe Range, [T.Text])
54−atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do
58+atPoint IdeOptions{..} tcs srcSpans pos = do
55− firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans
59+ SpanInfo{..} <- listToMaybe $ orderSpans $ spansAtPoint pos srcSpans
56− let constraintsAtPoint = mapMaybe spaninfoType (spansAtPoint pos cntsSpans)
60+ ty <- spaninfoType
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
57− return (Just (range firstSpan), hoverInfo firstSpan constraintsAtPoint)
75+ return (Just range, hoverInfo)
58 where
76 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−
104 -- NOTE(RJR): This is a bit hacky.
77 -- NOTE(RJR): This is a bit hacky.
105 -- We don't want to show the user type signatures generated from Eq and Show
78 -- We don't want to show the user type signatures generated from Eq and Show
106 -- instances, as they do not appear in the source program.
79 -- instances, as they do not appear in the source program.
107 -- However the user could have written an `==` or `show` function directly,
80 -- However the user could have written an `==` or `show` function directly,
108 -- in which case we still want to show information for that.
81 -- in which case we still want to show information for that.
109 -- Hence we just move such information later in the list of spans.
82 -- Hence we just move such information later in the list of spans.
110− deEmpasizeGeneratedEqShow :: [SpanInfo] -> [SpanInfo]
83+ orderSpans :: [SpanInfo] -> [SpanInfo]
111− deEmpasizeGeneratedEqShow = uncurry (++) . partition (not . isTypeclassDeclSpan)
84+ orderSpans = uncurry (++) . partition (not . isTypeclassDeclSpan)
112 isTypeclassDeclSpan :: SpanInfo -> Bool
85 isTypeclassDeclSpan :: SpanInfo -> Bool
113 isTypeclassDeclSpan spanInfo =
86 isTypeclassDeclSpan spanInfo =
114 case getNameM (spaninfoSource spanInfo) of
87 case getNameM (spaninfoSource spanInfo) of
115 Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]
88 Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]
116 Nothing -> False
89 Nothing -> False
117
90
118−locationsAtPoint
91+locationsAtPoint :: forall m . MonadIO m => (FilePath -> m (Maybe HieFile)) -> IdeOptions -> HscEnv -> Position -> [SpanInfo] -> m [Location]
119− :: forall m
120− . MonadIO m
121− => (Module -> m (Maybe (HieFile, FilePath)))
122− -> IdeOptions
123− -> Position
124− -> [SpanInfo]
125− -> m [Location]
126−locationsAtPoint getHieFile _ideOptions pos =
92+locationsAtPoint getHieFile IdeOptions{..} pkgState pos =
93+ fmap (map srcSpanToLocation) .
127− fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos
94+ mapMaybeM (getSpan . spaninfoSource) .
95+ spansAtPoint pos
128 where getSpan :: SpanSource -> m (Maybe SrcSpan)
96 where getSpan :: SpanSource -> m (Maybe SrcSpan)
129 getSpan NoSource = pure Nothing
97 getSpan NoSource = pure Nothing
130 getSpan (SpanS sp) = pure $ Just sp
98 getSpan (SpanS sp) = pure $ Just sp
131− getSpan (Lit _) = pure Nothing
132 getSpan (Named name) = case nameSrcSpan name of
99 getSpan (Named name) = case nameSrcSpan name of
133 sp@(RealSrcSpan _) -> pure $ Just sp
100 sp@(RealSrcSpan _) -> pure $ Just sp
134 sp@(UnhelpfulSpan _) -> runMaybeT $ do
101 sp@(UnhelpfulSpan _) -> runMaybeT $ do
135 guard (sp /= wiredInSrcSpan)
102 guard (sp /= wiredInSrcSpan)
136− -- This case usually arises when the definition is in an external package (DAML only).
103+ -- This case usually arises when the definition is in an external package.
137 -- In this case the interface files contain garbage source spans
104 -- In this case the interface files contain garbage source spans
138 -- so we instead read the .hie files to get useful source spans.
105 -- so we instead read the .hie files to get useful source spans.
139− mod <- MaybeT $ return $ nameModule_maybe name
106+ let mod = nameModule name
107+ let unitId = moduleUnitId mod
108+ pkgConfig <- MaybeT $ pure $ lookupPackageConfig unitId pkgState
109+ hiePath <- MaybeT $ liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod
140− (hieFile, srcPath) <- MaybeT $ getHieFile mod
110+ hieFile <- MaybeT $ getHieFile hiePath
141− avail <- MaybeT $ pure $ find (eqName name . snd) $ hieExportNames hieFile
111+ avail <- MaybeT $ pure $ listToMaybe (filterAvails (eqName name) $ hie_exports hieFile)
112+ srcPath <- MaybeT $ liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod
142 -- The location will point to the source file used during compilation.
113 -- The location will point to the source file used during compilation.
143 -- This file might no longer exists and even if it does the path will be relative
114 -- This file might no longer exists and even if it does the path will be relative
144 -- to the compilation directory which we don’t know.
115 -- to the compilation directory which we don’t know.
145− let span = setFileName srcPath $ fst avail
116+ let span = setFileName srcPath $ nameSrcSpan $ availName avail
146 pure span
117 pure span
147 -- We ignore uniques and source spans and only compare the name and the module.
118 -- We ignore uniques and source spans and only compare the name and the module.
148 eqName :: Name -> Name -> Bool
119 eqName :: Name -> Name -> Bool
149− eqName n n' = nameOccName n == nameOccName n' && nameModule_maybe n == nameModule_maybe n'
120+ eqName n n' = nameOccName n == nameOccName n' && nameModule n == nameModule n'
150 setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })
121 setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })
151 setFileName _ span@(UnhelpfulSpan _) = span
122 setFileName _ span@(UnhelpfulSpan _) = span
152
123
153−-- | Filter out spans which do not enclose a given point
154spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo]
124spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo]
155spansAtPoint pos = filter atp where
125spansAtPoint pos = filter atp where
156 line = _line pos
126 line = _line pos
157 cha = _character pos
127 cha = _character pos
158− atp SpanInfo{..} =
159− startsBeforePosition && endsAfterPosition
160− where
161− startLineCmp = compare spaninfoStartLine line
128+ atp SpanInfo{..} = spaninfoStartLine <= line
162− endLineCmp = compare spaninfoEndLine line
129+ && spaninfoEndLine >= line
163−
164− startsBeforePosition = startLineCmp == LT || (startLineCmp == EQ && spaninfoStartCol <= cha)
130+ && spaninfoStartCol <= cha
165− -- The end col points to the column after the
131+ -- The end col points to the column after the
166− -- last character so we use > instead of >=
132+ -- last character so we use > instead of >=
167− endsAfterPosition = endLineCmp == GT || (endLineCmp == EQ && spaninfoEndCol > cha)
133+ && spaninfoEndCol > cha
168
134
169showName :: Outputable a => a -> T.Text
135showName :: Outputable a => a -> T.Text
170showName = T.pack . prettyprint
136showName = T.pack . prettyprint
src/Development/IDE/Spans/Calculate.hs+64−149
@@ -9,35 +9,29 @@
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) where
12+module Development.IDE.Spans.Calculate(getSrcSpanInfos,listifyAllSpans) 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
17import Data.List
19import Data.List
18import Data.Maybe
20import Data.Maybe
19import DataCon
21import DataCon
20import Desugar
22import Desugar
21import GHC
23import GHC
22import GhcMonad
24import GhcMonad
23−import HscTypes
24import FastString (mkFastString)
25import 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
29import Development.IDE.GHC.Error (zeroSpan)
28import Development.IDE.GHC.Error (zeroSpan)
30−#else
31−import Development.IDE.GHC.Error (zeroSpan, catchSrcErrors)
32−#endif
33import Prelude hiding (mod)
29import Prelude hiding (mod)
34import TcHsSyn
30import TcHsSyn
35import Var
31import Var
36import Development.IDE.Core.Compile
32import Development.IDE.Core.Compile
37−import qualified Development.IDE.GHC.Compat as Compat
38import Development.IDE.GHC.Util
33import Development.IDE.GHC.Util
39−import Development.IDE.Spans.Common
34+
40−import Development.IDE.Spans.Documentation
41
35
42-- A lot of things gained an extra X argument in GHC 8.6, which we mostly ignore
36-- A lot of things gained an extra X argument in GHC 8.6, which we mostly ignore
43-- this U ignores that arg in 8.6, but is hidden in 8.4
37-- this U ignores that arg in 8.6, but is hidden in 8.4
@@ -50,67 +44,42 @@ import Development.IDE.Spans.Documentation
50-- | Get source span info, used for e.g. AtPoint and Goto Definition.
44-- | Get source span info, used for e.g. AtPoint and Goto Definition.
51getSrcSpanInfos
45getSrcSpanInfos
52 :: HscEnv
46 :: HscEnv
53− -> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order
47+ -> [(Located ModuleName, Maybe NormalizedFilePath)]
54 -> TcModuleResult
48 -> TcModuleResult
55− -> [ParsedModule] -- ^ Dependencies parsed, optional
49+ -> IO [SpanInfo]
56− -> [ModIface] -- ^ Dependencies module interfaces, required
57− -> IO SpansInfo
58−getSrcSpanInfos env imports tc parsedDeps deps =
50+getSrcSpanInfos env imports tc =
59− evalGhcEnv env $
51+ runGhcEnv env
60− getSpanInfo imports (tmrModule tc) parsedDeps deps
52+ . getSpanInfo imports
53+ $ tmrModule tc
61
54
62-- | Get ALL source spans in the module.
55-- | Get ALL source spans in the module.
63getSpanInfo :: GhcMonad m
56getSpanInfo :: GhcMonad m
64 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports
57 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports
65 -> TypecheckedModule
58 -> TypecheckedModule
66− -> [ParsedModule]
59+ -> m [SpanInfo]
67− -> [ModIface]
68− -> m SpansInfo
69−getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps deps =
60+getSpanInfo mods tcm =
70− do let tcs = tm_typechecked_source
61+ do let tcs = tm_typechecked_source tcm
71 bs = listifyAllSpans tcs :: [LHsBind GhcTc]
62 bs = listifyAllSpans tcs :: [LHsBind GhcTc]
72 es = listifyAllSpans tcs :: [LHsExpr GhcTc]
63 es = listifyAllSpans tcs :: [LHsExpr GhcTc]
73 ps = listifyAllSpans' tcs :: [Pat GhcTc]
64 ps = listifyAllSpans' tcs :: [Pat GhcTc]
74− ts = listifyAllSpans tm_renamed_source :: [LHsType GhcRn]
65+ ts = listifyAllSpans $ tm_renamed_source tcm :: [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−
83− bts <- mapM (getTypeLHsBind allModules funBinds) bs -- binds
66+ bts <- mapM (getTypeLHsBind tcm) bs -- binds
84− ets <- mapM (getTypeLHsExpr allModules) es -- expressions
67+ ets <- mapM (getTypeLHsExpr tcm) es -- expressions
85− pts <- mapM (getTypeLPat allModules) ps -- patterns
68+ pts <- mapM (getTypeLPat tcm) ps -- patterns
86− tts <- mapM (getLHsType allModules) ts -- types
69+ tts <- mapM (getLHsType tcm) ts -- types
87 let imports = importInfo mods
70 let imports = importInfo mods
88 let exports = getExports tcm
71 let exports = getExports tcm
89− let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)
72+ let exprs = exports ++ imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)
90− let constraints = map constraintToInfo (concatMap getConstraintsLHsBind bs)
91− return $ SpansInfo (mapMaybe toSpanInfo (sortBy cmp exprs))
73+ return (mapMaybe toSpanInfo (sortBy cmp exprs))
92− (mapMaybe toSpanInfo (sortBy cmp constraints))
93− where cmp (_,a,_,_) (_,b,_,_)
74+ where cmp (_,a,_) (_,b,_)
94 | a `isSubspanOf` b = LT
75 | a `isSubspanOf` b = LT
95 | b `isSubspanOf` a = GT
76 | b `isSubspanOf` a = GT
96 | otherwise = compare (srcSpanStart a) (srcSpanStart b)
77 | otherwise = compare (srcSpanStart a) (srcSpanStart b)
97
78
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−
110−getExports :: TypecheckedModule -> [(SpanSource, SrcSpan)]
79+getExports :: TypecheckedModule -> [(SpanSource, SrcSpan, Maybe Type)]
111getExports m
80getExports m
112 | Just (_, _, Just exports, _) <- renamedSource m =
81 | Just (_, _, Just exports, _) <- renamedSource m =
113− [ (Named $ unLoc n, getLoc n)
82+ [ (Named $ unLoc n, getLoc n, Nothing)
114 | (e, _) <- exports
83 | (e, _) <- exports
115 , n <- ieLNames $ unLoc e
84 , n <- ieLNames $ unLoc e
116 ]
85 ]
@@ -126,96 +95,43 @@ ieLNames _ = []
126
95
127-- | Get the name and type of a binding.
96-- | Get the name and type of a binding.
128getTypeLHsBind :: (GhcMonad m)
97getTypeLHsBind :: (GhcMonad m)
129− => [ParsedModule]
98+ => TypecheckedModule
130− -> OccEnv (HsBind GhcPs)
131 -> LHsBind GhcTc
99 -> LHsBind GhcTc
132− -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
100+ -> m [(SpanSource, SrcSpan, Maybe Type)]
133−getTypeLHsBind deps funBinds (L _spn FunBind{fun_id = pid})
101+getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) =
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
142− return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)]
102+ return [(Named $ getName (unLoc pid), getLoc pid, Just (varType (unLoc pid)))]
143−getTypeLHsBind _ _ _ = return []
103+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 _ = []
151
104
152-- | Get the name and type of an expression.
105-- | Get the name and type of an expression.
153getTypeLHsExpr :: (GhcMonad m)
106getTypeLHsExpr :: (GhcMonad m)
154− => [ParsedModule]
107+ => TypecheckedModule
155 -> LHsExpr GhcTc
108 -> LHsExpr GhcTc
156− -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
109+ -> m (Maybe (SpanSource, SrcSpan, Maybe Type))
157−getTypeLHsExpr deps e = do
110+getTypeLHsExpr _ e = do
158 hs_env <- getSession
111 hs_env <- getSession
159 (_, mbe) <- liftIO (deSugarExpr hs_env e)
112 (_, mbe) <- liftIO (deSugarExpr hs_env e)
113+ return $
160− case mbe of
114+ case mbe of
161− Just expr -> do
115+ Just expr ->
162− let ss = getSpanSource (unLoc e)
163− docs <- case ss of
164− Named n -> getDocumentationTryGhc deps n
165− _ -> return emptySpanDoc
166− return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr), docs)
116+ Just (getSpanSource (unLoc e), getLoc e, Just (CoreUtils.exprType expr))
167− Nothing -> return Nothing
117+ Nothing -> Nothing
168 where
118 where
169 getSpanSource :: HsExpr GhcTc -> SpanSource
119 getSpanSource :: HsExpr GhcTc -> SpanSource
170− getSpanSource xpr | isLit xpr = Lit (showGhc xpr)
171 getSpanSource (HsVar U (L _ i)) = Named (getName i)
120 getSpanSource (HsVar U (L _ i)) = Named (getName i)
172 getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)
121 getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)
173 getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name)
122 getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name)
174 getSpanSource (HsWrap U _ xpr) = getSpanSource xpr
123 getSpanSource (HsWrap U _ xpr) = getSpanSource xpr
175 getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr)
124 getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr)
176− getSpanSource _ = NoSource
125+ 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
207
126
208-- | Get the name and type of a pattern.
127-- | Get the name and type of a pattern.
209getTypeLPat :: (GhcMonad m)
128getTypeLPat :: (GhcMonad m)
210− => [ParsedModule]
129+ => TypecheckedModule
211 -> Pat GhcTc
130 -> Pat GhcTc
212− -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
131+ -> m (Maybe (SpanSource, SrcSpan, Maybe Type))
213−getTypeLPat deps pat = do
132+getTypeLPat _ pat =
214− let (src, spn) = getSpanSource pat
133+ let (src, spn) = getSpanSource pat in
215− docs <- case src of
216− Named n -> getDocumentationTryGhc deps n
217− _ -> return emptySpanDoc
218− return $ Just (src, spn, Just (hsPatType pat), docs)
134+ return $ Just (src, spn, Just (hsPatType pat))
219 where
135 where
220 getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan)
136 getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan)
221 getSpanSource (VarPat U (L spn vid)) = (Named (getName vid), spn)
137 getSpanSource (VarPat U (L spn vid)) = (Named (getName vid), spn)
@@ -225,40 +141,40 @@ getTypeLPat deps pat = do
225
141
226getLHsType
142getLHsType
227 :: GhcMonad m
143 :: GhcMonad m
228− => [ParsedModule]
144+ => TypecheckedModule
229 -> LHsType GhcRn
145 -> LHsType GhcRn
230− -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
146+ -> m [(SpanSource, SrcSpan, Maybe Type)]
231−getLHsType deps (L spn (HsTyVar U _ v)) = do
147+getLHsType _ (L spn (HsTyVar U _ v)) = pure [(Named $ unLoc v, spn, Nothing)]
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)]
245getLHsType _ _ = pure []
148getLHsType _ _ = pure []
246
149
247importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]
150importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]
248− -> [(SpanSource, SrcSpan)]
151+ -> [(SpanSource, SrcSpan, Maybe Type)]
249importInfo = mapMaybe (uncurry wrk) where
152importInfo = mapMaybe (uncurry wrk) where
250− wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan)
153+ wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan, Maybe Type)
251 wrk modName = \case
154 wrk modName = \case
252 Nothing -> Nothing
155 Nothing -> Nothing
253− Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName)
156+ Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName, Nothing)
254
157
255 -- TODO make this point to the module name
158 -- TODO make this point to the module name
256 fpToSpanSource :: FilePath -> SpanSource
159 fpToSpanSource :: FilePath -> SpanSource
257 fpToSpanSource fp = SpanS $ RealSrcSpan $ zeroSpan $ mkFastString fp
160 fpToSpanSource fp = SpanS $ RealSrcSpan $ zeroSpan $ mkFastString fp
258
161
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+
259-- | Pretty print the types into a 'SpanInfo'.
175-- | Pretty print the types into a 'SpanInfo'.
260−toSpanInfo :: (SpanSource, SrcSpan, Maybe Type, SpanDoc) -> Maybe SpanInfo
176+toSpanInfo :: (SpanSource, SrcSpan, Maybe Type) -> Maybe SpanInfo
261−toSpanInfo (name,mspan,typ,docs) =
177+toSpanInfo (name,mspan,typ) =
262 case mspan of
178 case mspan of
263 RealSrcSpan spn ->
179 RealSrcSpan spn ->
264 -- GHC’s line and column numbers are 1-based while LSP’s line and column
180 -- GHC’s line and column numbers are 1-based while LSP’s line and column
@@ -268,6 +184,5 @@ toSpanInfo (name,mspan,typ,docs) =
268 (srcSpanEndLine spn - 1)
184 (srcSpanEndLine spn - 1)
269 (srcSpanEndCol spn - 1)
185 (srcSpanEndCol spn - 1)
270 typ
186 typ
271− name
187+ name)
272− docs)
273 _ -> Nothing
188 _ -> Nothing
src/Development/IDE/Spans/Common.hsdeleted−162
@@ -1,162 +0,0 @@
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+18−41
@@ -1,12 +1,8 @@
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−
7module Development.IDE.Spans.Documentation (
4module Development.IDE.Spans.Documentation (
8 getDocumentation
5 getDocumentation
9− , getDocumentationTryGhc
10 ) where
6 ) where
11
7
12import Control.Monad
8import Control.Monad
@@ -14,34 +10,16 @@ import Data.List.Extra
14import qualified Data.Map as M
10import qualified Data.Map as M
15import Data.Maybe
11import Data.Maybe
16import qualified Data.Text as T
12import qualified Data.Text as T
17−import Development.IDE.GHC.Compat
18import Development.IDE.GHC.Error
13import Development.IDE.GHC.Error
19−import Development.IDE.Spans.Common
14+import Development.IDE.Spans.Calculate
20import FastString
15import FastString
16+import GHC
21import SrcLoc
17import SrcLoc
22
18
23
19
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−
42getDocumentation
20getDocumentation
21+ :: Name -- ^ The name you want documentation for.
43− :: [ParsedModule] -- ^ All of the possible modules it could be defined in.
22+ -> [TypecheckedModule] -- ^ All of the possible modules it could be defined in.
44− -> Name -- ^ The name you want documentation for.
45 -> [T.Text]
23 -> [T.Text]
46-- This finds any documentation between the name you want
24-- This finds any documentation between the name you want
47-- documentation for and the one before it. This is only an
25-- documentation for and the one before it. This is only an
@@ -50,18 +28,17 @@ getDocumentation
50-- may be edge cases where it is very wrong).
28-- may be edge cases where it is very wrong).
51-- TODO : Build a version of GHC exactprint to extract this information
29-- TODO : Build a version of GHC exactprint to extract this information
52-- more accurately.
30-- more accurately.
53−getDocumentation sources targetName = fromMaybe [] $ do
31+getDocumentation targetName tcs = fromMaybe [] $ do
54 -- Find the module the target is defined in.
32 -- Find the module the target is defined in.
55 targetNameSpan <- realSpan $ nameSrcSpan targetName
33 targetNameSpan <- realSpan $ nameSrcSpan targetName
56 tc <-
34 tc <-
35+ listToMaybe
57− find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)
36+ $ filter ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)
58− $ reverse sources -- TODO : Is reversing the list here really neccessary?
37+ $ reverse tcs -- TODO : Is reversing the list here really neccessary?
59−
60− -- Top level names bound by the module
38+ -- Names bound by the module (we want to exclude non-"top-level"
61− let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc
39+ -- bindings but unfortunately we get all here).
62− , L _ (ValD hsbind) <- hsmodDecls
63− , Just n <- [name_of_bind hsbind]
40+ let bs = mapMaybe name_of_bind
64− ]
41+ (listifyAllSpans (tm_typechecked_source tc) :: [LHsBind GhcTc])
65 -- Sort the names' source spans.
42 -- Sort the names' source spans.
66 let sortedSpans = sortedNameSpans bs
43 let sortedSpans = sortedNameSpans bs
67 -- Now go ahead and extract the docs.
44 -- Now go ahead and extract the docs.
@@ -83,16 +60,16 @@ getDocumentation sources targetName = fromMaybe [] $ do
83 where
60 where
84 -- Get the name bound by a binding. We only concern ourselves with
61 -- Get the name bound by a binding. We only concern ourselves with
85 -- @FunBind@ (which covers functions and variables).
62 -- @FunBind@ (which covers functions and variables).
86− name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)
63+ name_of_bind :: LHsBind GhcTc -> Maybe Name
87− name_of_bind FunBind {fun_id} = Just fun_id
64+ name_of_bind (L _ FunBind {fun_id}) = Just (getName (unLoc fun_id))
88 name_of_bind _ = Nothing
65 name_of_bind _ = Nothing
89 -- Get source spans from names, discard unhelpful spans, remove
66 -- Get source spans from names, discard unhelpful spans, remove
90 -- duplicates and sort.
67 -- duplicates and sort.
91− sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]
68+ sortedNameSpans :: [Name] -> [RealSrcSpan]
92− sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)
69+ sortedNameSpans ls = nubSort (mapMaybe (realSpan . nameSrcSpan) ls)
93 isBetween target before after = before <= target && target <= after
70 isBetween target before after = before <= target && target <= after
94− ann = snd . pm_annotations
71+ ann = snd . pm_annotations . tm_parsed_module
95− annotationFileName :: ParsedModule -> Maybe FastString
72+ annotationFileName :: TypecheckedModule -> Maybe FastString
96 annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann
73 annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann
97 realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]
74 realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]
98 realSpans =
75 realSpans =
src/Development/IDE/Spans/Type.hs+4−19
@@ -6,8 +6,7 @@
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(..)
10− , SpanInfo(..)
9+ SpanInfo(..)
11 , SpanSource(..)
10 , SpanSource(..)
12 , getNameM
11 , getNameM
13 ) where
12 ) where
@@ -16,15 +15,6 @@ import GHC
16import Control.DeepSeq
15import Control.DeepSeq
17import OccName
16import OccName
18import Development.IDE.GHC.Util
17import 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
28
18
29-- | Type of some span of source code. Most of these fields are
19-- | Type of some span of source code. Most of these fields are
30-- unboxed but Haddock doesn't show that.
20-- unboxed but Haddock doesn't show that.
@@ -44,14 +34,11 @@ data SpanInfo =
44 -- any. This can be useful for accessing a variety of
34 -- any. This can be useful for accessing a variety of
45 -- information about the identifier such as module,
35 -- information about the identifier such as module,
46 -- locality, definition location, etc.
36 -- locality, definition location, etc.
47− ,spaninfoDocs :: !SpanDoc
48− -- ^ Documentation for the element
49 }
37 }
50instance Show SpanInfo where
38instance Show SpanInfo where
51− show (SpanInfo sl sc el ec t n docs) =
39+ show (SpanInfo sl sc el ec t n) =
52 unwords ["(SpanInfo", show sl, show sc, show el, show ec
40 unwords ["(SpanInfo", show sl, show sc, show el, show ec
53− , show $ maybe "NoType" prettyPrint t, "(" <> show n <> "))"
41+ , show $ maybe "NoType" prettyPrint t, "(" <> show n <> "))"]
54− , "docs(" <> show docs <> ")"]
55
42
56instance NFData SpanInfo where
43instance NFData SpanInfo where
57 rnf = rwhnf
44 rnf = rwhnf
@@ -60,7 +47,6 @@ instance NFData SpanInfo where
60-- we don't always get a name out so sometimes manually annotating source is more appropriate
47-- we don't always get a name out so sometimes manually annotating source is more appropriate
61data SpanSource = Named Name
48data SpanSource = Named Name
62 | SpanS SrcSpan
49 | SpanS SrcSpan
63− | Lit String
64 | NoSource
50 | NoSource
65 deriving (Eq)
51 deriving (Eq)
66
52
@@ -68,10 +54,9 @@ instance Show SpanSource where
68 show = \case
54 show = \case
69 Named n -> "Named " ++ occNameString (occName n)
55 Named n -> "Named " ++ occNameString (occName n)
70 SpanS sp -> "Span " ++ show sp
56 SpanS sp -> "Span " ++ show sp
71− Lit lit -> "Lit " ++ lit
72 NoSource -> "NoSource"
57 NoSource -> "NoSource"
73
58
74getNameM :: SpanSource -> Maybe Name
59getNameM :: SpanSource -> Maybe Name
75getNameM = \case
60getNameM = \case
76 Named name -> Just name
61 Named name -> Just name
77− _ -> Nothing
62+ _ -> Nothing
src/Development/IDE/Types/Diagnostics.hs+7−38
@@ -4,23 +4,19 @@
4
4
5module Development.IDE.Types.Diagnostics (
5module Development.IDE.Types.Diagnostics (
6 LSP.Diagnostic(..),
6 LSP.Diagnostic(..),
7− ShowDiagnostic(..),
8 FileDiagnostic,
7 FileDiagnostic,
9− IdeResult,
10 LSP.DiagnosticSeverity(..),
8 LSP.DiagnosticSeverity(..),
11 DiagnosticStore,
9 DiagnosticStore,
12 List(..),
10 List(..),
13 ideErrorText,
11 ideErrorText,
14− ideErrorWithSource,
15 showDiagnostics,
12 showDiagnostics,
16 showDiagnosticsColored,
13 showDiagnosticsColored,
17 ) where
14 ) where
18
15
19−import Control.DeepSeq
20import Data.Maybe as Maybe
16import Data.Maybe as Maybe
21import qualified Data.Text as T
17import qualified Data.Text as T
22import Data.Text.Prettyprint.Doc
18import Data.Text.Prettyprint.Doc
23−import Language.Haskell.LSP.Types as LSP (DiagnosticSource,
19+import Language.Haskell.LSP.Types as LSP (
24 DiagnosticSeverity(..)
20 DiagnosticSeverity(..)
25 , Diagnostic(..)
21 , Diagnostic(..)
26 , List(..)
22 , List(..)
@@ -32,43 +28,17 @@ import Data.Text.Prettyprint.Doc.Render.Terminal (Color(..), color)
32
28
33import Development.IDE.Types.Location
29import Development.IDE.Types.Location
34
30
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)
38
31
39ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic
32ideErrorText :: 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)
48−ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic {
33+ideErrorText fp msg = (fp, LSP.Diagnostic {
49 _range = noRange,
34 _range = noRange,
50− _severity = sev,
35+ _severity = Just LSP.DsError,
51 _code = Nothing,
36 _code = Nothing,
52− _source = source,
37+ _source = Just "compiler",
53 _message = msg,
38 _message = msg,
54− _relatedInformation = Nothing,
39+ _relatedInformation = Nothing
55− _tags = Nothing
56 })
40 })
57
41
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
72
42
73-- | Human readable diagnostics for a specific file.
43-- | Human readable diagnostics for a specific file.
74--
44--
@@ -76,7 +46,7 @@ instance NFData ShowDiagnostic where
76-- along with the related source location so that we can display the error
46-- along with the related source location so that we can display the error
77-- on either the console or in the IDE at the right source location.
47-- on either the console or in the IDE at the right source location.
78--
48--
79−type FileDiagnostic = (NormalizedFilePath, ShowDiagnostic, Diagnostic)
49+type FileDiagnostic = (NormalizedFilePath, Diagnostic)
80
50
81prettyRange :: Range -> Doc Terminal.AnsiStyle
51prettyRange :: Range -> Doc Terminal.AnsiStyle
82prettyRange Range{..} = f _start <> "-" <> f _end
52prettyRange Range{..} = f _start <> "-" <> f _end
@@ -96,10 +66,9 @@ prettyDiagnostics :: [FileDiagnostic] -> Doc Terminal.AnsiStyle
96prettyDiagnostics = vcat . map prettyDiagnostic
66prettyDiagnostics = vcat . map prettyDiagnostic
97
67
98prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle
68prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle
99−prettyDiagnostic (fp, sh, LSP.Diagnostic{..}) =
69+prettyDiagnostic (fp, LSP.Diagnostic{..}) =
100 vcat
70 vcat
101 [ slabel_ "File: " $ pretty (fromNormalizedFilePath fp)
71 [ slabel_ "File: " $ pretty (fromNormalizedFilePath fp)
102− , slabel_ "Hidden: " $ if sh == ShowDiag then "no" else "yes"
103 , slabel_ "Range: " $ prettyRange _range
72 , slabel_ "Range: " $ prettyRange _range
104 , slabel_ "Source: " $ pretty _source
73 , slabel_ "Source: " $ pretty _source
105 , slabel_ "Severity:" $ pretty $ show sev
74 , slabel_ "Severity:" $ pretty $ show sev
src/Development/IDE/Types/Location.hs+59−70
@@ -10,59 +10,84 @@ module Development.IDE.Types.Location
10 , Position(..)
10 , Position(..)
11 , showPosition
11 , showPosition
12 , Range(..)
12 , Range(..)
13− , LSP.Uri(..)
13+ , Uri(..)
14− , LSP.NormalizedUri
14+ , NormalizedUri
15 , LSP.toNormalizedUri
15 , LSP.toNormalizedUri
16 , LSP.fromNormalizedUri
16 , LSP.fromNormalizedUri
17− , LSP.NormalizedFilePath
17+ , NormalizedFilePath
18 , fromUri
18 , fromUri
19− , emptyFilePath
20− , emptyPathUri
21− , toNormalizedFilePath'
19+ , toNormalizedFilePath
22− , LSP.fromNormalizedFilePath
20+ , fromNormalizedFilePath
21+ , filePathToUri
23 , filePathToUri'
22 , filePathToUri'
24 , uriToFilePath'
23 , uriToFilePath'
25− , readSrcSpan
26 ) where
24 ) where
27
25
28−import Control.Applicative
29import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..))
26import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..))
30−import Control.Monad
27+import Control.DeepSeq
31−import Data.Hashable (Hashable(hash))
28+import Data.Binary
29+import Data.Maybe as Maybe
30+import Data.Hashable
32import Data.String
31import Data.String
33−import FastString
32+import System.FilePath
33+import System.Info.Extra
34import qualified Language.Haskell.LSP.Types as LSP
34import qualified Language.Haskell.LSP.Types as LSP
35−import SrcLoc as GHC
35+import Language.Haskell.LSP.Types as LSP (
36−import Text.ParserCombinators.ReadP as ReadP
36+ filePathToUri
37−import Data.Maybe (fromMaybe)
37+ , NormalizedUri(..)
38−
38+ , Uri(..)
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+
39−toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath
51+toNormalizedFilePath :: FilePath -> NormalizedFilePath
40−-- We want to keep empty paths instead of normalising them to "."
52+toNormalizedFilePath "" = NormalizedFilePath ""
41−toNormalizedFilePath' "" = emptyFilePath
53+toNormalizedFilePath fp = NormalizedFilePath $ normalise' fp
42−toNormalizedFilePath' fp = LSP.toNormalizedFilePath fp
54+ where
43−
55+ -- We do not use System.FilePath’s normalise here since that
44−emptyFilePath :: LSP.NormalizedFilePath
56+ -- also normalises things like the case of the drive letter
45−emptyFilePath = LSP.NormalizedFilePath emptyPathUri ""
57+ -- which NormalizedUri does not normalise so we get VFS lookup failures.
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
46
74
47-- | We use an empty string as a filepath when we don’t have a file.
75-- | We use an empty string as a filepath when we don’t have a file.
48-- However, haskell-lsp doesn’t support that in uriToFilePath and given
76-- However, haskell-lsp doesn’t support that in uriToFilePath and given
49-- that it is not a valid filepath it does not make sense to upstream a fix.
77-- that it is not a valid filepath it does not make sense to upstream a fix.
50-- So we have our own wrapper here that supports empty filepaths.
78-- So we have our own wrapper here that supports empty filepaths.
51−uriToFilePath' :: LSP.Uri -> Maybe FilePath
79+uriToFilePath' :: Uri -> Maybe FilePath
52uriToFilePath' uri
80uriToFilePath' uri
53− | uri == LSP.fromNormalizedUri emptyPathUri = Just ""
81+ | uri == filePathToUri "" = Just ""
54 | otherwise = LSP.uriToFilePath uri
82 | otherwise = LSP.uriToFilePath uri
55
83
56−emptyPathUri :: LSP.NormalizedUri
84+filePathToUri' :: NormalizedFilePath -> NormalizedUri
57−emptyPathUri =
85+filePathToUri' = toNormalizedUri . filePathToUri . fromNormalizedFilePath
58− let s = "file://"
86+
59− in LSP.NormalizedUri (hash s) s
60
87
61−filePathToUri' :: LSP.NormalizedFilePath -> LSP.NormalizedUri
88+fromUri :: LSP.NormalizedUri -> NormalizedFilePath
62−filePathToUri' = LSP.normalizedFilePathToUri
89+fromUri = toNormalizedFilePath . fromMaybe noFilePath . uriToFilePath' . fromNormalizedUri
63
90
64−fromUri :: LSP.NormalizedUri -> LSP.NormalizedFilePath
65−fromUri = fromMaybe (toNormalizedFilePath' noFilePath) . LSP.uriToNormalizedFilePath
66
91
67noFilePath :: FilePath
92noFilePath :: FilePath
68noFilePath = "<unknown>"
93noFilePath = "<unknown>"
@@ -71,42 +96,6 @@ noFilePath = "<unknown>"
71noRange :: Range
96noRange :: Range
72noRange = Range (Position 0 0) (Position 100000 0)
97noRange = Range (Position 0 0) (Position 100000 0)
73
98
99+
74showPosition :: Position -> String
100showPosition :: Position -> String
75showPosition Position{..} = show (_line + 1) ++ ":" ++ show (_character + 1)
101showPosition 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+8−35
@@ -12,25 +12,25 @@ module Development.IDE.Types.Options
12 , clientSupportsProgress
12 , clientSupportsProgress
13 , IdePkgLocationOptions(..)
13 , IdePkgLocationOptions(..)
14 , defaultIdeOptions
14 , defaultIdeOptions
15− , IdeResult
16 ) where
15 ) where
17
16
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
25
23
26data IdeOptions = IdeOptions
24data IdeOptions = IdeOptions
27 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource
25 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource
28 -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings
26 -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings
29 -- and a list of errors, along with a new parse tree.
27 -- and a list of errors, along with a new parse tree.
30− , optGhcSession :: Action (FilePath -> Action (IdeResult HscEnvEq))
28+ , optGhcSession :: IO (FilePath -> Action HscEnvEq)
31 -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.
29 -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.
32− -- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.
30+ -- The 'IO' will be called once, then the resulting function will be applied once per file.
33 -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.
31 -- 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,17 +43,12 @@ 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
48 , optReportProgress :: IdeReportProgress
46 , optReportProgress :: IdeReportProgress
49 -- ^ Whether to report progress during long operations.
47 -- ^ Whether to report progress during long operations.
50 , optLanguageSyntax :: String
48 , optLanguageSyntax :: String
51 -- ^ the ```language to use
49 -- ^ the ```language to use
52 , optNewColonConvention :: Bool
50 , optNewColonConvention :: Bool
53 -- ^ whether to use new colon convention
51 -- ^ 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.
57 , optDefer :: IdeDefer
52 , optDefer :: IdeDefer
58 -- ^ Whether to defer type errors, typed holes and out of scope
53 -- ^ Whether to defer type errors, typed holes and out of scope
59 -- variables. Deferral allows the IDE to continue to provide
54 -- variables. Deferral allows the IDE to continue to provide
@@ -75,10 +70,10 @@ newtype IdeReportProgress = IdeReportProgress Bool
75newtype IdeDefer = IdeDefer Bool
70newtype IdeDefer = IdeDefer Bool
76
71
77clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress
72clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress
78−clientSupportsProgress caps = IdeReportProgress $ Just True ==
73+clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $
79− (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))
74+ LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)
80
75
81−defaultIdeOptions :: Action (FilePath -> Action (IdeResult HscEnvEq)) -> IdeOptions
76+defaultIdeOptions :: IO (FilePath -> Action HscEnvEq) -> IdeOptions
82defaultIdeOptions session = IdeOptions
77defaultIdeOptions session = IdeOptions
83 {optPreprocessor = IdePreprocessedSource [] []
78 {optPreprocessor = IdePreprocessedSource [] []
84 ,optGhcSession = session
79 ,optGhcSession = session
@@ -90,9 +85,7 @@ defaultIdeOptions session = IdeOptions
90 ,optReportProgress = IdeReportProgress False
85 ,optReportProgress = IdeReportProgress False
91 ,optLanguageSyntax = "haskell"
86 ,optLanguageSyntax = "haskell"
92 ,optNewColonConvention = False
87 ,optNewColonConvention = False
93− ,optKeywords = haskellKeywords
94 ,optDefer = IdeDefer True
88 ,optDefer = IdeDefer True
95− ,optTesting = False
96 }
89 }
97
90
98
91
@@ -110,23 +103,3 @@ data IdePkgLocationOptions = IdePkgLocationOptions
110defaultIdePkgLocationOptions :: IdePkgLocationOptions
103defaultIdePkgLocationOptions :: IdePkgLocationOptions
111defaultIdePkgLocationOptions = IdePkgLocationOptions f f
104defaultIdePkgLocationOptions = IdePkgLocationOptions f f
112 where f _ _ = return Nothing
105 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+4−10
@@ -2,18 +2,12 @@ resolver: nightly-2019-09-16
2packages:
2packages:
3- .
3- .
4extra-deps:
4extra-deps:
5−- haskell-lsp-0.22.0.0
5+- haskell-lsp-0.18.0.0
6−- haskell-lsp-types-0.22.0.0
6+- haskell-lsp-types-0.18.0.0
7−- lsp-test-0.10.3.0
7+- lsp-test-0.8.2.0
8−- hie-bios-0.5.0
8+- hie-bios-0.2.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
17nix:
11nix:
18 packages: [zlib]
12 packages: [zlib]
19flags:
13flags:
stack.yaml+5−14
@@ -1,19 +1,10 @@
1−resolver: nightly-2019-09-21
1+resolver: nightly-2019-09-16
2packages:
2packages:
3- .
3- .
4extra-deps:
4extra-deps:
5−- haskell-lsp-0.22.0.0
5+- haskell-lsp-0.18.0.0
6−- haskell-lsp-types-0.22.0.0
6+- haskell-lsp-types-0.18.0.0
7−- lsp-test-0.11.0.1
7+- lsp-test-0.8.2.0
8−- hie-bios-0.5.0
8+- hie-bios-0.2.1
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
18nix:
9nix:
19 packages: [zlib]
10 packages: [zlib]
stack810.yamldeleted−18
@@ -1,18 +0,0 @@
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+6−23
@@ -3,31 +3,14 @@ packages:
3- .
3- .
4
4
5extra-deps:
5extra-deps:
6−- aeson-1.4.6.0
6+- haskell-lsp-0.18.0.0
7−- base-orphans-0.8.2
7+- haskell-lsp-types-0.18.0.0
8−- haskell-lsp-0.22.0.0
8+- lsp-test-0.8.2.0
9−- haskell-lsp-types-0.22.0.0
10−- lsp-test-0.11.0.1
11- rope-utf16-splay-0.3.1.0
9- rope-utf16-splay-0.3.1.0
10+- shake-0.18.3
12- filepattern-0.1.1
11- filepattern-0.1.1
13- js-dgtable-0.5.2
12- js-dgtable-0.5.2
14−- hie-bios-0.5.0
13+- hie-bios-0.2.1
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−
32nix:
14nix:
33 packages: [zlib]
15 packages: [zlib]
16+allow-newer: true
stack88.yaml+2−6
@@ -1,11 +1,7 @@
1−resolver: nightly-2020-02-13
1+resolver: nightly-2019-12-06
2packages:
2packages:
3- .
3- .
4extra-deps:
4extra-deps:
5−- haskell-lsp-0.22.0.0
5+allow-newer: true
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
10nix:
6nix:
11 packages: [zlib]
7 packages: [zlib]
test/data/GotoHover.hsnew file+34
@@ -0,0 +1,34 @@
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.hsdeleted−3
@@ -1,3 +0,0 @@
1−module Bar (Bar(..)) where
2−
3−data Bar = Bar
test/data/hover/Foo.hsdeleted−5
@@ -1,5 +0,0 @@
1−module Foo (Bar, foo) where
2−
3−import Bar
4−
5−foo = Bar
test/data/hover/GotoHover.hsdeleted−57
@@ -1,57 +0,0 @@
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.hsdeleted−3
@@ -1,3 +0,0 @@
1−module A(foo) where
2−
3−foo = ()
test/data/multi/a/a.cabaldeleted−9
@@ -1,9 +0,0 @@
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.hsdeleted−3
@@ -1,3 +0,0 @@
1−module B(module B) where
2−import A
3−qux = foo
test/data/multi/b/b.cabaldeleted−9
@@ -1,9 +0,0 @@
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.projectdeleted−1
@@ -1 +0,0 @@
1−packages: a b
test/data/multi/hie.yamldeleted−6
@@ -1,6 +0,0 @@
1−cradle:
2− cabal:
3− - path: "./a"
4− component: "lib:a"
5− - path: "./b"
6− component: "lib:b"
test/exe/Main.hs+171−1731
@@ -1,83 +1,48 @@
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 #-}
5{-# LANGUAGE DuplicateRecordFields #-}
4{-# LANGUAGE DuplicateRecordFields #-}
6−{-# LANGUAGE PatternSynonyms #-}
7{-# LANGUAGE CPP #-}
5{-# LANGUAGE CPP #-}
8#include "ghc-api-version.h"
6#include "ghc-api-version.h"
9
7
10module Main (main) where
8module Main (main) where
11
9
12import Control.Applicative.Combinators
10import Control.Applicative.Combinators
13−import Control.Exception (bracket, catch)
14−import qualified Control.Lens as Lens
15import Control.Monad
11import Control.Monad
16import Control.Monad.IO.Class (liftIO)
12import Control.Monad.IO.Class (liftIO)
17−import Data.Aeson (FromJSON, Value)
13+import Data.Char (toLower)
18import Data.Foldable
14import 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)
23import Development.IDE.GHC.Util
15import Development.IDE.GHC.Util
24import qualified Data.Text as T
16import qualified Data.Text as T
25−import Data.Typeable
26−import Development.IDE.Spans.Common
27import Development.IDE.Test
17import Development.IDE.Test
28import Development.IDE.Test.Runfiles
18import Development.IDE.Test.Runfiles
29−import Development.IDE.Types.Location
30−import Development.Shake (getDirectoryFilesIO)
31import Language.Haskell.LSP.Test
19import Language.Haskell.LSP.Test
32−import Language.Haskell.LSP.Messages
33import Language.Haskell.LSP.Types
20import Language.Haskell.LSP.Types
34import Language.Haskell.LSP.Types.Capabilities
21import 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
38−import System.Environment.Blank (getEnv, setEnv, unsetEnv)
22+import System.Environment.Blank (setEnv)
39import System.FilePath
23import System.FilePath
40import System.IO.Extra
24import System.IO.Extra
41import System.Directory
25import System.Directory
42−import Test.QuickCheck
43−import Test.QuickCheck.Instances ()
44import Test.Tasty
26import Test.Tasty
45−import Test.Tasty.ExpectedFailure
46−import Test.Tasty.Ingredients.Rerun
47import Test.Tasty.HUnit
27import Test.Tasty.HUnit
48−import Test.Tasty.QuickCheck
28+import Test.Tasty.ExpectedFailure
49import Data.Maybe
29import Data.Maybe
50
30
51main :: IO ()
31main :: IO ()
52−main = do
53− -- We mess with env vars so run single-threaded.
54− setEnv "TASTY_NUM_THREADS" "1" True
55− defaultMainWithRerun $ testGroup "HIE"
32+main = defaultMain $ testGroup "HIE"
56− [ testSession "open close" $ do
33+ [ testSession "open close" $ do
57− doc <- createDoc "Testing.hs" "haskell" ""
34+ doc <- openDoc' "Testing.hs" "haskell" ""
58− void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
35+ void (message :: Session WorkDoneProgressCreateRequest)
59− void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
36+ void (message :: Session WorkDoneProgressBeginNotification)
60− closeDoc doc
37+ closeDoc doc
61− void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
38+ void (message :: Session WorkDoneProgressEndNotification)
62− , initializeResponseTests
39+ , initializeResponseTests
63− , completionTests
64− , cppTests
65− , diagnosticTests
40+ , diagnosticTests
66− , codeActionTests
41+ , codeActionTests
67− , codeLensesTests
68− , outlineTests
69− , findDefinitionAndHoverTests
42+ , findDefinitionAndHoverTests
70− , pluginTests
43+ , pluginTests
71− , preprocessorTests
72− , thTests
44+ , thTests
73− , safeTests
74− , unitTests
75− , haddockTests
76− , positionMappingTests
77− , watchedFilesTests
78− , cradleTests
79− , dependentFileTest
80− ]
45+ ]
81
46
82initializeResponseTests :: TestTree
47initializeResponseTests :: TestTree
83initializeResponseTests = withResource acquire release tests where
48initializeResponseTests = withResource acquire release tests where
@@ -92,14 +57,14 @@ initializeResponseTests = withResource acquire release tests where
92 testGroup "initialize response capabilities"
57 testGroup "initialize response capabilities"
93 [ chk " text doc sync" _textDocumentSync tds
58 [ chk " text doc sync" _textDocumentSync tds
94 , chk " hover" _hoverProvider (Just True)
59 , chk " hover" _hoverProvider (Just True)
95− , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing)
60+ , chk "NO completion" _completionProvider Nothing
96 , chk "NO signature help" _signatureHelpProvider Nothing
61 , chk "NO signature help" _signatureHelpProvider Nothing
97 , chk " goto definition" _definitionProvider (Just True)
62 , chk " goto definition" _definitionProvider (Just True)
98 , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)
63 , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)
99 , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic False)
64 , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic False)
100 , chk "NO find references" _referencesProvider Nothing
65 , chk "NO find references" _referencesProvider Nothing
101 , chk "NO doc highlight" _documentHighlightProvider Nothing
66 , chk "NO doc highlight" _documentHighlightProvider Nothing
102− , chk " doc symbol" _documentSymbolProvider (Just True)
67+ , chk "NO doc symbol" _documentSymbolProvider Nothing
103 , chk "NO workspace symbol" _workspaceSymbolProvider Nothing
68 , chk "NO workspace symbol" _workspaceSymbolProvider Nothing
104 , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True
69 , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True
105 , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing
70 , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing
@@ -112,8 +77,8 @@ initializeResponseTests = withResource acquire release tests where
112 , chk "NO doc link" _documentLinkProvider Nothing
77 , chk "NO doc link" _documentLinkProvider Nothing
113 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
78 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
114 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
79 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
115− , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
80+ , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
116− , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
81+ , chk "NO workspace" _workspace nothingWorkspace
117 , chk "NO experimental" _experimental Nothing
82 , chk "NO experimental" _experimental Nothing
118 ] where
83 ] where
119
84
@@ -124,21 +89,14 @@ initializeResponseTests = withResource acquire release tests where
124 , _willSaveWaitUntil = Nothing
89 , _willSaveWaitUntil = Nothing
125 , _save = Just (SaveOptions {_includeText = Nothing})}))
90 , _save = Just (SaveOptions {_includeText = Nothing})}))
126
91
92+ nothingWorkspace = Just (WorkspaceOptions {_workspaceFolders = Nothing})
93+
127 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree
94 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree
128 chk title getActual expected =
95 chk title getActual expected =
129 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
96 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
130
97
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−
140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
98 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
141− innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
99+ innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c
142 innerCaps _ = error "this test only expects inner capabilities"
100 innerCaps _ = error "this test only expects inner capabilities"
143
101
144 acquire :: IO InitializeResponse
102 acquire :: IO InitializeResponse
@@ -152,7 +110,7 @@ diagnosticTests :: TestTree
152diagnosticTests = testGroup "diagnostics"
110diagnosticTests = testGroup "diagnostics"
153 [ testSessionWait "fix syntax error" $ do
111 [ testSessionWait "fix syntax error" $ do
154 let content = T.unlines [ "module Testing wher" ]
112 let content = T.unlines [ "module Testing wher" ]
155− doc <- createDoc "Testing.hs" "haskell" content
113+ doc <- openDoc' "Testing.hs" "haskell" content
156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
114 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
157 let change = TextDocumentContentChangeEvent
115 let change = TextDocumentContentChangeEvent
158 { _range = Just (Range (Position 0 15) (Position 0 19))
116 { _range = Just (Range (Position 0 15) (Position 0 19))
@@ -163,9 +121,9 @@ diagnosticTests = testGroup "diagnostics"
163 expectDiagnostics [("Testing.hs", [])]
121 expectDiagnostics [("Testing.hs", [])]
164 , testSessionWait "introduce syntax error" $ do
122 , testSessionWait "introduce syntax error" $ do
165 let content = T.unlines [ "module Testing where" ]
123 let content = T.unlines [ "module Testing where" ]
166− doc <- createDoc "Testing.hs" "haskell" content
124+ doc <- openDoc' "Testing.hs" "haskell" content
167− void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
125+ void (message :: Session WorkDoneProgressCreateRequest)
168− void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
126+ void (message :: Session WorkDoneProgressBeginNotification)
169 let change = TextDocumentContentChangeEvent
127 let change = TextDocumentContentChangeEvent
170 { _range = Just (Range (Position 0 15) (Position 0 18))
128 { _range = Just (Range (Position 0 15) (Position 0 18))
171 , _rangeLength = Nothing
129 , _rangeLength = Nothing
@@ -181,7 +139,7 @@ diagnosticTests = testGroup "diagnostics"
181 , "bar :: Int -> Int -> Int"
139 , "bar :: Int -> Int -> Int"
182 , "bar a b = cd + b"
140 , "bar a b = cd + b"
183 ]
141 ]
184− _ <- createDoc "Testing.hs" "haskell" content
142+ _ <- openDoc' "Testing.hs" "haskell" content
185 expectDiagnostics
143 expectDiagnostics
186 [ ( "Testing.hs"
144 [ ( "Testing.hs"
187 , [ (DsError, (2, 14), "Variable not in scope: ab")
145 , [ (DsError, (2, 14), "Variable not in scope: ab")
@@ -195,7 +153,7 @@ diagnosticTests = testGroup "diagnostics"
195 , "foo :: Int -> String -> Int"
153 , "foo :: Int -> String -> Int"
196 , "foo a b = a + b"
154 , "foo a b = a + b"
197 ]
155 ]
198− _ <- createDoc "Testing.hs" "haskell" content
156+ _ <- openDoc' "Testing.hs" "haskell" content
199 expectDiagnostics
157 expectDiagnostics
200 [ ( "Testing.hs"
158 [ ( "Testing.hs"
201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
159 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
@@ -207,7 +165,7 @@ diagnosticTests = testGroup "diagnostics"
207 , "foo :: Int -> String"
165 , "foo :: Int -> String"
208 , "foo a = _ a"
166 , "foo a = _ a"
209 ]
167 ]
210− _ <- createDoc "Testing.hs" "haskell" content
168+ _ <- openDoc' "Testing.hs" "haskell" content
211 expectDiagnostics
169 expectDiagnostics
212 [ ( "Testing.hs"
170 [ ( "Testing.hs"
213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
171 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
@@ -229,23 +187,24 @@ diagnosticTests = testGroup "diagnostics"
229 [ ("A.hs", [(DsError, (2,4), aMessage)])
187 [ ("A.hs", [(DsError, (2,4), aMessage)])
230 , ("B.hs", [(DsError, (3,4), bMessage)])]
188 , ("B.hs", [(DsError, (3,4), bMessage)])]
231 deferralTest title binding msg = testSessionWait title $ do
189 deferralTest title binding msg = testSessionWait title $ do
232− _ <- createDoc "A.hs" "haskell" $ sourceA binding
190+ _ <- openDoc' "A.hs" "haskell" $ sourceA binding
233− _ <- createDoc "B.hs" "haskell" sourceB
191+ _ <- openDoc' "B.hs" "haskell" sourceB
234 expectDiagnostics $ expectedDs msg
192 expectDiagnostics $ expectedDs msg
235 in
193 in
236 [ deferralTest "type error" "True" "Couldn't match expected type"
194 [ deferralTest "type error" "True" "Couldn't match expected type"
237 , deferralTest "typed hole" "_" "Found hole"
195 , deferralTest "typed hole" "_" "Found hole"
238 , deferralTest "out of scope var" "unbound" "Variable not in scope"
196 , deferralTest "out of scope var" "unbound" "Variable not in scope"
197+ , deferralTest "message shows error" "True" "A.hs:3:5: error:"
239 ]
198 ]
240
199
241 , testSessionWait "remove required module" $ do
200 , testSessionWait "remove required module" $ do
242 let contentA = T.unlines [ "module ModuleA where" ]
201 let contentA = T.unlines [ "module ModuleA where" ]
243− docA <- createDoc "ModuleA.hs" "haskell" contentA
202+ docA <- openDoc' "ModuleA.hs" "haskell" contentA
244 let contentB = T.unlines
203 let contentB = T.unlines
245 [ "module ModuleB where"
204 [ "module ModuleB where"
246 , "import ModuleA"
205 , "import ModuleA"
247 ]
206 ]
248− _ <- createDoc "ModuleB.hs" "haskell" contentB
207+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
249 let change = TextDocumentContentChangeEvent
208 let change = TextDocumentContentChangeEvent
250 { _range = Just (Range (Position 0 0) (Position 0 20))
209 { _range = Just (Range (Position 0 0) (Position 0 20))
251 , _rangeLength = Nothing
210 , _rangeLength = Nothing
@@ -258,21 +217,11 @@ diagnosticTests = testGroup "diagnostics"
258 [ "module ModuleB where"
217 [ "module ModuleB where"
259 , "import ModuleA"
218 , "import ModuleA"
260 ]
219 ]
261− _ <- createDoc "ModuleB.hs" "haskell" contentB
220+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
221 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
263 let contentA = T.unlines [ "module ModuleA where" ]
222 let contentA = T.unlines [ "module ModuleA where" ]
264− _ <- createDoc "ModuleA.hs" "haskell" contentA
223+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
265 expectDiagnostics [("ModuleB.hs", [])]
224 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", [])]
276 , testSessionWait "cyclic module dependency" $ do
225 , testSessionWait "cyclic module dependency" $ do
277 let contentA = T.unlines
226 let contentA = T.unlines
278 [ "module ModuleA where"
227 [ "module ModuleA where"
@@ -282,8 +231,8 @@ diagnosticTests = testGroup "diagnostics"
282 [ "module ModuleB where"
231 [ "module ModuleB where"
283 , "import ModuleA"
232 , "import ModuleA"
284 ]
233 ]
285− _ <- createDoc "ModuleA.hs" "haskell" contentA
234+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
286− _ <- createDoc "ModuleB.hs" "haskell" contentB
235+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
287 expectDiagnostics
236 expectDiagnostics
288 [ ( "ModuleA.hs"
237 [ ( "ModuleA.hs"
289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
238 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
@@ -304,9 +253,9 @@ diagnosticTests = testGroup "diagnostics"
304 let contentBboot = T.unlines
253 let contentBboot = T.unlines
305 [ "module ModuleB where"
254 [ "module ModuleB where"
306 ]
255 ]
307− _ <- createDoc "ModuleA.hs" "haskell" contentA
256+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
308− _ <- createDoc "ModuleB.hs" "haskell" contentB
257+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
309− _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
258+ _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
310 expectDiagnostics []
259 expectDiagnostics []
311 , testSessionWait "correct reference used with hs-boot" $ do
260 , testSessionWait "correct reference used with hs-boot" $ do
312 let contentB = T.unlines
261 let contentB = T.unlines
@@ -328,10 +277,10 @@ diagnosticTests = testGroup "diagnostics"
328 -- resolved to the hs-boot file
277 -- resolved to the hs-boot file
329 , "y = x"
278 , "y = x"
330 ]
279 ]
331− _ <- createDoc "ModuleB.hs" "haskell" contentB
280+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
332− _ <- createDoc "ModuleA.hs" "haskell" contentA
281+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
333− _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot
282+ _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
334− _ <- createDoc "ModuleC.hs" "haskell" contentC
283+ _ <- openDoc' "ModuleC.hs" "haskell" contentC
335 expectDiagnostics []
284 expectDiagnostics []
336 , testSessionWait "redundant import" $ do
285 , testSessionWait "redundant import" $ do
337 let contentA = T.unlines ["module ModuleA where"]
286 let contentA = T.unlines ["module ModuleA where"]
@@ -340,8 +289,8 @@ diagnosticTests = testGroup "diagnostics"
340 , "module ModuleB where"
289 , "module ModuleB where"
341 , "import ModuleA"
290 , "import ModuleA"
342 ]
291 ]
343− _ <- createDoc "ModuleA.hs" "haskell" contentA
292+ _ <- openDoc' "ModuleA.hs" "haskell" contentA
344− _ <- createDoc "ModuleB.hs" "haskell" contentB
293+ _ <- openDoc' "ModuleB.hs" "haskell" contentB
345 expectDiagnostics
294 expectDiagnostics
346 [ ( "ModuleB.hs"
295 [ ( "ModuleB.hs"
347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
296 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
@@ -350,7 +299,6 @@ diagnosticTests = testGroup "diagnostics"
350 , testSessionWait "package imports" $ do
299 , testSessionWait "package imports" $ do
351 let thisDataListContent = T.unlines
300 let thisDataListContent = T.unlines
352 [ "module Data.List where"
301 [ "module Data.List where"
353− , "x :: Integer"
354 , "x = 123"
302 , "x = 123"
355 ]
303 ]
356 let mainContent = T.unlines
304 let mainContent = T.unlines
@@ -363,8 +311,8 @@ diagnosticTests = testGroup "diagnostics"
363 , "wrong1 = ThisList.map"
311 , "wrong1 = ThisList.map"
364 , "wrong2 = BaseList.x"
312 , "wrong2 = BaseList.x"
365 ]
313 ]
366− _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
314+ _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent
367− _ <- createDoc "Main.hs" "haskell" mainContent
315+ _ <- openDoc' "Main.hs" "haskell" mainContent
368 expectDiagnostics
316 expectDiagnostics
369 [ ( "Main.hs"
317 [ ( "Main.hs"
370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
318 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
@@ -379,7 +327,7 @@ diagnosticTests = testGroup "diagnostics"
379 , "foo :: Ord a => a -> Int"
327 , "foo :: Ord a => a -> Int"
380 , "foo a = 1"
328 , "foo a = 1"
381 ]
329 ]
382− _ <- createDoc "Foo.hs" "haskell" fooContent
330+ _ <- openDoc' "Foo.hs" "haskell" fooContent
383 expectDiagnostics
331 expectDiagnostics
384 [ ( "Foo.hs"
332 [ ( "Foo.hs"
385 -- The test is to make sure that warnings contain unqualified names
333 -- The test is to make sure that warnings contain unqualified names
@@ -404,18 +352,18 @@ diagnosticTests = testGroup "diagnostics"
404 Just pathB <- pure $ uriToFilePath uriB
352 Just pathB <- pure $ uriToFilePath uriB
405 uriB <- pure $
353 uriB <- pure $
406 let (drive, suffix) = splitDrive pathB
354 let (drive, suffix) = splitDrive pathB
407− in filePathToUri (joinDrive (lower drive) suffix)
355+ in filePathToUri (joinDrive (map toLower drive ) suffix)
408 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
356 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
409 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
357 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
410 uriA <- getDocUri "A/A.hs"
358 uriA <- getDocUri "A/A.hs"
411 Just pathA <- pure $ uriToFilePath uriA
359 Just pathA <- pure $ uriToFilePath uriA
412 uriA <- pure $
360 uriA <- pure $
413 let (drive, suffix) = splitDrive pathA
361 let (drive, suffix) = splitDrive pathA
414− in filePathToUri (joinDrive (lower drive) suffix)
362+ in filePathToUri (joinDrive (map toLower drive ) suffix)
415 let itemA = TextDocumentItem uriA "haskell" 0 aContent
363 let itemA = TextDocumentItem uriA "haskell" 0 aContent
416 let a = TextDocumentIdentifier uriA
364 let a = TextDocumentIdentifier uriA
417 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
365 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
418− diagsNot <- skipManyTill anyMessage diagnostic
366+ diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
419 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
367 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
420 -- Check that if we put a lower-case drive in for A.A
368 -- Check that if we put a lower-case drive in for A.A
421 -- the diagnostics for A.B will also be lower-case.
369 -- the diagnostics for A.B will also be lower-case.
@@ -424,38 +372,6 @@ diagnosticTests = testGroup "diagnostics"
424 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
372 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
425 assertFailure ("Expected redundant import but got " <> T.unpack msg)
373 assertFailure ("Expected redundant import but got " <> T.unpack msg)
426 closeDoc a
374 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
459 ]
375 ]
460
376
461codeActionTests :: TestTree
377codeActionTests :: TestTree
@@ -463,46 +379,9 @@ codeActionTests = testGroup "code actions"
463 [ renameActionTests
379 [ renameActionTests
464 , typeWildCardActionTests
380 , typeWildCardActionTests
465 , removeImportTests
381 , removeImportTests
466− , extendImportTests
467− , suggestImportTests
468− , addExtensionTests
469− , fixConstructorImportTests
470 , importRenameActionTests
382 , importRenameActionTests
471 , fillTypedHoleTests
383 , fillTypedHoleTests
472 , addSigActionTests
384 , 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
506 ]
385 ]
507
386
508renameActionTests :: TestTree
387renameActionTests :: TestTree
@@ -513,9 +392,11 @@ renameActionTests = testGroup "rename actions"
513 , "foo :: Int -> Int"
392 , "foo :: Int -> Int"
514 , "foo argName = argNme"
393 , "foo argName = argNme"
515 ]
394 ]
516− doc <- createDoc "Testing.hs" "haskell" content
395+ doc <- openDoc' "Testing.hs" "haskell" content
517 _ <- waitForDiagnostics
396 _ <- waitForDiagnostics
397+ [CACodeAction action@CodeAction { _title = actionTitle }]
518− action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
398+ <- getCodeActions doc (Range (Position 2 14) (Position 2 20))
399+ liftIO $ "Replace with ‘argName’" @=? actionTitle
519 executeCodeAction action
400 executeCodeAction action
520 contentAfterAction <- documentContents doc
401 contentAfterAction <- documentContents doc
521 let expectedContentAfterAction = T.unlines
402 let expectedContentAfterAction = T.unlines
@@ -531,9 +412,11 @@ renameActionTests = testGroup "rename actions"
531 , "foo :: Maybe a -> [a]"
412 , "foo :: Maybe a -> [a]"
532 , "foo = maybToList"
413 , "foo = maybToList"
533 ]
414 ]
534− doc <- createDoc "Testing.hs" "haskell" content
415+ doc <- openDoc' "Testing.hs" "haskell" content
535 _ <- waitForDiagnostics
416 _ <- waitForDiagnostics
417+ [CACodeAction action@CodeAction { _title = actionTitle }]
536− action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
418+ <- getCodeActions doc (Range (Position 3 6) (Position 3 16))
419+ liftIO $ "Replace with ‘maybeToList’" @=? actionTitle
537 executeCodeAction action
420 executeCodeAction action
538 contentAfterAction <- documentContents doc
421 contentAfterAction <- documentContents doc
539 let expectedContentAfterAction = T.unlines
422 let expectedContentAfterAction = T.unlines
@@ -549,11 +432,12 @@ renameActionTests = testGroup "rename actions"
549 , "foo :: Char -> Char -> Char -> Char"
432 , "foo :: Char -> Char -> Char -> Char"
550 , "foo argument1 argument2 argument3 = argumentX"
433 , "foo argument1 argument2 argument3 = argumentX"
551 ]
434 ]
552− doc <- createDoc "Testing.hs" "haskell" content
435+ doc <- openDoc' "Testing.hs" "haskell" content
553 _ <- waitForDiagnostics
436 _ <- waitForDiagnostics
554− _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
437+ actionsOrCommands <- getCodeActions doc (Range (Position 2 36) (Position 2 45))
438+ let actionTitles = [ actionTitle | CACodeAction CodeAction{ _title = actionTitle } <- actionsOrCommands ]
555− ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
439+ expectedActionTitles = ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
556− return()
440+ liftIO $ expectedActionTitles @=? actionTitles
557 , testSession "change infix function" $ do
441 , testSession "change infix function" $ do
558 let content = T.unlines
442 let content = T.unlines
559 [ "module Testing where"
443 [ "module Testing where"
@@ -561,7 +445,7 @@ renameActionTests = testGroup "rename actions"
561 , "monus x y = max 0 (x - y)"
445 , "monus x y = max 0 (x - y)"
562 , "foo x y = x `monnus` y"
446 , "foo x y = x `monnus` y"
563 ]
447 ]
564− doc <- createDoc "Testing.hs" "haskell" content
448+ doc <- openDoc' "Testing.hs" "haskell" content
565 _ <- waitForDiagnostics
449 _ <- waitForDiagnostics
566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
450 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
567 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
451 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
@@ -584,7 +468,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
584 , "func :: _"
468 , "func :: _"
585 , "func x = x"
469 , "func x = x"
586 ]
470 ]
587− doc <- createDoc "Testing.hs" "haskell" content
471+ doc <- openDoc' "Testing.hs" "haskell" content
588 _ <- waitForDiagnostics
472 _ <- waitForDiagnostics
589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
473 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
474 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -604,7 +488,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
604 , "func :: _"
488 , "func :: _"
605 , "func x y = x + y"
489 , "func x y = x + y"
606 ]
490 ]
607− doc <- createDoc "Testing.hs" "haskell" content
491+ doc <- openDoc' "Testing.hs" "haskell" content
608 _ <- waitForDiagnostics
492 _ <- waitForDiagnostics
609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
493 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
494 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -627,7 +511,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
627 , " y = x * 2"
511 , " y = x * 2"
628 , " in y"
512 , " in y"
629 ]
513 ]
630− doc <- createDoc "Testing.hs" "haskell" content
514+ doc <- openDoc' "Testing.hs" "haskell" content
631 _ <- waitForDiagnostics
515 _ <- waitForDiagnostics
632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
516 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
517 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -652,15 +536,14 @@ removeImportTests = testGroup "remove import actions"
652 let contentA = T.unlines
536 let contentA = T.unlines
653 [ "module ModuleA where"
537 [ "module ModuleA where"
654 ]
538 ]
655− _docA <- createDoc "ModuleA.hs" "haskell" contentA
539+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
656 let contentB = T.unlines
540 let contentB = T.unlines
657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
541 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
658 , "module ModuleB where"
542 , "module ModuleB where"
659 , "import ModuleA"
543 , "import ModuleA"
660− , "stuffB :: Integer"
661 , "stuffB = 123"
544 , "stuffB = 123"
662 ]
545 ]
663− docB <- createDoc "ModuleB.hs" "haskell" contentB
546+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
664 _ <- waitForDiagnostics
547 _ <- waitForDiagnostics
665 [CACodeAction action@CodeAction { _title = actionTitle }]
548 [CACodeAction action@CodeAction { _title = actionTitle }]
666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
549 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -670,7 +553,6 @@ removeImportTests = testGroup "remove import actions"
670 let expectedContentAfterAction = T.unlines
553 let expectedContentAfterAction = T.unlines
671 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
554 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
672 , "module ModuleB where"
555 , "module ModuleB where"
673− , "stuffB :: Integer"
674 , "stuffB = 123"
556 , "stuffB = 123"
675 ]
557 ]
676 liftIO $ expectedContentAfterAction @=? contentAfterAction
558 liftIO $ expectedContentAfterAction @=? contentAfterAction
@@ -678,15 +560,14 @@ removeImportTests = testGroup "remove import actions"
678 let contentA = T.unlines
560 let contentA = T.unlines
679 [ "module ModuleA where"
561 [ "module ModuleA where"
680 ]
562 ]
681− _docA <- createDoc "ModuleA.hs" "haskell" contentA
563+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA
682 let contentB = T.unlines
564 let contentB = T.unlines
683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
565 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
684 , "module ModuleB where"
566 , "module ModuleB where"
685 , "import qualified ModuleA"
567 , "import qualified ModuleA"
686− , "stuffB :: Integer"
687 , "stuffB = 123"
568 , "stuffB = 123"
688 ]
569 ]
689− docB <- createDoc "ModuleB.hs" "haskell" contentB
570+ docB <- openDoc' "ModuleB.hs" "haskell" contentB
690 _ <- waitForDiagnostics
571 _ <- waitForDiagnostics
691 [CACodeAction action@CodeAction { _title = actionTitle }]
572 [CACodeAction action@CodeAction { _title = actionTitle }]
692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
573 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -696,457 +577,10 @@ removeImportTests = testGroup "remove import actions"
696 let expectedContentAfterAction = T.unlines
577 let expectedContentAfterAction = T.unlines
697 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
578 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
698 , "module ModuleB where"
579 , "module ModuleB where"
699− , "stuffB :: Integer"
700 , "stuffB = 123"
580 , "stuffB = 123"
701 ]
581 ]
702 liftIO $ expectedContentAfterAction @=? contentAfterAction
582 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− ])
1051 ]
583 ]
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
1150
584
1151importRenameActionTests :: TestTree
585importRenameActionTests :: TestTree
1152importRenameActionTests = testGroup "import rename actions"
586importRenameActionTests = testGroup "import rename actions"
@@ -1157,7 +591,7 @@ importRenameActionTests = testGroup "import rename actions"
1157 [ "module Testing where"
591 [ "module Testing where"
1158 , "import Data.Mape"
592 , "import Data.Mape"
1159 ]
593 ]
1160− doc <- createDoc "Testing.hs" "haskell" content
594+ doc <- openDoc' "Testing.hs" "haskell" content
1161 _ <- waitForDiagnostics
595 _ <- waitForDiagnostics
1162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
596 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
1163 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
597 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
@@ -1194,10 +628,10 @@ fillTypedHoleTests = let
1194 newA newB newC = testSession (T.unpack actionTitle) $ do
628 newA newB newC = testSession (T.unpack actionTitle) $ do
1195 let originalCode = sourceCode oldA oldB oldC
629 let originalCode = sourceCode oldA oldB oldC
1196 let expectedCode = sourceCode newA newB newC
630 let expectedCode = sourceCode newA newB newC
1197− doc <- createDoc "Testing.hs" "haskell" originalCode
631+ doc <- openDoc' "Testing.hs" "haskell" originalCode
1198 _ <- waitForDiagnostics
632 _ <- waitForDiagnostics
1199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
633 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
1200− chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
634+ let chosenAction = pickActionWithTitle actionTitle actionsOrCommands
1201 executeCodeAction chosenAction
635 executeCodeAction chosenAction
1202 modifiedCode <- documentContents doc
636 modifiedCode <- documentContents doc
1203 liftIO $ expectedCode @=? modifiedCode
637 liftIO $ expectedCode @=? modifiedCode
@@ -1234,81 +668,47 @@ fillTypedHoleTests = let
1234
668
1235addSigActionTests :: TestTree
669addSigActionTests :: TestTree
1236addSigActionTests = let
670addSigActionTests = let
1237− header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"
671+ header = T.unlines [ "{-# OPTIONS_GHC -Wmissing-signatures #-}"
1238− moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
672+ , "module Sigs where"]
1239− before def = T.unlines [header, moduleH, def]
673+ before def = T.unlines [header, def]
1240− after' def sig = T.unlines [header, moduleH, sig, def]
674+ after' def sig = T.unlines [header, sig, def]
1241
675
1242 def >:: sig = testSession (T.unpack def) $ do
676 def >:: sig = testSession (T.unpack def) $ do
1243 let originalCode = before def
677 let originalCode = before def
1244− let expectedCode = after' def sig
678+ let expectedCode = after' def sig
1245− doc <- createDoc "Sigs.hs" "haskell" originalCode
679+ doc <- openDoc' "Sigs.hs" "haskell" originalCode
1246 _ <- waitForDiagnostics
680 _ <- waitForDiagnostics
1247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
681 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
1248− chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
682+ let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
1249 executeCodeAction chosenAction
683 executeCodeAction chosenAction
1250 modifiedCode <- documentContents doc
684 modifiedCode <- documentContents doc
1251 liftIO $ expectedCode @=? modifiedCode
685 liftIO $ expectedCode @=? modifiedCode
1252 in
686 in
1253 testGroup "add signature"
687 testGroup "add signature"
1254− [ "abc = True" >:: "abc :: Bool"
688+ [ "abc = True" >:: "abc :: Bool"
1255− , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
689+ , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
1256− , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"
690+ , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"
1257− , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
691+ , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
1258− , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
692+ , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
1259− , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"
693+ , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"
1260− , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"
1261− ]
694+ ]
1262
695
1263−addSigLensesTests :: TestTree
696+findDefinitionAndHoverTests :: TestTree
1264−addSigLensesTests = let
697+findDefinitionAndHoverTests = 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]
1273
698
1274− sigSession withMissing def sig = testSession (T.unpack def) $ do
699+ tst (get, check) pos targetRange title = testSession title $ do
1275− let originalCode = before withMissing def
700+ doc <- openTestDataDoc sourceFilePath
1276− let expectedCode = after' withMissing def sig
701+ found <- get doc pos
1277− doc <- createDoc "Sigs.hs" "haskell" originalCode
702+ check found targetRange
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− ]
1298
703
1299−checkDefs :: [Location] -> Session [Expect] -> Session ()
704+ checkDefs :: [Location] -> [Expect] -> Session ()
1300−checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
705+ checkDefs defs expectations = traverse_ check expectations where
1301
706
1302− check (ExpectRange expectedRange) = do
707+ check (ExpectRange expectedRange) = do
1303− assertNDefinitionsFound 1 defs
708+ assertNDefinitionsFound 1 defs
1304− assertRangeCorrect (head defs) expectedRange
709+ 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
1310− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
710+ check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1311− check _ = pure () -- all other expectations not relevant to getDefinition
711+ check _ = pure () -- all other expectations not relevant to getDefinition
1312
712
1313 assertNDefinitionsFound :: Int -> [a] -> Session ()
713 assertNDefinitionsFound :: Int -> [a] -> Session ()
1314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
714 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
@@ -1316,35 +716,23 @@ checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
1316 assertRangeCorrect Location{_range = foundRange} expectedRange =
716 assertRangeCorrect Location{_range = foundRange} expectedRange =
1317 liftIO $ expectedRange @=? foundRange
717 liftIO $ expectedRange @=? foundRange
1318
718
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−
1330− checkHover :: Maybe Hover -> Session [Expect] -> Session ()
719+ checkHover :: Maybe Hover -> [Expect] -> Session ()
1331− checkHover hover expectations = traverse_ check =<< expectations where
720+ checkHover hover expectations = traverse_ check expectations where
1332
721
1333 check expected =
722 check expected =
1334 case hover of
723 case hover of
1335− Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
724+ Nothing -> liftIO $ assertFailure "no hover found"
1336 Just Hover{_contents = (HoverContents MarkupContent{_value = msg})
725 Just Hover{_contents = (HoverContents MarkupContent{_value = msg})
1337 ,_range = rangeInHover } ->
726 ,_range = rangeInHover } ->
1338 case expected of
727 case expected of
1339 ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
728 ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
1340 ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
729 ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg
1341 ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
730 ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets
1342− ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover
1343 _ -> pure () -- all other expectations not relevant to hover
731 _ -> pure () -- all other expectations not relevant to hover
1344 _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
732 _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
1345
733
1346 extractLineColFromHoverMsg :: T.Text -> [T.Text]
734 extractLineColFromHoverMsg :: T.Text -> [T.Text]
1347− extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")
735+ extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "**" . last . T.splitOn (sourceFileName <> ":")
1348
736
1349 checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()
737 checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()
1350 checkHoverRange expectedRange rangeInHover msg =
738 checkHoverRange expectedRange rangeInHover msg =
@@ -1371,12 +759,9 @@ findDefinitionAndHoverTests = let
1371
759
1372 mkFindTests tests = testGroup "get"
760 mkFindTests tests = testGroup "get"
1373 [ testGroup "definition" $ mapMaybe fst tests
761 [ testGroup "definition" $ mapMaybe fst tests
1374− , testGroup "hover" $ mapMaybe snd tests
762+ , testGroup "hover" $ mapMaybe snd tests ]
1375− , checkFileCompiles sourceFilePath ]
1376−
1377− test runDef runHover look expect = testM runDef runHover look (return expect)
1378
763
1379− testM runDef runHover look expect title =
764+ test runDef runHover look expect title =
1380 ( runDef $ tst def look expect title
765 ( runDef $ tst def look expect title
1381 , runHover $ tst hover look expect title ) where
766 , runHover $ tst hover look expect title ) where
1382 def = (getDefinitions, checkDefs)
767 def = (getDefinitions, checkDefs)
@@ -1384,100 +769,59 @@ findDefinitionAndHoverTests = let
1384 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
769 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
1385
770
1386 -- search locations expectations on results
771 -- search locations expectations on results
1387− fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR]
772+ fffL4 = _start fffR ; fffR = mkRange 4 4 4 7 ; fff = [ExpectRange fffR]
1388− fffL8 = Position 12 4 ;
773+ fffL8 = Position 8 4 ;
1389− fffL14 = Position 18 7 ;
774+ fffL14 = Position 14 7 ;
1390− aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]
775+ aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]
1391− dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]
776+ dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]
1392− dcL12 = Position 16 11 ;
777+ dcL12 = Position 12 11 ;
1393− xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
778+ xtcL5 = Position 5 11 ; xtc = [ExpectExternFail]
1394− tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]]
779+ tcL6 = Position 6 11 ; tcData = [mkR 3 0 5 16]
1395− vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6]
780+ vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]
1396− opL16 = Position 20 15 ; op = [mkR 21 2 21 4]
781+ opL16 = Position 16 15 ; op = [mkR 17 2 17 4]
1397− opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]
782+ opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]
1398− aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]
783+ aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]
1399− b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]
784+ b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]
1400− xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
785+ xvL20 = Position 20 8 ; xvMsg = [ExpectHoverText ["Data.Text.pack", ":: String -> Text"], ExpectExternFail]
1401− clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]]
786+ clL23 = Position 23 11 ; cls = [mkR 21 0 22 20]
1402− clL25 = Position 29 9
787+ clL25 = Position 25 9
1403− eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
788+ eclL15 = Position 15 8 ; ecls = [ExpectHoverText ["Num"], ExpectExternFail]
1404− dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21]
789+ dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]
1405− dnbL30 = Position 34 23
790+ dnbL30 = Position 30 23
1406− lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27]
791+ lcbL33 = Position 33 26 ; lcb = [ExpectHoverText [":: Char"], mkR 33 26 33 27]
1407− lclL33 = Position 37 22
792+ lclL33 = Position 33 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]
1424 in
793 in
1425 mkFindTests
794 mkFindTests
1426− -- def hover look expect
795+ -- def hover look expect
1427− [ test yes yes fffL4 fff "field in record definition"
796+ [ test yes yes fffL4 fff "field in record definition"
1428− , test broken broken fffL8 fff "field in record construction #71"
797+ , test broken broken fffL8 fff "field in record construction"
1429− , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
798+ , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
1430− , test yes yes aaaL14 aaa "top-level name" -- 120
799+ , test yes yes aaaL14 aaa "top-level name" -- 120
1431− , test yes yes dcL7 tcDC "data constructor record #247"
800+ , test broken broken dcL7 tcDC "record data constructor"
1432− , test yes yes dcL12 tcDC "data constructor plain" -- 121
801+ , test yes yes dcL12 tcDC "plain data constructor" -- 121
1433− , test yes yes tcL6 tcData "type constructor #248" -- 147
802+ , test yes broken tcL6 tcData "type constructor" -- 147
1434− , test broken yes xtcL5 xtc "type constructor external #248,249"
803+ , test broken broken xtcL5 xtc "type constructor from other package"
1435− , test broken yes xvL20 xvMsg "value external package #249" -- 120
804+ , test broken yes xvL20 xvMsg "value from other package" -- 120
1436− , test yes yes vvL16 vv "plain parameter" -- 120
805+ , test yes yes vvL16 vv "plain parameter" -- 120
1437− , test yes yes aL18 apmp "pattern match name" -- 120
806+ , test yes yes aL18 apmp "pattern match name" -- 120
1438− , test yes yes opL16 op "top-level operator" -- 120, 123
807+ , test yes yes opL16 op "top-level operator" -- 120, 123
1439− , test yes yes opL18 opp "parameter operator" -- 120
808+ , test yes yes opL18 opp "parameter operator" -- 120
1440− , test yes yes b'L19 bp "name in backticks" -- 120
809+ , test yes yes b'L19 bp "name in backticks" -- 120
1441− , test yes yes clL23 cls "class in instance declaration #250"
810+ , test yes broken clL23 cls "class in instance declaration"
1442− , test yes yes clL25 cls "class in signature #250" -- 147
811+ , test yes broken clL25 cls "class in signature" -- 147
1443− , test broken yes eclL15 ecls "external class in signature #249,250"
812+ , test broken broken eclL15 ecls "external class in signature"
1444− , test yes yes dnbL29 dnb "do-notation bind" -- 137
813+ , test yes yes dnbL29 dnb "do-notation bind" -- 137
1445− , test yes yes dnbL30 dnb "do-notation lookup"
814+ , test yes yes dnbL30 dnb "do-notation lookup"
1446− , test yes yes lcbL33 lcb "listcomp bind" -- 137
815+ , test yes yes lcbL33 lcb "listcomp bind" -- 137
1447− , test yes yes lclL33 lcb "listcomp lookup"
816+ , 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)"
1464 ]
817 ]
1465 where yes, broken :: (TestTree -> Maybe TestTree)
818 where yes, broken :: (TestTree -> Maybe TestTree)
1466 yes = Just -- test should run and pass
819 yes = Just -- test should run and pass
1467 broken = Just . (`xfail` "known broken")
820 broken = Just . (`xfail` "known broken")
1468− no = const Nothing -- don't run this test at all
821+ -- 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−
1477
822
1478pluginTests :: TestTree
823pluginTests :: TestTree
1479−pluginTests = (`xfail8101` "known broken (#556)")
1480− $ testSessionWait "plugins" $ do
824+pluginTests = testSessionWait "plugins" $ do
1481 let content =
825 let content =
1482 T.unlines
826 T.unlines
1483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
827 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
@@ -1491,100 +835,13 @@ pluginTests = (`xfail8101` "known broken (#556)")
1491 , "foo :: Int -> Int -> Int"
835 , "foo :: Int -> Int -> Int"
1492 , "foo a b = a + c"
836 , "foo a b = a + c"
1493 ]
837 ]
1494− _ <- createDoc "Testing.hs" "haskell" content
838+ _ <- openDoc' "Testing.hs" "haskell" content
1495 expectDiagnostics
839 expectDiagnostics
1496 [ ( "Testing.hs",
840 [ ( "Testing.hs",
1497 [(DsError, (8, 14), "Variable not in scope: c")]
841 [(DsError, (8, 14), "Variable not in scope: c")]
1498 )
842 )
1499 ]
843 ]
1500
844
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−
1588thTests :: TestTree
845thTests :: TestTree
1589thTests =
846thTests =
1590 testGroup
847 testGroup
@@ -1610,586 +867,24 @@ thTests =
1610 "b :: Integer",
867 "b :: Integer",
1611 "b = $(litE $ IntegerL $ a) + n"
868 "b = $(litE $ IntegerL $ a) + n"
1612 ]
869 ]
1613− _ <- createDoc "A.hs" "haskell" sourceA
870+ _ <- openDoc' "A.hs" "haskell" sourceA
1614− _ <- createDoc "B.hs" "haskell" sourceB
871+ _ <- openDoc' "B.hs" "haskell" sourceB
1615 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
872 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 "*")]
1723 ]
873 ]
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')
1948
874
1949xfail :: TestTree -> String -> TestTree
875xfail :: TestTree -> String -> TestTree
1950xfail = flip expectFailBecause
876xfail = flip expectFailBecause
1951
877
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−
1959data Expect
878data Expect
1960 = ExpectRange Range -- Both gotoDef and hover should report this range
879 = ExpectRange Range -- Both gotoDef and hover should report this range
1961− | ExpectLocation Location
1962-- | ExpectDefRange Range -- Only gotoDef should report this range
880-- | ExpectDefRange Range -- Only gotoDef should report this range
1963 | ExpectHoverRange Range -- Only hover should report this range
881 | ExpectHoverRange Range -- Only hover should report this range
1964 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
882 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
1965 | ExpectExternFail -- definition lookup in other file expected to fail
883 | ExpectExternFail -- definition lookup in other file expected to fail
1966− | ExpectNoDefinitions
1967− | ExpectNoHover
1968-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
884-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples
1969− deriving Eq
1970
885
1971mkR :: Int -> Int -> Int -> Int -> Expect
886mkR :: Int -> Int -> Int -> Int -> Expect
1972mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
887mkR 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−
2193----------------------------------------------------------------------
888----------------------------------------------------------------------
2194-- Utils
889-- Utils
2195
890
@@ -2197,12 +892,6 @@ sessionDepsArePickedUp = testSession'
2197testSession :: String -> Session () -> TestTree
892testSession :: String -> Session () -> TestTree
2198testSession name = testCase name . run
893testSession name = testCase name . run
2199
894
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−
2206testSessionWait :: String -> Session () -> TestTree
895testSessionWait :: String -> Session () -> TestTree
2207testSessionWait name = testSession name .
896testSessionWait name = testSession name .
2208 -- Check that any diagnostics produced were already consumed by the test case.
897 -- Check that any diagnostics produced were already consumed by the test case.
@@ -2213,284 +902,35 @@ testSessionWait name = testSession name .
2213 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.
902 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.
2214 ( >> expectNoMoreDiagnostics 0.5)
903 ( >> expectNoMoreDiagnostics 0.5)
2215
904
2216−pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction
905+pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction
2217−pickActionWithTitle title actions = do
906+pickActionWithTitle title actions = head
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 =
2226− [ action
907+ [ action
2227− | CACodeAction action@CodeAction { _title = actionTitle } <- actions
908+ | CACodeAction action@CodeAction{ _title = actionTitle } <- actions
2228− , title == actionTitle
909+ , title == actionTitle ]
2229− ]
2230
910
2231mkRange :: Int -> Int -> Int -> Int -> Range
911mkRange :: Int -> Int -> Int -> Int -> Range
2232mkRange a b c d = Range (Position a b) (Position c d)
912mkRange a b c d = Range (Position a b) (Position c d)
2233
913
2234run :: Session a -> IO a
914run :: Session a -> IO a
2235−run s = withTempDir $ \dir -> runInDir dir s
915+run s = withTempDir $ \dir -> do
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
2255 ghcideExe <- locateGhcideExecutable
916 ghcideExe <- locateGhcideExecutable
2256
917
2257 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
918 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
2258 -- since the package import test creates "Data/List.hs", which otherwise has no physical home
919 -- since the package import test creates "Data/List.hs", which otherwise has no physical home
2259 createDirectoryIfMissing True $ dir ++ "/Data"
920 createDirectoryIfMissing True $ dir ++ "/Data"
2260
921
2261−
2262− let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
922+ let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]
2263 -- HIE calls getXgdDirectory which assumes that HOME is set.
923 -- HIE calls getXgdDirectory which assumes that HOME is set.
2264 -- Only sets HOME if it wasn't already set.
924 -- Only sets HOME if it wasn't already set.
2265 setEnv "HOME" "/homeless-shelter" False
925 setEnv "HOME" "/homeless-shelter" False
2266− let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }
926+ runSessionWithConfig conf cmd fullCaps { _window = Just $ WindowClientCapabilities $ Just True } dir s
2267− runSessionWithConfig conf cmd lspTestCaps dir s
2268 where
927 where
2269 conf = defaultConfig
928 conf = defaultConfig
2270− -- If you uncomment this you can see all logging
929+ -- If you uncomment this you can see all messages
2271 -- which can be quite useful for debugging.
930 -- which can be quite useful for debugging.
2272− -- { logStdErr = True, logColor = False }
2273− -- If you really want to, you can also see all messages
2274− -- { logMessages = True, logColor = False }
931+ -- { logMessages = True, logColor = False, logStdErr = True }
2275
932
2276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
933openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
2277openTestDataDoc path = do
934openTestDataDoc path = do
2278 source <- liftIO $ readFileUtf8 $ "test/data" </> path
935 source <- liftIO $ readFileUtf8 $ "test/data" </> path
2279− createDoc path "haskell" source
936+ openDoc' 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.hsdeleted−10
@@ -1,10 +0,0 @@
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+2−8
@@ -1,13 +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 DuplicateRecordFields #-}
5−
6module Development.IDE.Test
4module Development.IDE.Test
7 ( Cursor
5 ( Cursor
8 , cursorPosition
6 , cursorPosition
9 , requireDiagnostic
7 , requireDiagnostic
10− , diagnostic
11 , expectDiagnostics
8 , expectDiagnostics
12 , expectNoMoreDiagnostics
9 , expectNoMoreDiagnostics
13 ) where
10 ) where
@@ -18,7 +15,7 @@ import Control.Monad
18import Control.Monad.IO.Class
15import Control.Monad.IO.Class
19import qualified Data.Map.Strict as Map
16import qualified Data.Map.Strict as Map
20import qualified Data.Text as T
17import qualified Data.Text as T
21−import Language.Haskell.LSP.Test hiding (message)
18+import Language.Haskell.LSP.Test hiding (message, openDoc')
22import qualified Language.Haskell.LSP.Test as LspTest
19import qualified Language.Haskell.LSP.Test as LspTest
23import Language.Haskell.LSP.Types
20import Language.Haskell.LSP.Types
24import Language.Haskell.LSP.Types.Lens as Lsp
21import Language.Haskell.LSP.Types.Lens as Lsp
@@ -80,7 +77,7 @@ expectDiagnostics expected = do
80 go m
77 go m
81 | Map.null m = pure ()
78 | Map.null m = pure ()
82 | otherwise = do
79 | otherwise = do
83− diagsNot <- skipManyTill anyMessage diagnostic
80+ diagsNot <- skipManyTill anyMessage LspTest.message :: Session PublishDiagnosticsNotification
84 let fileUri = diagsNot ^. params . uri
81 let fileUri = diagsNot ^. params . uri
85 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of
82 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of
86 Nothing -> do
83 Nothing -> do
@@ -99,9 +96,6 @@ expectDiagnostics expected = do
99 " but got " <> show actual
96 " but got " <> show actual
100 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m
97 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m
101
98
102−diagnostic :: Session PublishDiagnosticsNotification
103−diagnostic = LspTest.message
104−
105standardizeQuotes :: T.Text -> T.Text
99standardizeQuotes :: T.Text -> T.Text
106standardizeQuotes msg = let
100standardizeQuotes msg = let
107 repl '‘' = '\''
101 repl '‘' = '\''