git.iko.soy/ghcide
on master help sign in
swap
5a754e1102 ahead, 0 behind
.azure/linux-stack.ymlnew file+63
since splitsnapshots
unifiedsplit
@@ -0,0 +1,63 @@
1+jobs:
2+- job: ghcide_stack_linux
3+ timeoutInMinutes: 60
4+ pool:
5+ vmImage: 'ubuntu-latest'
6+ strategy:
7+ matrix:
8+ stack_810:
9+ STACK_YAML: "stack810.yaml"
10+ stack_88:
11+ STACK_YAML: "stack88.yaml"
12+ stack_86:
13+ STACK_YAML: "stack.yaml"
14+ stack_84:
15+ STACK_YAML: "stack84.yaml"
16+ stack_ghc_lib_88:
17+ STACK_YAML: "stack-ghc-lib.yaml"
18+ steps:
19+ - checkout: self
20+ - task: Cache@2
21+ inputs:
22+ key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/$(STACK_YAML) | $(Build.SourcesDirectory)/ghcide.cabal
23+ path: .azure-cache
24+ cacheHitVar: CACHE_RESTORED
25+ displayName: "Cache stack artifacts"
26+ - bash: |
27+ mkdir -p ~/.stack
28+ tar xzf .azure-cache/stack-root.tar.gz -C $HOME
29+ displayName: "Unpack cache"
30+ condition: eq(variables.CACHE_RESTORED, 'true')
31+ - bash: |
32+ ./fmt.sh
33+ displayName: "HLint via ./fmt.sh"
34+ - bash: |
35+ sudo add-apt-repository ppa:hvr/ghc
36+ sudo apt-get update
37+ sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev cabal-install-3.2
38+ if ! which stack >/dev/null 2>&1; then
39+ curl -sSL https://get.haskellstack.org/ | sh
40+ fi
41+ displayName: 'Install Stack'
42+ - bash: stack setup --stack-yaml=$STACK_YAML
43+ displayName: 'stack setup'
44+ - bash: stack build --only-dependencies --stack-yaml=$STACK_YAML
45+ displayName: 'stack build --only-dependencies'
46+ - bash: |
47+ export PATH=/opt/cabal/bin:$PATH
48+ stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML || stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML|| stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML
49+ # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.
50+ displayName: 'stack test --ghc-options=-Werror'
51+ - bash: |
52+ mkdir -p .azure-cache
53+ tar czf .azure-cache/stack-root.tar.gz -C $HOME .stack
54+ displayName: "Pack cache"
55+ - bash: |
56+ set -euo pipefail
57+ MESSAGE=$(git log --pretty=format:%s -n1)
58+ curl -XPOST \
59+ -i \
60+ -H 'Content-type: application/json' \
61+ --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \
62+ $(Slack.URL)
63+ condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))
.azure/windows-stack.ymlnew file+68
@@ -0,0 +1,68 @@
1+jobs:
2+- job: ghcide_stack_windows
3+ timeoutInMinutes: 60
4+ pool:
5+ vmImage: 'windows-2019'
6+ strategy:
7+ matrix:
8+ stack_810:
9+ STACK_YAML: "stack810.yaml"
10+ stack_88:
11+ STACK_YAML: "stack88.yaml"
12+ stack_86:
13+ STACK_YAML: "stack.yaml"
14+ stack_84:
15+ STACK_YAML: "stack84.yaml"
16+ stack_ghc_lib_88:
17+ STACK_YAML: "stack-ghc-lib.yaml"
18+ variables:
19+ STACK_ROOT: "C:\\sr"
20+ steps:
21+ - checkout: self
22+ - task: Cache@2
23+ inputs:
24+ key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/$(STACK_YAML) | $(Build.SourcesDirectory)/ghcide.cabal
25+ path: .azure-cache
26+ cacheHitVar: CACHE_RESTORED
27+ displayName: "Cache stack artifacts"
28+ - bash: |
29+ mkdir -p $STACK_ROOT
30+ tar -vxzf .azure-cache/stack-root.tar.gz -C /c
31+ mkdir -p .stack-work
32+ tar -vxzf .azure-cache/stack-work.tar.gz
33+ displayName: "Unpack cache"
34+ condition: eq(variables.CACHE_RESTORED, 'true')
35+ - bash: |
36+ ./fmt.sh
37+ displayName: "HLint via ./fmt.sh"
38+ - bash: |
39+ curl -sSkL http://www.stackage.org/stack/windows-x86_64 -o /usr/bin/stack.zip
40+ unzip -o /usr/bin/stack.zip -d /usr/bin/
41+ mkdir -p "$STACK_ROOT"
42+ displayName: 'Install Stack'
43+ - bash: stack setup --stack-yaml $STACK_YAML
44+ displayName: 'stack setup'
45+ - bash: |
46+ # Installing happy and alex standalone to avoid error "strip.exe: unable to rename ../*.exe; reason: File exists"
47+ stack install happy --stack-yaml $STACK_YAML
48+ stack install alex --stack-yaml $STACK_YAML
49+ stack install cabal-install --stack-yaml $STACK_YAML
50+ stack build --only-dependencies --stack-yaml $STACK_YAML
51+ displayName: 'stack build --only-dependencies'
52+ - bash: stack test --no-run-tests --ghc-options=-Werror --stack-yaml $STACK_YAML
53+ displayName: 'stack test --ghc-options=-Werror'
54+ # TODO: run test suite when failing tests are fixed or marked as broken. See https://github.com/digital-asset/ghcide/issues/474
55+ - bash: |
56+ mkdir -p .azure-cache
57+ tar -vczf .azure-cache/stack-root.tar.gz $(cygpath $STACK_ROOT)
58+ tar -vczf .azure-cache/stack-work.tar.gz .stack-work
59+ displayName: "Pack cache"
60+ - bash: |
61+ set -euo pipefail
62+ MESSAGE=$(git log --pretty=format:%s -n1)
63+ curl -XPOST \
64+ -i \
65+ -H 'Content-type: application/json' \
66+ --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \
67+ $(Slack.URL)
68+ condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))
.editorconfignew file+11
@@ -0,0 +1,11 @@
1+; This file is for unifying the coding style for different editors and IDEs.
2+; More information at https://EditorConfig.org
3+
4+root = true
5+
6+[*]
7+end_of_line = LF
8+indent_style = space
9+indent_size = 4
10+trim_trailing_whitespace = true
11+insert_final_newline = true
.ghcideleted−25
@@ -1,25 +0,0 @@
1−:set -Wunused-binds -Wunused-imports -Worphans -Wunused-matches -Wincomplete-patterns
2−
3−:set -XBangPatterns
4−:set -XDeriveFunctor
5−:set -XDeriveGeneric
6−:set -XGeneralizedNewtypeDeriving
7−:set -XLambdaCase
8−:set -XNamedFieldPuns
9−:set -XOverloadedStrings
10−:set -XRecordWildCards
11−:set -XScopedTypeVariables
12−:set -XStandaloneDeriving
13−:set -XTupleSections
14−:set -XTypeApplications
15−:set -XViewPatterns
16−
17−:set -package=ghc
18−:set -ignore-package=ghc-lib-parser
19−:set -DGHC_STABLE
20−:set -Iinclude
21−:set -idist/build/autogen
22−:set -isrc
23−:set -iexe
24−
25−:load Main
.gitignore+4
@@ -4,3 +4,7 @@ dist-newstyle/
4cabal.project.local
4cabal.project.local
5*~
5*~
6*.lock
6*.lock
7+/.tasty-rerun-log
8+.vscode
9+/.hlint-*
10+bench/example
.hlint.yaml+5−1
@@ -73,18 +73,22 @@
73 - {name: ViewPatterns, within: []}
73 - {name: ViewPatterns, within: []}
74
74
75 # Shady extensions
75 # Shady extensions
76− - {name: ImplicitParams, within: []}
77 - name: CPP
76 - name: CPP
78 within:
77 within:
78+ - Development.IDE.Compat
79 - Development.IDE.Core.FileStore
79 - Development.IDE.Core.FileStore
80 - Development.IDE.Core.Compile
80 - Development.IDE.Core.Compile
81+ - Development.IDE.Core.Rules
81 - Development.IDE.GHC.Compat
82 - Development.IDE.GHC.Compat
83+ - Development.IDE.GHC.Orphans
82 - Development.IDE.GHC.Util
84 - Development.IDE.GHC.Util
83 - Development.IDE.Import.FindImports
85 - Development.IDE.Import.FindImports
86+ - Development.IDE.LSP.Outline
84 - Development.IDE.Spans.Calculate
87 - Development.IDE.Spans.Calculate
85 - Development.IDE.Spans.Documentation
88 - Development.IDE.Spans.Documentation
86 - Development.IDE.Spans.Common
89 - Development.IDE.Spans.Common
87 - Development.IDE.Plugin.CodeAction
90 - Development.IDE.Plugin.CodeAction
91+ - Development.IDE.Plugin.Completions
88 - Development.IDE.Plugin.Completions.Logic
92 - Development.IDE.Plugin.Completions.Logic
89 - Main
93 - Main
90
94
CHANGELOG.md+35
@@ -1,5 +1,40 @@
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+
3### 0.0.6 (2020-01-10)
38### 0.0.6 (2020-01-10)
4
39
5* Fix type in hover information for do-notation and list
40* Fix type in hover information for do-notation and list
README.md+62−3
@@ -25,13 +25,40 @@ There are more details about our approach [in this blog post](https://4ta.uk/p/s
25| Display type and source module of values | hover |
25| Display type and source module of values | hover |
26| Remove redundant imports, replace suggested typos for values and module imports, fill type holes, insert missing type signatures, add suggested ghc extensions | codeAction (quickfix) |
26| Remove redundant imports, replace suggested typos for values and module imports, fill type holes, insert missing type signatures, add suggested ghc extensions | codeAction (quickfix) |
27
27
28+
29+## Limitations to Multi-Component support
30+
31+`ghcide` supports loading multiple components into the same session so that
32+features such as go-to definition work across components. However, there are
33+some limitations to this.
34+
35+1. You will get much better results currently manually specifying the hie.yaml file.
36+Until tools like cabal and stack provide the right interface to support multi-component
37+projects, it is always advised to specify explicitly how your project partitions.
38+2. Cross-component features only work if you have loaded at least one file
39+from each component.
40+3. There is a known issue where if you have three components, such that A depends on B which depends on C
41+then if you load A and C into the session but not B then under certain situations you
42+can get strange errors about a type coming from two different places. See [this repo](https://github.com/fendor/ghcide-bad-interface-files) for
43+a simple reproduction of the bug.
44+
28## Using it
45## Using it
29
46
30### Install `ghcide`
47### Install `ghcide`
31
48
32#### With Nix
49#### With Nix
33
50
51+Note that you need to compile `ghcide` with the same `ghc` as the project you are working on.
52+
53+1. If the `ghc` you are using matches the version (or better is) from `nixpkgs` it‘s easiest to use the `ghcide` from `nixpkgs`. You can do so via
54+ ```
55+ nix-env -iA haskellPackages.ghcide
56+ ```
57+ or e.g. including `pkgs.haskellPackages.ghcide` in your projects `shell.nix`.
58+ Depending on your `nixpkgs` channel that might not be the newest `ghcide`, though.
59+
34−[See ghcide-nix repository](https://github.com/hercules-ci/ghcide-nix)
60+2. If your `ghc` does not match nixpkgs you should try the [ghcide-nix repository](https://github.com/cachix/ghcide-nix)
61+ which provides a `ghcide` via the `haskell.nix` infrastructure.
35
62
36#### With Cabal or Stack
63#### With Cabal or Stack
37
64
@@ -64,6 +91,10 @@ The `ghcide` executable mostly relies on [`hie-bios`](https://github.com/mpicker
64
91
65If you can't get `ghcide` working outside the editor, see [this setup troubleshooting guide](docs/Setup.md). Once you have got `ghcide` working outside the editor, the next step is to pick which editor to integrate with.
92If you can't get `ghcide` working outside the editor, see [this setup troubleshooting guide](docs/Setup.md). Once you have got `ghcide` working outside the editor, the next step is to pick which editor to integrate with.
66
93
94+### Optimal project setup
95+
96+`ghcide` has been designed to handle projects with hundreds or thousands of modules. If `ghci` can handle it, then `ghcide` should be able to handle it. The only caveat is that this currently requires GHC >= 8.6, and that the first time a module is loaded in the editor will trigger generation of support files in the background if those do not already exist.
97+
67### Using with VS Code
98### Using with VS Code
68
99
69You can install the VSCode extension from the [VSCode
100You can install the VSCode extension from the [VSCode
@@ -203,7 +234,11 @@ Add this to your coc-settings.json (which you can edit with :CocConfig):
203```
234```
204
235
205Here's a nice article on setting up neovim and coc: [Vim and Haskell in
236Here's a nice article on setting up neovim and coc: [Vim and Haskell in
206−2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/)
237+2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/) (this is actually for haskell-ide, not ghcide)
238+
239+Here is a Docker container that pins down the build and configuration for
240+Neovim and ghcide on a minimal Debian 10 base system:
241+[docker-ghcide-neovim](https://github.com/carlohamalainen/docker-ghcide-neovim/).
207
242
208### SpaceVim
243### SpaceVim
209
244
@@ -248,10 +283,32 @@ Add this to your coc-settings.json (which you can edit with :CocConfig):
248This example above describes a setup in which `ghcide` is installed
283This example above describes a setup in which `ghcide` is installed
249using `stack install ghcide` within a project.
284using `stack install ghcide` within a project.
250
285
286+### Using with Kakoune
287+
288+Install [kak-lsp](https://github.com/ul/kak-lsp).
289+
290+Change `kak-lsp.toml` to include this:
291+
292+```toml
293+[language.haskell]
294+filetypes = ["haskell"]
295+roots = ["Setup.hs", "stack.yaml", "*.cabal", "cabal.project", "hie.yaml"]
296+command = "ghcide"
297+args = ["--lsp"]
298+```
299+
251## Hacking on ghcide
300## Hacking on ghcide
252
301
253To build and work on `ghcide` itself, you can use Stack or cabal, e.g.,
302To build and work on `ghcide` itself, you can use Stack or cabal, e.g.,
254running `stack test` will execute the test suite.
303running `stack test` will execute the test suite.
304+If you are using Windows, you should disable the `auto.crlf` setting and configure your editor to use LF line endings, directly or making it use the existing `.editor-config`.
305+
306+If you are chasing down test failures, you can use the tasty-rerun feature by running tests as
307+
308+ stack --stack-yaml=stack84.yaml test --test-arguments "--rerun"
309+
310+This writes a log file called `.tasty-rerun-log` of the failures, and only runs those.
311+See the [tasty-rerun](https://hackage.haskell.org/package/tasty-rerun-1.1.17/docs/Test-Tasty-Ingredients-Rerun.html) documentation for other options.
255
312
256### Building the extension
313### Building the extension
257
314
@@ -268,8 +325,10 @@ Now opening a `.hs` file should work with `ghcide`.
268
325
269## History and relationship to other Haskell IDE's
326## History and relationship to other Haskell IDE's
270
327
328+The teams behind this project and the [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme) have agreed to join forces under the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server), see the [original announcement](https://neilmitchell.blogspot.com/2020/01/one-haskell-ide-to-rule-them-all.html). The technical work is ongoing, with the likely model being that this project serves as the core, while plugins and integrations are kept in the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server).
329+
271The code behind `ghcide` was originally developed by [Digital Asset](https://digitalasset.com/) as part of the [DAML programming language](https://github.com/digital-asset/daml). DAML is a smart contract language targeting distributed-ledger runtimes, based on [GHC](https://www.haskell.org/ghc/) with custom language extensions. The DAML programming language has [an IDE](https://webide.daml.com/), and work was done to separate off a reusable Haskell-only IDE (what is now `ghcide`) which the [DAML IDE then builds upon](https://github.com/digital-asset/daml/tree/master/compiler/damlc). Since that time, there have been various [non-Digital Asset contributors](https://github.com/digital-asset/ghcide/graphs/contributors), in addition to continued investment by Digital Asset. All contributions require a [Contributor License Agreement](https://cla.digitalasset.com/digital-asset/ghcide) that states you license the code under the [Apache License](LICENSE).
330The code behind `ghcide` was originally developed by [Digital Asset](https://digitalasset.com/) as part of the [DAML programming language](https://github.com/digital-asset/daml). DAML is a smart contract language targeting distributed-ledger runtimes, based on [GHC](https://www.haskell.org/ghc/) with custom language extensions. The DAML programming language has [an IDE](https://webide.daml.com/), and work was done to separate off a reusable Haskell-only IDE (what is now `ghcide`) which the [DAML IDE then builds upon](https://github.com/digital-asset/daml/tree/master/compiler/damlc). Since that time, there have been various [non-Digital Asset contributors](https://github.com/digital-asset/ghcide/graphs/contributors), in addition to continued investment by Digital Asset. All contributions require a [Contributor License Agreement](https://cla.digitalasset.com/digital-asset/ghcide) that states you license the code under the [Apache License](LICENSE).
272
331
273−The Haskell community [has](https://github.com/DanielG/ghc-mod) [various](https://github.com/chrisdone/intero) [IDE](https://github.com/rikvdkleij/intellij-haskell) [choices](http://leksah.org/), but the one that has been gathering momentum is [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme). Our project owes a debt of gratitude to the `haskell-ide-engine`. We reuse libraries from their ecosystem, including [`hie-bios`](https://github.com/mpickering/hie-bios#readme) (a likely future environment setup layer in `haskell-ide-engine`), [`haskell-lsp`](https://github.com/alanz/haskell-lsp#readme) and [`lsp-test`](https://github.com/bubba/lsp-test#readme) (the `haskell-ide-engine` [LSP protocol](https://microsoft.github.io/language-server-protocol/) pieces). We make heavy use of their contributions to GHC itself, in particular the work to make GHC take string buffers rather than files. While `ghcide` is not a part of `haskell-ide-engine`, we feel it _could_ form the core of a future version - but such decisions are up to the `haskell-ide-engine` contributors.
332+The Haskell community [has](https://github.com/DanielG/ghc-mod) [various](https://github.com/chrisdone/intero) [IDE](https://github.com/rikvdkleij/intellij-haskell) [choices](http://leksah.org/), but the one that had been gathering momentum is [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme). Our project owes a debt of gratitude to the `haskell-ide-engine`. We reuse libraries from their ecosystem, including [`hie-bios`](https://github.com/mpickering/hie-bios#readme) (a likely future environment setup layer in `haskell-ide-engine`), [`haskell-lsp`](https://github.com/alanz/haskell-lsp#readme) and [`lsp-test`](https://github.com/bubba/lsp-test#readme) (the `haskell-ide-engine` [LSP protocol](https://microsoft.github.io/language-server-protocol/) pieces). We make heavy use of their contributions to GHC itself, in particular the work to make GHC take string buffers rather than files.
274
333
275The best summary of the architecture of `ghcide` is available [this talk](https://www.youtube.com/watch?v=cijsaeWNf2E&list=PLxxF72uPfQVRdAsvj7THoys-nVj-oc4Ss) ([slides](https://ndmitchell.com/downloads/slides-making_a_haskell_ide-07_sep_2019.pdf)), given at [MuniHac 2019](https://munihac.de/2019.html). However, since that talk the project has renamed from `hie-core` to `ghcide`, and the repo has moved to [this location](https://github.com/digital-asset/ghcide/).
334The best summary of the architecture of `ghcide` is available [this talk](https://www.youtube.com/watch?v=cijsaeWNf2E&list=PLxxF72uPfQVRdAsvj7THoys-nVj-oc4Ss) ([slides](https://ndmitchell.com/downloads/slides-making_a_haskell_ide-07_sep_2019.pdf)), given at [MuniHac 2019](https://munihac.de/2019.html). However, since that talk the project has renamed from `hie-core` to `ghcide`, and the repo has moved to [this location](https://github.com/digital-asset/ghcide/).
azure-pipelines.yml+3−184
@@ -4,6 +4,7 @@ trigger:
4 branches:
4 branches:
5 include:
5 include:
6 - master
6 - master
7+ - azure*
7
8
8# Enable PR triggers that target the master branch
9# Enable PR triggers that target the master branch
9pr:
10pr:
@@ -13,187 +14,5 @@ pr:
13 - master
14 - master
14
15
15jobs:
16jobs:
16− - job: ghcide_stack_86
17+ - template: ./.azure/linux-stack.yml
17− timeoutInMinutes: 60
18+ - template: ./.azure/windows-stack.yml
18− pool:
19− vmImage: 'ubuntu-latest'
20− steps:
21− - checkout: self
22− - task: CacheBeta@0
23− inputs:
24− key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/stack.yaml | $(Build.SourcesDirectory)/ghcide.cabal
25− path: .azure-cache
26− cacheHitVar: CACHE_RESTORED
27− displayName: "Cache stack artifacts"
28− - bash: |
29− mkdir -p ~/.stack
30− tar xzf .azure-cache/stack-root.tar.gz -C $HOME
31− displayName: "Unpack cache"
32− condition: eq(variables.CACHE_RESTORED, 'true')
33− - bash: |
34− ./fmt.sh
35− displayName: "HLint via ./fmt.sh"
36− - bash: |
37− sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev
38− if ! which stack >/dev/null 2>&1; then
39− curl -sSL https://get.haskellstack.org/ | sh
40− fi
41− displayName: 'Install Stack'
42− - bash: stack setup
43− displayName: 'stack setup'
44− - bash: stack build --only-dependencies
45− displayName: 'stack build --only-dependencies'
46− - bash: stack test --ghc-options=-Werror || stack test --ghc-options=-Werror || stack test --ghc-options=-Werror
47− # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.
48− displayName: 'stack test --ghc-options=-Werror'
49− - bash: |
50− mkdir -p .azure-cache
51− tar czf .azure-cache/stack-root.tar.gz -C $HOME .stack
52− displayName: "Pack cache"
53− - bash: |
54− set -euo pipefail
55− MESSAGE=$(git log --pretty=format:%s -n1)
56− curl -XPOST \
57− -i \
58− -H 'Content-type: application/json' \
59− --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \
60− $(Slack.URL)
61− condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))
62− - job: ghcide_stack_84
63− timeoutInMinutes: 60
64− pool:
65− vmImage: 'ubuntu-latest'
66− steps:
67− - checkout: self
68− - task: CacheBeta@0
69− inputs:
70− key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/stack84.yaml | $(Build.SourcesDirectory)/ghcide.cabal
71− path: .azure-cache
72− cacheHitVar: CACHE_RESTORED
73− displayName: "Cache stack artifacts"
74− - bash: |
75− mkdir -p ~/.stack
76− tar xzf .azure-cache/stack-root.tar.gz -C $HOME
77− displayName: "Unpack cache"
78− condition: eq(variables.CACHE_RESTORED, 'true')
79− - bash: |
80− ./fmt.sh
81− displayName: "HLint via ./fmt.sh"
82− - bash: |
83− sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev
84− if ! which stack >/dev/null 2>&1; then
85− curl -sSL https://get.haskellstack.org/ | sh
86− fi
87− displayName: 'Install Stack'
88− - bash: stack setup --stack-yaml=stack84.yaml
89− displayName: 'stack setup --stack-yaml=stack84.yaml'
90− - bash: stack build --only-dependencies --stack-yaml=stack84.yaml
91− displayName: 'stack build --only-dependencies --stack-yaml=stack84.yaml'
92− - bash: stack test --stack-yaml=stack84.yaml --ghc-options=-Werror || stack test --stack-yaml=stack84.yaml --ghc-options=-Werror || stack test --stack-yaml=stack84.yaml --ghc-options=-Werror
93− # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.
94− displayName: 'stack test --stack-yaml=stack84.yaml --ghc-options=-Werror'
95− - bash: |
96− mkdir -p .azure-cache
97− tar czf .azure-cache/stack-root.tar.gz -C $HOME .stack
98− displayName: "Pack cache"
99− - bash: |
100− set -euo pipefail
101− MESSAGE=$(git log --pretty=format:%s -n1)
102− curl -XPOST \
103− -i \
104− -H 'Content-type: application/json' \
105− --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \
106− $(Slack.URL)
107− condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))
108− - job: ghcide_stack_88
109− timeoutInMinutes: 60
110− pool:
111− vmImage: 'ubuntu-latest'
112− steps:
113− - checkout: self
114− - task: CacheBeta@0
115− inputs:
116− key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/stack88.yaml | $(Build.SourcesDirectory)/ghcide.cabal
117− path: .azure-cache
118− cacheHitVar: CACHE_RESTORED
119− displayName: "Cache stack artifacts"
120− - bash: |
121− mkdir -p ~/.stack
122− tar xzf .azure-cache/stack-root.tar.gz -C $HOME
123− displayName: "Unpack cache"
124− condition: eq(variables.CACHE_RESTORED, 'true')
125− - bash: |
126− ./fmt.sh
127− displayName: "HLint via ./fmt.sh"
128− - bash: |
129− sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev
130− if ! which stack >/dev/null 2>&1; then
131− curl -sSL https://get.haskellstack.org/ | sh
132− fi
133− displayName: 'Install Stack'
134− - bash: stack setup --stack-yaml=stack88.yaml
135− displayName: 'stack setup --stack-yaml=stack88.yaml'
136− - bash: stack build --only-dependencies --stack-yaml=stack88.yaml
137− displayName: 'stack build --only-dependencies --stack-yaml=stack88.yaml'
138− - bash: stack test --stack-yaml=stack88.yaml --ghc-options=-Werror || stack test --stack-yaml=stack88.yaml --ghc-options=-Werror || stack test --stack-yaml=stack88.yaml --ghc-options=-Werror
139− # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.
140− displayName: 'stack test --stack-yaml=stack88.yaml --ghc-options=-Werror'
141− - bash: |
142− mkdir -p .azure-cache
143− tar czf .azure-cache/stack-root.tar.gz -C $HOME .stack
144− displayName: "Pack cache"
145− - bash: |
146− set -euo pipefail
147− MESSAGE=$(git log --pretty=format:%s -n1)
148− curl -XPOST \
149− -i \
150− -H 'Content-type: application/json' \
151− --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \
152− $(Slack.URL)
153− condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))
154− - job: ghcide_stack_ghc_lib_88
155− timeoutInMinutes: 60
156− pool:
157− vmImage: 'ubuntu-latest'
158− steps:
159− - checkout: self
160− - task: CacheBeta@0
161− inputs:
162− key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/stack-ghc-lib.yaml | $(Build.SourcesDirectory)/ghcide.cabal
163− path: .azure-cache
164− cacheHitVar: CACHE_RESTORED
165− displayName: "Cache stack artifacts"
166− - bash: |
167− mkdir -p ~/.stack
168− tar xzf .azure-cache/stack-root.tar.gz -C $HOME
169− displayName: "Unpack cache"
170− condition: eq(variables.CACHE_RESTORED, 'true')
171− - bash: |
172− ./fmt.sh
173− displayName: "HLint via ./fmt.sh"
174− - bash: |
175− sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev
176− if ! which stack >/dev/null 2>&1; then
177− curl -sSL https://get.haskellstack.org/ | sh
178− fi
179− displayName: 'Install Stack'
180− - bash: stack setup --stack-yaml=stack-ghc-lib.yaml
181− displayName: 'stack setup --stack-yaml=stack-ghc-lib.yaml'
182− - bash: stack build --only-dependencies --stack-yaml=stack-ghc-lib.yaml
183− displayName: 'stack build --only-dependencies --stack-yaml=stack-ghc-lib.yaml'
184− - bash: stack test --stack-yaml=stack-ghc-lib.yaml --ghc-options=-Werror || stack test --stack-yaml=stack-ghc-lib.yaml --ghc-options=-Werror || stack test --stack-yaml=stack-ghc-lib.yaml --ghc-options=-Werror
185− # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.
186− displayName: 'stack test --stack-yaml=stack-ghc-lib.yaml --ghc-options=-Werror'
187− - bash: |
188− mkdir -p .azure-cache
189− tar czf .azure-cache/stack-root.tar.gz -C $HOME .stack
190− displayName: "Pack cache"
191− - bash: |
192− set -euo pipefail
193− MESSAGE=$(git log --pretty=format:%s -n1)
194− curl -XPOST \
195− -i \
196− -H 'Content-type: application/json' \
197− --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \
198− $(Slack.URL)
199− condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))
bench/Main.hsnew file+287
@@ -0,0 +1,287 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE ExistentialQuantification #-}
3+{-# LANGUAGE ImplicitParams #-}
4+
5+{- An automated benchmark built around the simple experiment described in:
6+
7+ > https://neilmitchell.blogspot.com/2020/05/fixing-space-leaks-in-ghcide.html
8+
9+ As an example project, it unpacks Cabal-3.2.0.0 in the local filesystem and
10+ loads the module 'Distribution.Simple'. The rationale for this choice is:
11+
12+ - It's convenient to download with `cabal unpack Cabal-3.2.0.0`
13+ - It has very few dependencies, and all are already needed to build ghcide
14+ - Distribution.Simple has 235 transitive module dependencies, so non trivial
15+
16+ The experiments are sequences of lsp commands scripted using lsp-test.
17+ A more refined approach would be to record and replay real IDE interactions,
18+ once the replay functionality is available in lsp-test.
19+ A more declarative approach would be to reuse ide-debug-driver:
20+
21+ > https://github.com/digital-asset/daml/blob/master/compiler/damlc/ide-debug-driver/README.md
22+
23+ The result of an experiment is a total duration in seconds after a preset
24+ number of iterations. There is ample room for improvement:
25+ - Statistical analysis to detect outliers and auto infer the number of iterations needed
26+ - GC stats analysis (currently -S is printed as part of the experiment)
27+ - Analyisis of performance over the commit history of the project
28+
29+ How to run:
30+ 1. `cabal bench`
31+ 2. `cabal exec <absolute-path-to-ghcide-bench> -- ghcide-bench-options`
32+
33+ Note that the package database influences the response times of certain actions,
34+ e.g. code actions, and therefore the two methods above do not necessarily
35+ produce the same results.
36+
37+ -}
38+
39+import Control.Applicative.Combinators
40+import Control.Concurrent
41+import Control.Exception.Safe
42+import Control.Monad.Extra
43+import Control.Monad.IO.Class
44+import Data.Aeson
45+import Data.List
46+import Data.Maybe
47+import Data.Version
48+import Language.Haskell.LSP.Test
49+import Language.Haskell.LSP.Types
50+import Language.Haskell.LSP.Types.Capabilities
51+import Numeric.Natural
52+import Options.Applicative
53+import System.Directory
54+import System.FilePath ((</>))
55+import System.Process
56+import System.Time.Extra
57+
58+-- Points to a string in the target file,
59+-- convenient for hygienic edits
60+hygienicP :: Position
61+hygienicP = Position 854 23
62+
63+-- Points to the middle of an identifier,
64+-- convenient for requesting goto-def, hover and completions
65+identifierP :: Position
66+identifierP = Position 853 12
67+
68+main :: IO ()
69+main = do
70+ config <- execParser $ info configP fullDesc
71+ let ?config = config
72+
73+ output "starting test"
74+
75+ cleanUp <- setup
76+
77+ runBenchmarks
78+ [ ---------------------------------------------------------------------------------------
79+ bench "hover" 10 $ \doc ->
80+ isJust <$> getHover doc identifierP,
81+ ---------------------------------------------------------------------------------------
82+ bench "getDefinition" 10 $ \doc ->
83+ not . null <$> getDefinitions doc identifierP,
84+ ---------------------------------------------------------------------------------------
85+ bench "documentSymbols" 100 $
86+ fmap (either (not . null) (not . null)) . getDocumentSymbols,
87+ ---------------------------------------------------------------------------------------
88+ bench "documentSymbols after edit" 100 $ \doc -> do
89+ let change =
90+ TextDocumentContentChangeEvent
91+ { _range = Just (Range hygienicP hygienicP),
92+ _rangeLength = Nothing,
93+ _text = " "
94+ }
95+ changeDoc doc [change]
96+ either (not . null) (not . null) <$> getDocumentSymbols doc,
97+ ---------------------------------------------------------------------------------------
98+ bench "completions after edit" 10 $ \doc -> do
99+ let change =
100+ TextDocumentContentChangeEvent
101+ { _range = Just (Range hygienicP hygienicP),
102+ _rangeLength = Nothing,
103+ _text = " "
104+ }
105+ changeDoc doc [change]
106+ not . null <$> getCompletions doc identifierP,
107+ ---------------------------------------------------------------------------------------
108+ benchWithSetup
109+ "code actions"
110+ 10
111+ ( \doc -> do
112+ let p = identifierP
113+ let change =
114+ TextDocumentContentChangeEvent
115+ { _range = Just (Range p p),
116+ _rangeLength = Nothing,
117+ _text = "a"
118+ }
119+ changeDoc doc [change]
120+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
121+ return p
122+ )
123+ ( \p doc -> do
124+ not . null <$> getCodeActions doc (Range p p)
125+ ),
126+ ---------------------------------------------------------------------------------------
127+ bench "code actions after edit" 10 $ \doc -> do
128+ let p = identifierP
129+ let change =
130+ TextDocumentContentChangeEvent
131+ { _range = Just (Range p p),
132+ _rangeLength = Nothing,
133+ _text = "a"
134+ }
135+ changeDoc doc [change]
136+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
137+ not . null <$> getCodeActions doc (Range p p)
138+ ]
139+ `finally` cleanUp
140+
141+---------------------------------------------------------------------------------------------
142+
143+examplePackageName :: String
144+examplePackageName = "Cabal"
145+
146+examplePackageVersion :: Version
147+examplePackageVersion = makeVersion [3, 2, 0, 0]
148+
149+examplePackage :: String
150+examplePackage = examplePackageName <> "-" <> showVersion examplePackageVersion
151+
152+exampleModulePath :: FilePath
153+exampleModulePath = "Distribution" </> "Simple.hs"
154+
155+examplesPath :: FilePath
156+examplesPath = "bench/example"
157+
158+data Config = Config
159+ { verbose :: !Bool,
160+ -- For some reason, the Shake profile files are truncated and won't load
161+ shakeProfiling :: !(Maybe FilePath),
162+ outputCSV :: !Bool
163+ }
164+
165+type HasConfig = (?config :: Config)
166+
167+configP :: Parser Config
168+configP = Config
169+ <$> (not <$> switch (long "quiet"))
170+ <*> optional (strOption (long "shake-profiling" <> metavar "PATH"))
171+ <*> switch (long "csv")
172+
173+output :: (MonadIO m, HasConfig) => String -> m ()
174+output = if verbose ?config then liftIO . putStrLn else (\_ -> pure ())
175+
176+---------------------------------------------------------------------------------------
177+
178+type Experiment = TextDocumentIdentifier -> Session Bool
179+
180+data Bench = forall setup.
181+ Bench
182+ { name :: !String,
183+ samples :: !Natural,
184+ benchSetup :: TextDocumentIdentifier -> Session setup,
185+ experiment :: setup -> Experiment
186+ }
187+
188+bench :: String -> Natural -> Experiment -> Bench
189+bench name samples userExperiment = Bench {..}
190+ where
191+ experiment () = userExperiment
192+ benchSetup _ = return ()
193+
194+benchWithSetup ::
195+ String ->
196+ Natural ->
197+ (TextDocumentIdentifier -> Session p) ->
198+ (p -> Experiment) ->
199+ Bench
200+benchWithSetup = Bench
201+
202+runBenchmarks :: HasConfig => [Bench] -> IO ()
203+runBenchmarks benchmarks = do
204+ results <- forM benchmarks $ \b -> (b,) <$> runBench b
205+
206+ forM_ results $ \(Bench {name, samples}, duration) ->
207+ output $
208+ "TOTAL "
209+ <> name
210+ <> " = "
211+ <> showDuration duration
212+ <> " ("
213+ <> show samples
214+ <> " repetitions)"
215+
216+ when (outputCSV ?config) $ do
217+ putStrLn $ intercalate ", " $ map name benchmarks
218+ putStrLn $ intercalate ", " $ map (showDuration . snd) results
219+
220+runBench :: HasConfig => Bench -> IO Seconds
221+runBench Bench {..} = handleAny (\e -> print e >> return (-1))
222+ $ runSessionWithConfig conf cmd lspTestCaps dir
223+ $ do
224+ doc <- openDoc exampleModulePath "haskell"
225+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
226+
227+ liftIO $ output $ "Running " <> name <> " benchmark"
228+ userState <- benchSetup doc
229+ let loop 0 = return True
230+ loop n = do
231+ (t, res) <- duration $ experiment userState doc
232+ if not res
233+ then return False
234+ else do
235+ output (showDuration t)
236+ loop (n -1)
237+
238+ (t, res) <- duration $ loop samples
239+
240+ exitServer
241+ -- sleeep to give ghcide a chance to print the RTS stats
242+ liftIO $ threadDelay 50000
243+
244+ return $ if res then t else -1
245+ where
246+ cmd =
247+ unwords $
248+ [ "ghcide",
249+ "--lsp",
250+ "--cwd",
251+ dir,
252+ "+RTS",
253+ "-S",
254+ "-RTS"
255+ ]
256+ ++ concat
257+ [ ["--shake-profiling", path]
258+ | Just path <- [shakeProfiling ?config]
259+ ]
260+ dir = "bench/example/" <> examplePackage
261+ lspTestCaps =
262+ fullCaps {_window = Just $ WindowClientCapabilities $ Just True}
263+ conf =
264+ defaultConfig
265+ { logStdErr = verbose ?config,
266+ logMessages = False,
267+ logColor = False
268+ }
269+
270+setup :: HasConfig => IO (IO ())
271+setup = do
272+ alreadyExists <- doesDirectoryExist examplesPath
273+ when alreadyExists $ removeDirectoryRecursive examplesPath
274+ callCommand $ "cabal get -v0 " <> examplePackage <> " -d " <> examplesPath
275+ writeFile
276+ (examplesPath </> examplePackage </> "hie.yaml")
277+ ("cradle: {cabal: {component: " <> show examplePackageName <> "}}")
278+
279+ whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True
280+
281+ return $ removeDirectoryRecursive examplesPath
282+
283+-- | Asks the server to shutdown and exit politely
284+exitServer :: Session ()
285+exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams
286+
287+--------------------------------------------------------------------------------------------
docs/Setup.md+38−1
@@ -54,8 +54,21 @@ with the following content:
54cradle: {cabal: {component: "mylibrary"}}
54cradle: {cabal: {component: "mylibrary"}}
55```
55```
56
56
57+If you are using stack, find the list of names you can use:
58+
59+ $ stack ide targets
60+ mypackage:lib
61+ mypackage:exe:mypackage-exe
62+ mypackage:test:mypackage-test
63+
64+and create a `hie.yaml` file as follows:
65+
66+ {stack: {component: "mypackage:lib"}}
67+
57## ghc: readCreateProcess: does not exist
68## ghc: readCreateProcess: does not exist
58
69
70+On Linux: try `stack exec ghcide`` instead of `ghcide` directly.
71+
59I was getting this in Windows: `ghcide.exe: ghc: readCreateProcess: does not exist (No such file or directory)`
72I was getting this in Windows: `ghcide.exe: ghc: readCreateProcess: does not exist (No such file or directory)`
60
73
61And we figured a hack around for this:
74And we figured a hack around for this:
@@ -69,7 +82,21 @@ Since I use stack. Required if you don't have a `ghc` on your path.
69
82
70## Could not find module ...
83## Could not find module ...
71
84
72−Try adding an explicit hie.yaml file and see if that helps.
85+Try adding an explicit `hie.yaml` file and see if that helps.
86+
87+## Ambiguous main module
88+
89+```console
90+$ stack exec ghcide
91+
92+...
93+
94+ghcide: CradleError (ExitFailure 1) ["Failed to parse result of calling stack","","* * * * * * * *","The main module to load is ambiguous. Candidates are: ","1. Package `mypackage' component mypackage:exe:mypackage-exe with main-is file: /home/user/mypackage/app/Main.hs","2. Package `mypackage' component mypackage:exe:otherbin-exe with main-is file: /home/user/mypackage/app/otherbin.hs","You can specify which one to pick by: "," * Specifying targets to stack ghci e.g. stack ghci mypackage:exe:mypackage-exe"," * Specifying what the main is e.g. stack ghci --main-is mypackage:exe:mypackage-exe"," * Choosing from the candidate above [1..2]","* * * * * * * *","","<stdin>: hGetLine: end of file"]
95+```
96+
97+Add a `hie.yaml` file to specify the module, e.g.
98+
99+ cradle: {stack: {component: "mypackage:exe:mypackage-exe"}}
73
100
74## Works in `ghcide` but not my editor
101## Works in `ghcide` but not my editor
75
102
@@ -106,3 +133,13 @@ find ~/.emacs.d -name '*.elc' -exec rm {} \;
106## Docker stack builds
133## Docker stack builds
107
134
108You're likely to see `ghcide: (ExitFailure 1,"","")`. Because ghcide can't get at the ghc installed inside Docker, your best bet is to `stack exec ghcide` and make sure `ghcide` is installed within the container. Full details at [issue 221](https://github.com/digital-asset/ghcide/issues/221).
135You're likely to see `ghcide: (ExitFailure 1,"","")`. Because ghcide can't get at the ghc installed inside Docker, your best bet is to `stack exec ghcide` and make sure `ghcide` is installed within the container. Full details at [issue 221](https://github.com/digital-asset/ghcide/issues/221).
136+
137+## stty error on Windows + Stack
138+
139+If you get an error like:
140+
141+```
142+ghcide.exe: CradleError (ExitFailure 1) ["Failed to parse result of calling stack","'stty' is not recognized as an internal or external command,","operable program or batch file."
143+```
144+
145+Then the workaround from https://github.com/haskell/haskell-ide-engine/issues/1428#issuecomment-547530794 might help.
exe/Arguments.hs+4
@@ -12,6 +12,8 @@ data Arguments = Arguments
12 ,argFiles :: [FilePath]
12 ,argFiles :: [FilePath]
13 ,argsVersion :: Bool
13 ,argsVersion :: Bool
14 ,argsShakeProfiling :: Maybe FilePath
14 ,argsShakeProfiling :: Maybe FilePath
15+ ,argsTesting :: Bool
16+ ,argsThreads :: Int
15 }
17 }
16
18
17getArguments :: IO Arguments
19getArguments :: IO Arguments
@@ -29,3 +31,5 @@ arguments = Arguments
29 <*> many (argument str (metavar "FILES/DIRS..."))
31 <*> many (argument str (metavar "FILES/DIRS..."))
30 <*> switch (long "version" <> help "Show ghcide and GHC versions")
32 <*> switch (long "version" <> help "Show ghcide and GHC versions")
31 <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")
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+540−82
@@ -3,19 +3,31 @@
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 #-}
5{-# LANGUAGE TemplateHaskell #-}
6+{-# LANGUAGE TypeFamilies #-}
6
7
7module Main(main) where
8module Main(main) where
8
9
10+import Linker (initDynLinker)
11+import Data.IORef
12+import NameCache
13+import Packages
14+import Module
9import Arguments
15import Arguments
10−import Data.Maybe
16+import Control.Concurrent.Async
11−import Data.List.Extra
12−import System.FilePath
13import Control.Concurrent.Extra
17import Control.Concurrent.Extra
14import Control.Exception
18import Control.Exception
15import Control.Monad.Extra
19import Control.Monad.Extra
16import Control.Monad.IO.Class
20import Control.Monad.IO.Class
17import Data.Default
21import Data.Default
18−import System.Time.Extra
22+import Data.Either
23+import Data.Function
24+import Data.List.Extra
25+import Data.Maybe
26+import qualified Data.Text as T
27+import qualified Data.Text.IO as T
28+import Data.Time.Clock (UTCTime)
29+import Data.Version
30+import Development.IDE.Core.Debouncer
19import Development.IDE.Core.FileStore
31import Development.IDE.Core.FileStore
20import Development.IDE.Core.OfInterest
32import Development.IDE.Core.OfInterest
21import Development.IDE.Core.Service
33import Development.IDE.Core.Service
@@ -31,31 +43,39 @@ import Development.IDE.GHC.Util
31import Development.IDE.Plugin
43import Development.IDE.Plugin
32import Development.IDE.Plugin.Completions as Completions
44import Development.IDE.Plugin.Completions as Completions
33import Development.IDE.Plugin.CodeAction as CodeAction
45import Development.IDE.Plugin.CodeAction as CodeAction
34−import qualified Data.Text as T
46+import qualified Language.Haskell.LSP.Core as LSP
35−import qualified Data.Text.IO as T
36import Language.Haskell.LSP.Messages
47import Language.Haskell.LSP.Messages
37−import Language.Haskell.LSP.Types (LspId(IdInt))
48+import Language.Haskell.LSP.Types
38−import Linker
39−import Data.Version
49+import Data.Aeson (ToJSON(toJSON))
40import Development.IDE.LSP.LanguageServer
50import Development.IDE.LSP.LanguageServer
41−import System.Directory.Extra as IO
51+import qualified System.Directory.Extra as IO
42import System.Environment
52import System.Environment
43import System.IO
53import System.IO
44import System.Exit
54import System.Exit
55+import System.FilePath
56+import System.Directory
57+import System.Time.Extra
58+import HIE.Bios.Environment (addCmdOpts, makeDynFlagsAbsolute)
45import Paths_ghcide
59import Paths_ghcide
46import Development.GitRev
60import Development.GitRev
47import Development.Shake (Action, action)
61import Development.Shake (Action, action)
48−import qualified Data.Set as Set
62+import qualified Data.HashSet as HashSet
63+import qualified Data.HashMap.Strict as HM
49import qualified Data.Map.Strict as Map
64import qualified Data.Map.Strict as Map
50−
65+import qualified Crypto.Hash.SHA1 as H
66+import qualified Data.ByteString.Char8 as B
67+import Data.ByteString.Base16 (encode)
68+import DynFlags (gopt_set, gopt_unset, updOptLevel, PackageFlag(..), PackageArg(..))
69+import GhcMonad
70+import HscTypes (HscEnv(..), ic_dflags)
51import GHC hiding (def)
71import GHC hiding (def)
52−import qualified GHC.Paths
72+import GHC.Check ( VersionCheck(..), makeGhcVersionChecker )
73+import Data.Either.Extra
53
74
54−import HIE.Bios
75+import HIE.Bios.Cradle
76+import HIE.Bios.Types
55
77
56−-- Set the GHC libdir to the nix libdir if it's present.
78+import Utils
57−getLibdir :: IO FilePath
58−getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
59
79
60ghcideVersion :: IO String
80ghcideVersion :: IO String
61ghcideVersion = do
81ghcideVersion = do
@@ -82,72 +102,68 @@ main = do
82 let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
102 let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
83 T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
103 T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
84
104
85− whenJust argsCwd setCurrentDirectory
105+ whenJust argsCwd IO.setCurrentDirectory
86
106
87− dir <- getCurrentDirectory
107+ dir <- IO.getCurrentDirectory
108+ command <- makeLspCommandId "typesignature.add"
88
109
89 let plugins = Completions.plugin <> CodeAction.plugin
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+ }
90
116
91 if argLSP then do
117 if argLSP then do
92 t <- offsetTime
118 t <- offsetTime
93 hPutStrLn stderr "Starting LSP server..."
119 hPutStrLn stderr "Starting LSP server..."
94 hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
120 hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
95− runLanguageServer def (pluginHandler plugins) $ \getLspId event vfs caps -> do
121+ runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do
96 t <- t
122 t <- t
97 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
123 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
98− -- very important we only call loadSession once, and it's fast, so just do it before starting
99− session <- loadSession dir
100− let options = (defaultIdeOptions $ return session)
124+ let options = (defaultIdeOptions $ loadSessionShake dir)
101 { optReportProgress = clientSupportsProgress caps
125 { optReportProgress = clientSupportsProgress caps
102 , optShakeProfiling = argsShakeProfiling
126 , optShakeProfiling = argsShakeProfiling
127+ , optTesting = argsTesting
128+ , optThreads = argsThreads
103 }
129 }
130+ debouncer <- newAsyncDebouncer
104− initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event (logger minBound) options vfs
131+ initialise caps (mainRule >> pluginRules plugins >> action kick)
132+ getLspId event (logger minBound) debouncer options vfs
105 else do
133 else do
134+ -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
135+ hSetEncoding stdout utf8
136+ hSetEncoding stderr utf8
137+
106 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
138 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
107 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
139 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
108
140
109− putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir
141+ putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir
110− files <- nubOrd <$> expandFiles (argFiles ++ ["." | null argFiles])
142+ files <- expandFiles (argFiles ++ ["." | null argFiles])
143+ -- LSP works with absolute file paths, so try and behave similarly
144+ files <- nubOrd <$> mapM IO.canonicalizePath files
111 putStrLn $ "Found " ++ show (length files) ++ " files"
145 putStrLn $ "Found " ++ show (length files) ++ " files"
112
146
113− putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"
147+ putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup"
114 cradles <- mapM findCradle files
148 cradles <- mapM findCradle files
115 let ucradles = nubOrd cradles
149 let ucradles = nubOrd cradles
116 let n = length ucradles
150 let n = length ucradles
117 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
151 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
118− sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do
119− let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x
120− putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg
121− cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x
122− when (isNothing x) $ print cradle
123− putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"
124− cradleToSession cradle
125−
126− putStrLn "\nStep 5/6: Initializing the IDE"
152+ putStrLn "\nStep 3/4: Initializing the IDE"
127 vfs <- makeVFSHandle
153 vfs <- makeVFSHandle
128− let cradlesToSessions = Map.fromList $ zip ucradles sessions
154+ debouncer <- newAsyncDebouncer
129− let filesToCradles = Map.fromList $ zip files cradles
130− let grab file = fromMaybe (head sessions) $ do
131− cradle <- Map.lookup file filesToCradles
132− Map.lookup cradle cradlesToSessions
133−
134− let options =
135− (defaultIdeOptions $ return $ return . grab)
136− { optShakeProfiling = argsShakeProfiling }
137− ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) options vfs
155+ ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs
138−
156+
139− putStrLn "\nStep 6/6: Type checking the files"
157+ putStrLn "\nStep 4/4: Type checking the files"
140− setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files
158+ setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
141− results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files
159+ results <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath' files)
142 let (worked, failed) = partition fst $ zip (map isJust results) files
160 let (worked, failed) = partition fst $ zip (map isJust results) files
143 when (failed /= []) $
161 when (failed /= []) $
144 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
162 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
145
163
146 let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
164 let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
147 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
165 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
148−
166+ return ()
149− unless (null failed) exitFailure
150−
151
167
152expandFiles :: [FilePath] -> IO [FilePath]
168expandFiles :: [FilePath] -> IO [FilePath]
153expandFiles = concatMapM $ \x -> do
169expandFiles = concatMapM $ \x -> do
@@ -156,7 +172,7 @@ expandFiles = concatMapM $ \x -> do
156 let recurse "." = True
172 let recurse "." = True
157 recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
173 recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
158 recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
174 recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
159− files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> listFilesInside (return . recurse) x
175+ files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x
160 when (null files) $
176 when (null files) $
161 fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
177 fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
162 return files
178 return files
@@ -165,48 +181,414 @@ expandFiles = concatMapM $ \x -> do
165kick :: Action ()
181kick :: Action ()
166kick = do
182kick = do
167 files <- getFilesOfInterest
183 files <- getFilesOfInterest
168− void $ uses TypeCheck $ Set.toList files
184+ void $ uses TypeCheck $ HashSet.toList files
169
185
170-- | Print an LSP event.
186-- | Print an LSP event.
171showEvent :: Lock -> FromServerMessage -> IO ()
187showEvent :: Lock -> FromServerMessage -> IO ()
172showEvent _ (EventFileDiagnostics _ []) = return ()
188showEvent _ (EventFileDiagnostics _ []) = return ()
173−showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
189+showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =
174 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
190 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
175showEvent lock e = withLock lock $ print e
191showEvent lock e = withLock lock $ print e
176
192
177
193
178−cradleToSession :: Cradle -> IO HscEnvEq
194+-- | Run the specific cradle on a specific FilePath via hie-bios.
179−cradleToSession cradle = do
195+cradleToSessionOpts :: Cradle a -> FilePath -> IO (Either [CradleError] ComponentOptions)
180− cradleRes <- getCompilerOptions "" cradle
196+cradleToSessionOpts cradle file = do
197+ let showLine s = putStrLn ("> " ++ s)
198+ cradleRes <- runCradle (cradleOptsProg cradle) showLine file
181− opts <- case cradleRes of
199+ case cradleRes of
182− CradleSuccess r -> pure r
200+ CradleSuccess r -> pure (Right r)
183− CradleFail err -> throwIO err
201+ CradleFail err -> return (Left [err])
184− -- TODO Rather than failing here, we should ignore any files that use this cradle.
202+ -- For the None cradle perhaps we still want to report an Info
185− -- That will require some more changes.
203+ -- message about the fact that the file is being ignored.
186− CradleNone -> fail "'none' cradle is not yet supported"
204+ CradleNone -> return (Left [])
205+
206+emptyHscEnv :: IO HscEnv
207+emptyHscEnv = do
187 libdir <- getLibdir
208 libdir <- getLibdir
188− env <- runGhc (Just libdir) $ do
209+ env <- runGhc (Just libdir) getSession
189− _targets <- initSession opts
190− getSession
191 initDynLinker env
210 initDynLinker env
192− newHscEnvEq env
211+ pure env
212+
213+-- | Convert a target to a list of potential absolute paths.
214+-- A TargetModule can be anywhere listed by the supplied include
215+-- directories
216+-- A target file is a relative path but with a specific prefix so just need
217+-- to canonicalise it.
218+targetToFile :: [FilePath] -> TargetId -> IO [NormalizedFilePath]
219+targetToFile is (TargetModule mod) = do
220+ let fps = [i </> moduleNameSlashes mod -<.> ext | ext <- exts, i <- is ]
221+ exts = ["hs", "hs-boot", "lhs"]
222+ mapM (fmap toNormalizedFilePath' . canonicalizePath) fps
223+targetToFile _ (TargetFile f _) = do
224+ f' <- canonicalizePath f
225+ return [toNormalizedFilePath' f']
226+
227+setNameCache :: IORef NameCache -> HscEnv -> HscEnv
228+setNameCache nc hsc = hsc { hsc_NC = nc }
229+
230+loadSessionShake :: FilePath -> Action (FilePath -> Action (IdeResult HscEnvEq))
231+loadSessionShake fp = do
232+ se <- getShakeExtras
233+ IdeOptions{optTesting} <- getIdeOptions
234+ res <- liftIO $ loadSession optTesting se fp
235+ return (fmap liftIO res)
236+
237+-- | This is the key function which implements multi-component support. All
238+-- components mapping to the same hie.yaml file are mapped to the same
239+-- HscEnv which is updated as new components are discovered.
240+loadSession :: Bool -> ShakeExtras -> FilePath -> IO (FilePath -> IO (IdeResult HscEnvEq))
241+loadSession optTesting ShakeExtras{logger, eventer} dir = do
242+ -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
243+ hscEnvs <- newVar Map.empty :: IO (Var HieMap)
244+ -- Mapping from a Filepath to HscEnv
245+ fileToFlags <- newVar Map.empty :: IO (Var FlagsMap)
246+
247+ -- This caches the mapping from Mod.hs -> hie.yaml
248+ cradleLoc <- memoIO $ \v -> do
249+ res <- findCradle v
250+ -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
251+ -- try and normalise that
252+ -- e.g. see https://github.com/digital-asset/ghcide/issues/126
253+ res' <- traverse IO.makeAbsolute res
254+ return $ normalise <$> res'
255+
256+ -- Create a new HscEnv from a hieYaml root and a set of options
257+ -- If the hieYaml file already has an HscEnv, the new component is
258+ -- combined with the components in the old HscEnv into a new HscEnv
259+ -- which contains the union.
260+ let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions)
261+ -> IO (HscEnv, ComponentInfo, [ComponentInfo])
262+ packageSetup (hieYaml, cfp, opts) = do
263+ -- Parse DynFlags for the newly discovered component
264+ hscEnv <- emptyHscEnv
265+ (df, targets) <- evalGhcEnv hscEnv $
266+ setOptions opts (hsc_dflags hscEnv)
267+ dep_info <- getDependencyInfo (componentDependencies opts ++ maybeToList hieYaml)
268+ -- Now lookup to see whether we are combining with an existing HscEnv
269+ -- or making a new one. The lookup returns the HscEnv and a list of
270+ -- information about other components loaded into the HscEnv
271+ -- (unitId, DynFlag, Targets)
272+ modifyVar hscEnvs $ \m -> do
273+ -- Just deps if there's already an HscEnv
274+ -- Nothing is it's the first time we are making an HscEnv
275+ let oldDeps = Map.lookup hieYaml m
276+ let -- Add the raw information about this component to the list
277+ -- We will modify the unitId and DynFlags used for
278+ -- compilation but these are the true source of
279+ -- information.
280+ new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info
281+ : maybe [] snd oldDeps
282+ -- Get all the unit-ids for things in this component
283+ inplace = map rawComponentUnitId new_deps
284+
285+ new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do
286+ -- Remove all inplace dependencies from package flags for
287+ -- components in this HscEnv
288+ let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags
289+ let prefix = show rawComponentUnitId
290+ -- See Note [Avoiding bad interface files]
291+ processed_df <- setCacheDir logger prefix (sort $ map show uids) opts df2
292+ -- The final component information, mostly the same but the DynFlags don't
293+ -- contain any packages which are also loaded
294+ -- into the same component.
295+ pure $ ComponentInfo rawComponentUnitId
296+ processed_df
297+ uids
298+ rawComponentTargets
299+ rawComponentFP
300+ rawComponentCOptions
301+ rawComponentDependencyInfo
302+ -- Make a new HscEnv, we have to recompile everything from
303+ -- scratch again (for now)
304+ -- It's important to keep the same NameCache though for reasons
305+ -- that I do not fully understand
306+ logInfo logger (T.pack ("Making new HscEnv" ++ show inplace))
307+ hscEnv <- case oldDeps of
308+ Nothing -> emptyHscEnv
309+ Just (old_hsc, _) -> setNameCache (hsc_NC old_hsc) <$> emptyHscEnv
310+ newHscEnv <-
311+ -- Add the options for the current component to the HscEnv
312+ evalGhcEnv hscEnv $ do
313+ _ <- setSessionDynFlags df
314+ getSession
315+ -- Modify the map so the hieYaml now maps to the newly created
316+ -- HscEnv
317+ -- Returns
318+ -- . the new HscEnv so it can be used to modify the
319+ -- FilePath -> HscEnv map (fileToFlags)
320+ -- . The information for the new component which caused this cache miss
321+ -- . The modified information (without -inplace flags) for
322+ -- existing packages
323+ pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps'))
324+
325+ let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> IO (IdeResult HscEnvEq)
326+ session (hieYaml, cfp, opts) = do
327+ (hscEnv, new, old_deps) <- packageSetup (hieYaml, cfp, opts)
328+ -- Make a map from unit-id to DynFlags, this is used when trying to
329+ -- resolve imports. (especially PackageImports)
330+ let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps)
331+
332+ -- For each component, now make a new HscEnvEq which contains the
333+ -- HscEnv for the hie.yaml file but the DynFlags for that component
334+
335+ -- New HscEnv for the component in question, returns the new HscEnvEq and
336+ -- a mapping from FilePath to the newly created HscEnvEq.
337+ let new_cache = newComponentCache logger hscEnv uids
338+ (cs, res) <- new_cache new
339+ -- Modified cache targets for everything else in the hie.yaml file
340+ -- which now uses the same EPS and so on
341+ cached_targets <- concatMapM (fmap fst . new_cache) old_deps
342+ modifyVar_ fileToFlags $ \var -> do
343+ pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var
344+
345+ return (fst res)
346+
347+ let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq)
348+ consultCradle hieYaml cfp = do
349+ when optTesting $ eventer $ notifyCradleLoaded cfp
350+ logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp)
351+ cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml
352+ eopts <- cradleToSessionOpts cradle cfp
353+ logDebug logger $ T.pack ("Session loading result: " <> show eopts)
354+ case eopts of
355+ -- The cradle gave us some options so get to work turning them
356+ -- into and HscEnv.
357+ Right opts -> do
358+ session (hieYaml, toNormalizedFilePath' cfp, opts)
359+ -- Failure case, either a cradle error or the none cradle
360+ Left err -> do
361+ dep_info <- getDependencyInfo (maybeToList hieYaml)
362+ let ncfp = toNormalizedFilePath' cfp
363+ let res = (map (renderCradleError ncfp) err, Nothing)
364+ modifyVar_ fileToFlags $ \var -> do
365+ pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var
366+ return res
367+
368+ -- This caches the mapping from hie.yaml + Mod.hs -> [String]
369+ let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq)
370+ sessionOpts (hieYaml, file) = do
371+ v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags
372+ cfp <- canonicalizePath file
373+ case HM.lookup (toNormalizedFilePath' cfp) v of
374+ Just (opts, old_di) -> do
375+ deps_ok <- checkDependencyInfo old_di
376+ if not deps_ok
377+ then do
378+ -- If the dependencies are out of date then clear both caches and start
379+ -- again.
380+ modifyVar_ fileToFlags (const (return Map.empty))
381+ -- Keep the same name cache
382+ modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml )
383+ consultCradle hieYaml cfp
384+ else return opts
385+ Nothing -> consultCradle hieYaml cfp
193
386
387+ dummyAs <- async $ return (error "Uninitialised")
388+ runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq)))
389+ -- The main function which gets options for a file. We only want one of these running
390+ -- at a time. Therefore the IORef contains the currently running cradle, if we try
391+ -- to get some more options then we wait for the currently running action to finish
392+ -- before attempting to do so.
393+ let getOptions :: FilePath -> IO (IdeResult HscEnvEq)
394+ getOptions file = do
395+ hieYaml <- cradleLoc file
396+ sessionOpts (hieYaml, file)
397+ return $ \file -> do
398+ join $ mask_ $ modifyVar runningCradle $ \as -> do
399+ -- If the cradle is not finished, then wait for it to finish.
400+ void $ wait as
401+ as <- async $ getOptions file
402+ return (as, wait as)
194
403
195−loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq)
196−loadSession dir = do
197− cradleLoc <- memoIO $ \v -> do
198− res <- findCradle v
199− -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
200− -- try and normalise that
201− -- e.g. see https://github.com/digital-asset/ghcide/issues/126
202− res' <- traverse makeAbsolute res
203− return $ normalise <$> res'
204− session <- memoIO $ \file -> do
205− c <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file
206− cradleToSession c
207− return $ \file -> liftIO $ session =<< cradleLoc file
208
404
209
405
406+-- | Create a mapping from FilePaths to HscEnvEqs
407+newComponentCache
408+ :: Logger
409+ -> HscEnv
410+ -> [(InstalledUnitId, DynFlags)]
411+ -> ComponentInfo
412+ -> IO ([(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))], (IdeResult HscEnvEq, DependencyInfo))
413+newComponentCache logger hsc_env uids ci = do
414+ let df = componentDynFlags ci
415+ let hscEnv' = hsc_env { hsc_dflags = df
416+ , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } }
417+
418+ versionMismatch <- checkGhcVersion
419+ henv <- case versionMismatch of
420+ Just mismatch -> return mismatch
421+ Nothing -> newHscEnvEq hscEnv' uids
422+ let res = (([], Just henv), componentDependencyInfo ci)
423+ logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res))
424+
425+ let is = importPaths df
426+ ctargets <- concatMapM (targetToFile is . targetId) (componentTargets ci)
427+ -- A special target for the file which caused this wonderful
428+ -- component to be created. In case the cradle doesn't list all the targets for
429+ -- the component, in which case things will be horribly broken anyway.
430+ -- Otherwise, we will immediately attempt to reload this module which
431+ -- causes an infinite loop and high CPU usage.
432+ let special_target = (componentFP ci, res)
433+ let xs = map (,res) ctargets
434+ return (special_target:xs, res)
435+
436+{- Note [Avoiding bad interface files]
437+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
438+Originally, we set the cache directory for the various components once
439+on the first occurrence of the component.
440+This works fine if these components have no references to each other,
441+but you have components that depend on each other, the interface files are
442+updated for each component.
443+After restarting the session and only opening the component that depended
444+on the other, suddenly the interface files of this component are stale.
445+However, from the point of view of `ghcide`, they do not look stale,
446+thus, not regenerated and the IDE shows weird errors such as:
447+```
448+typecheckIface
449+Declaration for Rep_ClientRunFlags
450+Axiom branches Rep_ClientRunFlags:
451+ Failed to load interface for ‘Distribution.Simple.Flag’
452+ Use -v to see a list of the files searched for.
453+```
454+and
455+```
456+expectJust checkFamInstConsistency
457+CallStack (from HasCallStack):
458+ error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes
459+ expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst
460+```
461+
462+To mitigate this, we set the cache directory for each component dependent
463+on the components of the current `HscEnv`, additionally to the component options
464+of the respective components.
465+Assume two components, c1, c2, where c2 depends on c1, and the options of the
466+respective components are co1, co2.
467+If we want to load component c2, followed by c1, we set the cache directory for
468+each component in this way:
469+
470+ * Load component c2
471+ * (Cache Directory State)
472+ - name of c2 + co2
473+ * Load component c1
474+ * (Cache Directory State)
475+ - name of c2 + name of c1 + co2
476+ - name of c2 + name of c1 + co1
477+
478+Overall, we created three cache directories. If we opened c1 first, then we
479+create a fourth cache directory.
480+This makes sure that interface files are always correctly updated.
481+
482+Since this causes a lot of recompilation, we only update the cache-directory,
483+if the dependencies of a component have really changed.
484+E.g. when you load two executables, they can not depend on each other. They
485+should be filtered out, such that we dont have to re-compile everything.
486+-}
487+
488+-- | Set the cache-directory based on the ComponentOptions and a list of
489+-- internal packages.
490+-- For the exact reason, see Note [Avoiding bad interface files].
491+setCacheDir :: MonadIO m => Logger -> String -> [String] -> ComponentOptions -> DynFlags -> m DynFlags
492+setCacheDir logger prefix hscComponents comps dflags = do
493+ cacheDir <- liftIO $ getCacheDir prefix (hscComponents ++ componentOptions comps)
494+ liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack cacheDir
495+ pure $ dflags
496+ & setHiDir cacheDir
497+ & setDefaultHieDir cacheDir
498+
499+
500+renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic
501+renderCradleError nfp (CradleError _ec t) =
502+ ideErrorText nfp (T.unlines (map T.pack t))
503+
504+-- See Note [Multi Cradle Dependency Info]
505+type DependencyInfo = Map.Map FilePath (Maybe UTCTime)
506+type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo])
507+type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))
508+
509+-- This is pristine information about a component
510+data RawComponentInfo = RawComponentInfo
511+ { rawComponentUnitId :: InstalledUnitId
512+ -- | Unprocessed DynFlags. Contains inplace packages such as libraries.
513+ -- We do not want to use them unprocessed.
514+ , rawComponentDynFlags :: DynFlags
515+ -- | All targets of this components.
516+ , rawComponentTargets :: [Target]
517+ -- | Filepath which caused the creation of this component
518+ , rawComponentFP :: NormalizedFilePath
519+ -- | Component Options used to load the component.
520+ , rawComponentCOptions :: ComponentOptions
521+ -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file
522+ -- to last modification time. See Note [Multi Cradle Dependency Info].
523+ , rawComponentDependencyInfo :: DependencyInfo
524+ }
525+
526+-- This is processed information about the component, in particular the dynflags will be modified.
527+data ComponentInfo = ComponentInfo
528+ { componentUnitId :: InstalledUnitId
529+ -- | Processed DynFlags. Does not contain inplace packages such as local
530+ -- libraries. Can be used to actually load this Component.
531+ , componentDynFlags :: DynFlags
532+ -- | Internal units, such as local libraries, that this component
533+ -- is loaded with. These have been extracted from the original
534+ -- ComponentOptions.
535+ , componentInternalUnits :: [InstalledUnitId]
536+ -- | All targets of this components.
537+ , componentTargets :: [Target]
538+ -- | Filepath which caused the creation of this component
539+ , componentFP :: NormalizedFilePath
540+ -- | Component Options used to load the component.
541+ , componentCOptions :: ComponentOptions
542+ -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file
543+ -- to last modification time. See Note [Multi Cradle Dependency Info]
544+ , componentDependencyInfo :: DependencyInfo
545+ }
546+
547+-- | Check if any dependency has been modified lately.
548+checkDependencyInfo :: DependencyInfo -> IO Bool
549+checkDependencyInfo old_di = do
550+ di <- getDependencyInfo (Map.keys old_di)
551+ return (di == old_di)
552+
553+-- Note [Multi Cradle Dependency Info]
554+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
555+-- Why do we implement our own file modification tracking here?
556+-- The primary reason is that the custom caching logic is quite complicated and going into shake
557+-- adds even more complexity and more indirection. I did try for about 5 hours to work out how to
558+-- use shake rules rather than IO but eventually gave up.
559+
560+-- | Computes a mapping from a filepath to its latest modification date.
561+-- See Note [Multi Cradle Dependency Info] why we do this ourselves instead
562+-- of letting shake take care of it.
563+getDependencyInfo :: [FilePath] -> IO DependencyInfo
564+getDependencyInfo fs = Map.fromList <$> mapM do_one fs
565+
566+ where
567+ tryIO :: IO a -> IO (Either IOException a)
568+ tryIO = try
569+
570+ do_one :: FilePath -> IO (FilePath, Maybe UTCTime)
571+ do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp)
572+
573+-- | This function removes all the -package flags which refer to packages we
574+-- are going to deal with ourselves. For example, if a executable depends
575+-- on a library component, then this function will remove the library flag
576+-- from the package flags for the executable
577+--
578+-- There are several places in GHC (for example the call to hptInstances in
579+-- tcRnImports) which assume that all modules in the HPT have the same unit
580+-- ID. Therefore we create a fake one and give them all the same unit id.
581+removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId])
582+removeInplacePackages us df = (df { packageFlags = ps
583+ , thisInstalledUnitId = fake_uid }, uids)
584+ where
585+ (uids, ps) = partitionEithers (map go (packageFlags df))
586+ fake_uid = toInstalledUnitId (stringToUnitId "fake_uid")
587+ go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us
588+ then Left (toInstalledUnitId u)
589+ else Right p
590+ go p = Right p
591+
210-- | Memoize an IO function, with the characteristics:
592-- | Memoize an IO function, with the characteristics:
211--
593--
212-- * If multiple people ask for a result simultaneously, make sure you only compute it once.
594-- * If multiple people ask for a result simultaneously, make sure you only compute it once.
@@ -223,3 +605,79 @@ memoIO op = do
223 res <- onceFork $ op k
605 res <- onceFork $ op k
224 return (Map.insert k res mp, res)
606 return (Map.insert k res mp, res)
225 Just res -> return (mp, res)
607 Just res -> return (mp, res)
608+
609+setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [Target])
610+setOptions (ComponentOptions theOpts compRoot _) dflags = do
611+ (dflags', targets) <- addCmdOpts theOpts dflags
612+ let dflags'' =
613+ -- disabled, generated directly by ghcide instead
614+ flip gopt_unset Opt_WriteInterface $
615+ -- disabled, generated directly by ghcide instead
616+ -- also, it can confuse the interface stale check
617+ dontWriteHieFiles $
618+ setIgnoreInterfacePragmas $
619+ setLinkerOptions $
620+ disableOptimisation $
621+ makeDynFlagsAbsolute compRoot dflags'
622+ -- initPackages parses the -package flags and
623+ -- sets up the visibility for each component.
624+ (final_df, _) <- liftIO $ initPackages dflags''
625+ return (final_df, targets)
626+
627+
628+-- we don't want to generate object code so we compile to bytecode
629+-- (HscInterpreted) which implies LinkInMemory
630+-- HscInterpreted
631+setLinkerOptions :: DynFlags -> DynFlags
632+setLinkerOptions df = df {
633+ ghcLink = LinkInMemory
634+ , hscTarget = HscNothing
635+ , ghcMode = CompManager
636+ }
637+
638+setIgnoreInterfacePragmas :: DynFlags -> DynFlags
639+setIgnoreInterfacePragmas df =
640+ gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges
641+
642+disableOptimisation :: DynFlags -> DynFlags
643+disableOptimisation df = updOptLevel 0 df
644+
645+setHiDir :: FilePath -> DynFlags -> DynFlags
646+setHiDir f d =
647+ -- override user settings to avoid conflicts leading to recompilation
648+ d { hiDir = Just f}
649+
650+getCacheDir :: String -> [String] -> IO FilePath
651+getCacheDir prefix opts = IO.getXdgDirectory IO.XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)
652+ where
653+ -- Create a unique folder per set of different GHC options, assuming that each different set of
654+ -- GHC options will create incompatible interface files.
655+ opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts)
656+
657+-- | Sub directory for the cache path
658+cacheDir :: String
659+cacheDir = "ghcide"
660+
661+notifyCradleLoaded :: FilePath -> FromServerMessage
662+notifyCradleLoaded fp =
663+ NotCustomServer $
664+ NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $
665+ toJSON fp
666+
667+cradleLoadedMethod :: T.Text
668+cradleLoadedMethod = "ghcide/cradle/loaded"
669+
670+ghcVersionChecker :: IO VersionCheck
671+ghcVersionChecker = $$(makeGhcVersionChecker (pure <$> getLibdir))
672+
673+checkGhcVersion :: IO (Maybe HscEnvEq)
674+checkGhcVersion = do
675+ res <- ghcVersionChecker
676+ case res of
677+ Failure err -> do
678+ putStrLn $ "Error while checking GHC version: " ++ show err
679+ return Nothing
680+ Mismatch {..} ->
681+ return $ Just GhcVersionMismatch {..}
682+ _ ->
683+ return Nothing
exe/Utils.hsnew file+9
@@ -0,0 +1,9 @@
1+module Utils (getLibdir) where
2+
3+import qualified GHC.Paths
4+import System.Environment
5+import Data.Maybe
6+
7+-- Set the GHC libdir to the nix libdir if it's present.
8+getLibdir :: IO FilePath
9+getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
fmt.sh+1−1
@@ -1,3 +1,3 @@
1#!/usr/bin/env bash
1#!/usr/bin/env bash
2set -eou pipefail
2set -eou pipefail
3−curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s .
3+curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s . --with-group=extra
ghcide.cabal+112−17
@@ -2,12 +2,12 @@ cabal-version: 1.20
2build-type: Simple
2build-type: Simple
3category: Development
3category: Development
4name: ghcide
4name: ghcide
5−version: 0.0.6
5+version: 0.2.0
6license: Apache-2.0
6license: Apache-2.0
7license-file: LICENSE
7license-file: LICENSE
8author: Digital Asset
8author: Digital Asset
9maintainer: Digital Asset
9maintainer: Digital Asset
10−copyright: Digital Asset 2018-2019
10+copyright: Digital Asset 2018-2020
11synopsis: The core of an IDE
11synopsis: The core of an IDE
12description:
12description:
13 A library for building Haskell IDE's on top of the GHC API.
13 A library for building Haskell IDE's on top of the GHC API.
@@ -15,7 +15,13 @@ homepage: https://github.com/digital-asset/ghcide#readme
15bug-reports: https://github.com/digital-asset/ghcide/issues
15bug-reports: https://github.com/digital-asset/ghcide/issues
16tested-with: GHC==8.6.5
16tested-with: GHC==8.6.5
17extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md
17extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md
18− test/data/GotoHover.hs
18+ test/data/hover/*.hs
19+ test/data/multi/cabal.project
20+ test/data/multi/hie.yaml
21+ test/data/multi/a/a.cabal
22+ test/data/multi/a/*.hs
23+ test/data/multi/b/b.cabal
24+ test/data/multi/b/*.hs
19
25
20source-repository head
26source-repository head
21 type: git
27 type: git
@@ -30,6 +36,7 @@ library
30 default-language: Haskell2010
36 default-language: Haskell2010
31 build-depends:
37 build-depends:
32 aeson,
38 aeson,
39+ array,
33 async,
40 async,
34 base == 4.*,
41 base == 4.*,
35 binary,
42 binary,
@@ -41,10 +48,10 @@ library
41 extra,
48 extra,
42 fuzzy,
49 fuzzy,
43 filepath,
50 filepath,
44− haddock-library,
51+ haddock-library >= 1.8,
45 hashable,
52 hashable,
46− haskell-lsp-types == 0.19.*,
53+ haskell-lsp-types == 0.22.*,
47− haskell-lsp == 0.19.*,
54+ haskell-lsp == 0.22.*,
48 mtl,
55 mtl,
49 network-uri,
56 network-uri,
50 prettyprinter-ansi-terminal,
57 prettyprinter-ansi-terminal,
@@ -53,14 +60,14 @@ library
53 regex-tdfa >= 1.3.1.0,
60 regex-tdfa >= 1.3.1.0,
54 rope-utf16-splay,
61 rope-utf16-splay,
55 safe-exceptions,
62 safe-exceptions,
56− shake >= 0.17.5,
63+ shake >= 0.18.4,
57 sorted-list,
64 sorted-list,
58 stm,
65 stm,
59 syb,
66 syb,
60 text,
67 text,
61 time,
68 time,
62 transformers,
69 transformers,
63− unordered-containers,
70+ unordered-containers >= 0.2.10.0,
64 utf8-string,
71 utf8-string,
65 hslogger
72 hslogger
66 if flag(ghc-lib)
73 if flag(ghc-lib)
@@ -73,7 +80,10 @@ library
73 ghc-boot-th,
80 ghc-boot-th,
74 ghc-boot,
81 ghc-boot,
75 ghc >= 8.4
82 ghc >= 8.4
76− if !os(windows)
83+ if os(windows)
84+ build-depends:
85+ Win32
86+ else
77 build-depends:
87 build-depends:
78 unix
88 unix
79 c-sources:
89 c-sources:
@@ -99,7 +109,10 @@ library
99 include-dirs:
109 include-dirs:
100 include
110 include
101 exposed-modules:
111 exposed-modules:
112+ Development.IDE.Compat
113+ Development.IDE.Core.Debouncer
102 Development.IDE.Core.FileStore
114 Development.IDE.Core.FileStore
115+ Development.IDE.Core.IdeConfiguration
103 Development.IDE.Core.OfInterest
116 Development.IDE.Core.OfInterest
104 Development.IDE.Core.PositionMapping
117 Development.IDE.Core.PositionMapping
105 Development.IDE.Core.Rules
118 Development.IDE.Core.Rules
@@ -109,7 +122,9 @@ library
109 Development.IDE.GHC.Error
122 Development.IDE.GHC.Error
110 Development.IDE.GHC.Util
123 Development.IDE.GHC.Util
111 Development.IDE.Import.DependencyInformation
124 Development.IDE.Import.DependencyInformation
125+ Development.IDE.LSP.HoverDefinition
112 Development.IDE.LSP.LanguageServer
126 Development.IDE.LSP.LanguageServer
127+ Development.IDE.LSP.Outline
113 Development.IDE.LSP.Protocol
128 Development.IDE.LSP.Protocol
114 Development.IDE.LSP.Server
129 Development.IDE.LSP.Server
115 Development.IDE.Spans.Common
130 Development.IDE.Spans.Common
@@ -121,7 +136,6 @@ library
121 Development.IDE.Plugin.Completions
136 Development.IDE.Plugin.Completions
122 Development.IDE.Plugin.CodeAction
137 Development.IDE.Plugin.CodeAction
123 other-modules:
138 other-modules:
124− Development.IDE.Core.Debouncer
125 Development.IDE.Core.Compile
139 Development.IDE.Core.Compile
126 Development.IDE.Core.Preprocessor
140 Development.IDE.Core.Preprocessor
127 Development.IDE.Core.FileExists
141 Development.IDE.Core.FileExists
@@ -129,22 +143,32 @@ library
129 Development.IDE.GHC.CPP
143 Development.IDE.GHC.CPP
130 Development.IDE.GHC.Orphans
144 Development.IDE.GHC.Orphans
131 Development.IDE.GHC.Warnings
145 Development.IDE.GHC.Warnings
146+ Development.IDE.GHC.WithDynFlags
132 Development.IDE.Import.FindImports
147 Development.IDE.Import.FindImports
133− Development.IDE.LSP.HoverDefinition
134 Development.IDE.LSP.Notifications
148 Development.IDE.LSP.Notifications
135− Development.IDE.LSP.Outline
136 Development.IDE.Spans.AtPoint
149 Development.IDE.Spans.AtPoint
137 Development.IDE.Spans.Calculate
150 Development.IDE.Spans.Calculate
138 Development.IDE.Spans.Documentation
151 Development.IDE.Spans.Documentation
139 Development.IDE.Spans.Type
152 Development.IDE.Spans.Type
153+ Development.IDE.Plugin.CodeAction.PositionIndexed
154+ Development.IDE.Plugin.CodeAction.Rules
155+ Development.IDE.Plugin.CodeAction.RuleTypes
140 Development.IDE.Plugin.Completions.Logic
156 Development.IDE.Plugin.Completions.Logic
141 Development.IDE.Plugin.Completions.Types
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
142 ghc-options: -Wall -Wno-name-shadowing
166 ghc-options: -Wall -Wno-name-shadowing
143
167
144executable ghcide-test-preprocessor
168executable ghcide-test-preprocessor
145 default-language: Haskell2010
169 default-language: Haskell2010
146 hs-source-dirs: test/preprocessor
170 hs-source-dirs: test/preprocessor
147− ghc-options: -Wall
171+ ghc-options: -Wall -Wno-name-shadowing
148 main-is: Main.hs
172 main-is: Main.hs
149 build-depends:
173 build-depends:
150 base == 4.*
174 base == 4.*
@@ -166,29 +190,52 @@ executable ghcide
166 "-with-rtsopts=-I0 -qg -A128M"
190 "-with-rtsopts=-I0 -qg -A128M"
167 main-is: Main.hs
191 main-is: Main.hs
168 build-depends:
192 build-depends:
193+ time,
194+ async,
169 hslogger,
195 hslogger,
196+ aeson,
170 base == 4.*,
197 base == 4.*,
198+ binary,
199+ base16-bytestring >=0.1.1 && <0.2,
200+ bytestring,
171 containers,
201 containers,
202+ cryptohash-sha1 >=0.11.100 && <0.12,
172 data-default,
203 data-default,
204+ deepseq,
173 directory,
205 directory,
174 extra,
206 extra,
175 filepath,
207 filepath,
208+ ghc-check >= 0.3.0.1 && < 0.4,
176 ghc-paths,
209 ghc-paths,
177 ghc,
210 ghc,
178 gitrev,
211 gitrev,
212+ hashable,
179 haskell-lsp,
213 haskell-lsp,
214+ haskell-lsp-types,
180− hie-bios >= 0.3.2 && < 0.4,
215+ hie-bios >= 0.5.0 && < 0.6,
181 ghcide,
216 ghcide,
182 optparse-applicative,
217 optparse-applicative,
183 shake,
218 shake,
184− text
219+ text,
220+ unordered-containers
185 other-modules:
221 other-modules:
222+ Utils
186 Arguments
223 Arguments
187 Paths_ghcide
224 Paths_ghcide
188
225
189 default-extensions:
226 default-extensions:
227+ BangPatterns
228+ DeriveFunctor
229+ DeriveGeneric
230+ GeneralizedNewtypeDeriving
231+ LambdaCase
232+ NamedFieldPuns
233+ OverloadedStrings
190 RecordWildCards
234 RecordWildCards
235+ ScopedTypeVariables
236+ StandaloneDeriving
191 TupleSections
237 TupleSections
238+ TypeApplications
192 ViewPatterns
239 ViewPatterns
193
240
194test-suite ghcide-tests
241test-suite ghcide-tests
@@ -218,13 +265,21 @@ test-suite ghcide-tests
218 ghcide,
265 ghcide,
219 ghc-typelits-knownnat,
266 ghc-typelits-knownnat,
220 haddock-library,
267 haddock-library,
268+ haskell-lsp,
221 haskell-lsp-types,
269 haskell-lsp-types,
270+ network-uri,
222 lens,
271 lens,
223− lsp-test >= 0.8,
272+ lsp-test >= 0.11.0.1 && < 0.12,
224 parser-combinators,
273 parser-combinators,
274+ QuickCheck,
275+ quickcheck-instances,
276+ rope-utf16-splay,
277+ shake,
225 tasty,
278 tasty,
226− tasty-hunit,
227 tasty-expected-failure,
279 tasty-expected-failure,
280+ tasty-hunit,
281+ tasty-quickcheck,
282+ tasty-rerun,
228 text
283 text
229 hs-source-dirs: test/cabal test/exe test/src
284 hs-source-dirs: test/cabal test/exe test/src
230 include-dirs: include
285 include-dirs: include
@@ -247,3 +302,43 @@ test-suite ghcide-tests
247 TupleSections
302 TupleSections
248 TypeApplications
303 TypeApplications
249 ViewPatterns
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
339+ RecordWildCards
340+ ScopedTypeVariables
341+ StandaloneDeriving
342+ TupleSections
343+ TypeApplications
344+ ViewPatterns
hie.yaml+12−1
@@ -1 +1,12 @@
1+cradle:
2+ cabal:
3+ - path: "./src"
1−cradle: {stack: {component: "ghcide:lib"}}
4+ component: "ghcide:lib:ghcide"
5+ - path: "./exe"
6+ component: "ghcide:exe:ghcide"
7+ - path: "./test"
8+ component: "ghcide:test:ghcide-tests"
9+ - path: "./bench"
10+ component: "ghcide:benchmark:ghcide-bench"
11+ - path: "./test/preprocessor"
12+ component: "ghcide:exe:ghcide-test-preprocessor"
src-ghc810/Development/IDE/GHC/HieAst.hsnew file+1928
@@ -0,0 +1,1928 @@
1+
2+
3+{-
4+Forked from GHC v8.10.1 to work around the readFile side effect in mkHiefile
5+
6+Main functions for .hie file generation
7+-}
8+{- HLINT ignore -}
9+{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE FlexibleInstances #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+{-# LANGUAGE FlexibleContexts #-}
13+{-# LANGUAGE TypeSynonymInstances #-}
14+{-# LANGUAGE ScopedTypeVariables #-}
15+{-# LANGUAGE TypeFamilies #-}
16+{-# LANGUAGE TypeApplications #-}
17+{-# LANGUAGE AllowAmbiguousTypes #-}
18+{-# LANGUAGE ViewPatterns #-}
19+{-# LANGUAGE DeriveDataTypeable #-}
20+module Development.IDE.GHC.HieAst ( mkHieFile ) where
21+
22+import GhcPrelude
23+
24+import Avail ( Avails )
25+import Bag ( Bag, bagToList )
26+import BasicTypes
27+import BooleanFormula
28+import Class ( FunDep )
29+import CoreUtils ( exprType )
30+import ConLike ( conLikeName )
31+import Desugar ( deSugarExpr )
32+import FieldLabel
33+import GHC.Hs
34+import HscTypes
35+import Module ( ModuleName, ml_hs_file )
36+import MonadUtils ( concatMapM, liftIO )
37+import Name ( Name, nameSrcSpan, setNameLoc )
38+import NameEnv ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )
39+import SrcLoc
40+import TcHsSyn ( hsLitType, hsPatType )
41+import Type ( mkVisFunTys, Type )
42+import TysWiredIn ( mkListTy, mkSumTy )
43+import Var ( Id, Var, setVarName, varName, varType )
44+import TcRnTypes
45+import MkIface ( mkIfaceExports )
46+import Panic
47+
48+import HieTypes
49+import HieUtils
50+
51+import qualified Data.Array as A
52+import qualified Data.ByteString as BS
53+import qualified Data.Map as M
54+import qualified Data.Set as S
55+import Data.Data ( Data, Typeable )
56+import Data.List ( foldl1' )
57+import Data.Maybe ( listToMaybe )
58+import Control.Monad.Trans.Reader
59+import Control.Monad.Trans.Class ( lift )
60+
61+{- Note [Updating HieAst for changes in the GHC AST]
62+
63+When updating the code in this file for changes in the GHC AST, you
64+need to pay attention to the following things:
65+
66+1) Symbols (Names/Vars/Modules) in the following categories:
67+
68+ a) Symbols that appear in the source file that directly correspond to
69+ something the user typed
70+ b) Symbols that don't appear in the source, but should be in some sense
71+ "visible" to a user, particularly via IDE tooling or the like. This
72+ includes things like the names introduced by RecordWildcards (We record
73+ all the names introduced by a (..) in HIE files), and will include implicit
74+ parameters and evidence variables after one of my pending MRs lands.
75+
76+2) Subtrees that may contain such symbols, or correspond to a SrcSpan in
77+ the file. This includes all `Located` things
78+
79+For 1), you need to call `toHie` for one of the following instances
80+
81+instance ToHie (Context (Located Name)) where ...
82+instance ToHie (Context (Located Var)) where ...
83+instance ToHie (IEContext (Located ModuleName)) where ...
84+
85+`Context` is a data type that looks like:
86+
87+data Context a = C ContextInfo a -- Used for names and bindings
88+
89+`ContextInfo` is defined in `HieTypes`, and looks like
90+
91+data ContextInfo
92+ = Use -- ^ regular variable
93+ | MatchBind
94+ | IEThing IEType -- ^ import/export
95+ | TyDecl
96+ -- | Value binding
97+ | ValBind
98+ BindType -- ^ whether or not the binding is in an instance
99+ Scope -- ^ scope over which the value is bound
100+ (Maybe Span) -- ^ span of entire binding
101+ ...
102+
103+It is used to annotate symbols in the .hie files with some extra information on
104+the context in which they occur and should be fairly self explanatory. You need
105+to select one that looks appropriate for the symbol usage. In very rare cases,
106+you might need to extend this sum type if none of the cases seem appropriate.
107+
108+So, given a `Located Name` that is just being "used", and not defined at a
109+particular location, you would do the following:
110+
111+ toHie $ C Use located_name
112+
113+If you select one that corresponds to a binding site, you will need to
114+provide a `Scope` and a `Span` for your binding. Both of these are basically
115+`SrcSpans`.
116+
117+The `SrcSpan` in the `Scope` is supposed to span over the part of the source
118+where the symbol can be legally allowed to occur. For more details on how to
119+calculate this, see Note [Capturing Scopes and other non local information]
120+in HieAst.
121+
122+The binding `Span` is supposed to be the span of the entire binding for
123+the name.
124+
125+For a function definition `foo`:
126+
127+foo x = x + y
128+ where y = x^2
129+
130+The binding `Span` is the span of the entire function definition from `foo x`
131+to `x^2`. For a class definition, this is the span of the entire class, and
132+so on. If this isn't well defined for your bit of syntax (like a variable
133+bound by a lambda), then you can just supply a `Nothing`
134+
135+There is a test that checks that all symbols in the resulting HIE file
136+occur inside their stated `Scope`. This can be turned on by passing the
137+-fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the
138+.hie file.
139+
140+You may also want to provide a test in testsuite/test/hiefile that includes
141+a file containing your new construction, and tests that the calculated scope
142+is valid (by using -fvalidate-ide-info)
143+
144+For subtrees in the AST that may contain symbols, the procedure is fairly
145+straightforward. If you are extending the GHC AST, you will need to provide a
146+`ToHie` instance for any new types you may have introduced in the AST.
147+
148+Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)):
149+
150+ toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
151+ HsVar _ (L _ var) ->
152+ [ toHie $ C Use (L mspan var)
153+ -- Patch up var location since typechecker removes it
154+ ]
155+ HsConLikeOut _ con ->
156+ [ toHie $ C Use $ L mspan $ conLikeName con
157+ ]
158+ ...
159+ HsApp _ a b ->
160+ [ toHie a
161+ , toHie b
162+ ]
163+
164+If your subtree is `Located` or has a `SrcSpan` available, the output list
165+should contain a HieAst `Node` corresponding to the subtree. You can use
166+either `makeNode` or `getTypeNode` for this purpose, depending on whether it
167+makes sense to assign a `Type` to the subtree. After this, you just need
168+to concatenate the result of calling `toHie` on all subexpressions and
169+appropriately annotated symbols contained in the subtree.
170+
171+The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed
172+to work for both the renamed and typechecked source. `getTypeNode` is from
173+the `HasType` class defined in this file, and it has different instances
174+for `GhcTc` and `GhcRn` that allow it to access the type of the expression
175+when given a typechecked AST:
176+
177+class Data a => HasType a where
178+ getTypeNode :: a -> HieM [HieAST Type]
179+instance HasType (LHsExpr GhcTc) where
180+ getTypeNode e@(L spn e') = ... -- Actually get the type for this expression
181+instance HasType (LHsExpr GhcRn) where
182+ getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type
183+
184+If your subtree doesn't have a span available, you can omit the `makeNode`
185+call and just recurse directly in to the subexpressions.
186+
187+-}
188+
189+-- These synonyms match those defined in main/GHC.hs
190+type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn]
191+ , Maybe [(LIE GhcRn, Avails)]
192+ , Maybe LHsDocString )
193+type TypecheckedSource = LHsBinds GhcTc
194+
195+
196+{- Note [Name Remapping]
197+The Typechecker introduces new names for mono names in AbsBinds.
198+We don't care about the distinction between mono and poly bindings,
199+so we replace all occurrences of the mono name with the poly name.
200+-}
201+newtype HieState = HieState
202+ { name_remapping :: NameEnv Id
203+ }
204+
205+initState :: HieState
206+initState = HieState emptyNameEnv
207+
208+class ModifyState a where -- See Note [Name Remapping]
209+ addSubstitution :: a -> a -> HieState -> HieState
210+
211+instance ModifyState Name where
212+ addSubstitution _ _ hs = hs
213+
214+instance ModifyState Id where
215+ addSubstitution mono poly hs =
216+ hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly}
217+
218+modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState
219+modifyState = foldr go id
220+ where
221+ go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f
222+ go _ f = f
223+
224+type HieM = ReaderT HieState Hsc
225+
226+-- | Construct an 'HieFile' from the outputs of the typechecker.
227+mkHieFile :: ModSummary
228+ -> TcGblEnv
229+ -> RenamedSource
230+ -> BS.ByteString -> Hsc HieFile
231+mkHieFile ms ts rs src = do
232+ let tc_binds = tcg_binds ts
233+ (asts', arr) <- getCompressedAsts tc_binds rs
234+ let Just src_file = ml_hs_file $ ms_location ms
235+ return $ HieFile
236+ { hie_hs_file = src_file
237+ , hie_module = ms_mod ms
238+ , hie_types = arr
239+ , hie_asts = asts'
240+ -- mkIfaceExports sorts the AvailInfos for stability
241+ , hie_exports = mkIfaceExports (tcg_exports ts)
242+ , hie_hs_src = src
243+ }
244+
245+getCompressedAsts :: TypecheckedSource -> RenamedSource
246+ -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
247+getCompressedAsts ts rs = do
248+ asts <- enrichHie ts rs
249+ return $ compressTypes asts
250+
251+enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)
252+enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do
253+ tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts
254+ rasts <- processGrp hsGrp
255+ imps <- toHie $ filter (not . ideclImplicit . unLoc) imports
256+ exps <- toHie $ fmap (map $ IEC Export . fst) exports
257+ let spanFile children = case children of
258+ [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)
259+ _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)
260+ (realSrcSpanEnd $ nodeSpan $ last children)
261+
262+ modulify xs =
263+ Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs
264+
265+ asts = HieASTs
266+ $ resolveTyVarScopes
267+ $ M.map (modulify . mergeSortAsts)
268+ $ M.fromListWith (++)
269+ $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
270+
271+ flat_asts = concat
272+ [ tasts
273+ , rasts
274+ , imps
275+ , exps
276+ ]
277+ return asts
278+ where
279+ processGrp grp = concatM
280+ [ toHie $ fmap (RS ModuleScope ) hs_valds grp
281+ , toHie $ hs_splcds grp
282+ , toHie $ hs_tyclds grp
283+ , toHie $ hs_derivds grp
284+ , toHie $ hs_fixds grp
285+ , toHie $ hs_defds grp
286+ , toHie $ hs_fords grp
287+ , toHie $ hs_warnds grp
288+ , toHie $ hs_annds grp
289+ , toHie $ hs_ruleds grp
290+ ]
291+
292+getRealSpan :: SrcSpan -> Maybe Span
293+getRealSpan (RealSrcSpan sp) = Just sp
294+getRealSpan _ = Nothing
295+
296+grhss_span :: GRHSs p body -> SrcSpan
297+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)
298+grhss_span (XGRHSs _) = panic "XGRHS has no span"
299+
300+bindingsOnly :: [Context Name] -> [HieAST a]
301+bindingsOnly [] = []
302+bindingsOnly (C c n : xs) = case nameSrcSpan n of
303+ RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs
304+ where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
305+ info = mempty{identInfo = S.singleton c}
306+ _ -> bindingsOnly xs
307+
308+concatM :: Monad m => [m [a]] -> m [a]
309+concatM xs = concat <$> sequence xs
310+
311+{- Note [Capturing Scopes and other non local information]
312+toHie is a local tranformation, but scopes of bindings cannot be known locally,
313+hence we have to push the relevant info down into the binding nodes.
314+We use the following types (*Context and *Scoped) to wrap things and
315+carry the required info
316+(Maybe Span) always carries the span of the entire binding, including rhs
317+-}
318+data Context a = C ContextInfo a -- Used for names and bindings
319+
320+data RContext a = RC RecFieldContext a
321+data RFContext a = RFC RecFieldContext (Maybe Span) a
322+-- ^ context for record fields
323+
324+data IEContext a = IEC IEType a
325+-- ^ context for imports/exports
326+
327+data BindContext a = BC BindType Scope a
328+-- ^ context for imports/exports
329+
330+data PatSynFieldContext a = PSC (Maybe Span) a
331+-- ^ context for pattern synonym fields.
332+
333+data SigContext a = SC SigInfo a
334+-- ^ context for type signatures
335+
336+data SigInfo = SI SigType (Maybe Span)
337+
338+data SigType = BindSig | ClassSig | InstSig
339+
340+data RScoped a = RS Scope a
341+-- ^ Scope spans over everything to the right of a, (mostly) not
342+-- including a itself
343+-- (Includes a in a few special cases like recursive do bindings) or
344+-- let/where bindings
345+
346+-- | Pattern scope
347+data PScoped a = PS (Maybe Span)
348+ Scope -- ^ use site of the pattern
349+ Scope -- ^ pattern to the right of a, not including a
350+ a
351+ deriving (Typeable, Data) -- Pattern Scope
352+
353+{- Note [TyVar Scopes]
354+Due to -XScopedTypeVariables, type variables can be in scope quite far from
355+their original binding. We resolve the scope of these type variables
356+in a separate pass
357+-}
358+data TScoped a = TS TyVarScope a -- TyVarScope
359+
360+data TVScoped a = TVS TyVarScope Scope a -- TyVarScope
361+-- ^ First scope remains constant
362+-- Second scope is used to build up the scope of a tyvar over
363+-- things to its right, ala RScoped
364+
365+-- | Each element scopes over the elements to the right
366+listScopes :: Scope -> [Located a] -> [RScoped (Located a)]
367+listScopes _ [] = []
368+listScopes rhsScope [pat] = [RS rhsScope pat]
369+listScopes rhsScope (pat : pats) = RS sc pat : pats'
370+ where
371+ pats'@((RS scope p):_) = listScopes rhsScope pats
372+ sc = combineScopes scope $ mkScope $ getLoc p
373+
374+-- | 'listScopes' specialised to 'PScoped' things
375+patScopes
376+ :: Maybe Span
377+ -> Scope
378+ -> Scope
379+ -> [LPat (GhcPass p)]
380+ -> [PScoped (LPat (GhcPass p))]
381+patScopes rsp useScope patScope xs =
382+ map (\(RS sc a) -> PS rsp useScope sc (composeSrcSpan a)) $
383+ listScopes patScope (map dL xs)
384+
385+-- | 'listScopes' specialised to 'TVScoped' things
386+tvScopes
387+ :: TyVarScope
388+ -> Scope
389+ -> [LHsTyVarBndr a]
390+ -> [TVScoped (LHsTyVarBndr a)]
391+tvScopes tvScope rhsScope xs =
392+ map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs
393+
394+{- Note [Scoping Rules for SigPat]
395+Explicitly quantified variables in pattern type signatures are not
396+brought into scope in the rhs, but implicitly quantified variables
397+are (HsWC and HsIB).
398+This is unlike other signatures, where explicitly quantified variables
399+are brought into the RHS Scope
400+For example
401+foo :: forall a. ...;
402+foo = ... -- a is in scope here
403+
404+bar (x :: forall a. a -> a) = ... -- a is not in scope here
405+-- ^ a is in scope here (pattern body)
406+
407+bax (x :: a) = ... -- a is in scope here
408+Because of HsWC and HsIB pass on their scope to their children
409+we must wrap the LHsType in pattern signatures in a
410+Shielded explictly, so that the HsWC/HsIB scope is not passed
411+on the the LHsType
412+-}
413+
414+data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead
415+
416+type family ProtectedSig a where
417+ ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs
418+ GhcRn
419+ (Shielded (LHsType GhcRn)))
420+ ProtectedSig GhcTc = NoExtField
421+
422+class ProtectSig a where
423+ protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a
424+
425+instance (HasLoc a) => HasLoc (Shielded a) where
426+ loc (SH _ a) = loc a
427+
428+instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where
429+ toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)
430+
431+instance ProtectSig GhcTc where
432+ protectSig _ _ = noExtField
433+
434+instance ProtectSig GhcRn where
435+ protectSig sc (HsWC a (HsIB b sig)) =
436+ HsWC a (HsIB b (SH sc sig))
437+ protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec
438+ protectSig _ (XHsWildCardBndrs nec) = noExtCon nec
439+
440+class HasLoc a where
441+ -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can
442+ -- know what their implicit bindings are scoping over
443+ loc :: a -> SrcSpan
444+
445+instance HasLoc thing => HasLoc (TScoped thing) where
446+ loc (TS _ a) = loc a
447+
448+instance HasLoc thing => HasLoc (PScoped thing) where
449+ loc (PS _ _ _ a) = loc a
450+
451+instance HasLoc (LHsQTyVars GhcRn) where
452+ loc (HsQTvs _ vs) = loc vs
453+ loc _ = noSrcSpan
454+
455+instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where
456+ loc (HsIB _ a) = loc a
457+ loc _ = noSrcSpan
458+
459+instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where
460+ loc (HsWC _ a) = loc a
461+ loc _ = noSrcSpan
462+
463+instance HasLoc (Located a) where
464+ loc (L l _) = l
465+
466+instance HasLoc a => HasLoc [a] where
467+ loc [] = noSrcSpan
468+ loc xs = foldl1' combineSrcSpans $ map loc xs
469+
470+instance HasLoc a => HasLoc (FamEqn s a) where
471+ loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]
472+ loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
473+ [loc a, loc tvs, loc b, loc c]
474+ loc _ = noSrcSpan
475+instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
476+ loc (HsValArg tm) = loc tm
477+ loc (HsTypeArg _ ty) = loc ty
478+ loc (HsArgPar sp) = sp
479+
480+instance HasLoc (HsDataDefn GhcRn) where
481+ loc def@(HsDataDefn{}) = loc $ dd_cons def
482+ -- Only used for data family instances, so we only need rhs
483+ -- Most probably the rest will be unhelpful anyway
484+ loc _ = noSrcSpan
485+
486+{- Note [Real DataCon Name]
487+The typechecker subtitutes the conLikeWrapId for the name, but we don't want
488+this showing up in the hieFile, so we replace the name in the Id with the
489+original datacon name
490+See also Note [Data Constructor Naming]
491+-}
492+class HasRealDataConName p where
493+ getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p)
494+
495+instance HasRealDataConName GhcRn where
496+ getRealDataCon _ n = n
497+instance HasRealDataConName GhcTc where
498+ getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) =
499+ L sp (setVarName var (conLikeName con))
500+
501+-- | The main worker class
502+-- See Note [Updating HieAst for changes in the GHC AST] for more information
503+-- on how to add/modify instances for this.
504+class ToHie a where
505+ toHie :: a -> HieM [HieAST Type]
506+
507+-- | Used to collect type info
508+class Data a => HasType a where
509+ getTypeNode :: a -> HieM [HieAST Type]
510+
511+instance (ToHie a) => ToHie [a] where
512+ toHie = concatMapM toHie
513+
514+instance (ToHie a) => ToHie (Bag a) where
515+ toHie = toHie . bagToList
516+
517+instance (ToHie a) => ToHie (Maybe a) where
518+ toHie = maybe (pure []) toHie
519+
520+instance ToHie (Context (Located NoExtField)) where
521+ toHie _ = pure []
522+
523+instance ToHie (TScoped NoExtField) where
524+ toHie _ = pure []
525+
526+instance ToHie (IEContext (Located ModuleName)) where
527+ toHie (IEC c (L (RealSrcSpan span) mname)) =
528+ pure $ [Node (NodeInfo S.empty [] idents) span []]
529+ where details = mempty{identInfo = S.singleton (IEThing c)}
530+ idents = M.singleton (Left mname) details
531+ toHie _ = pure []
532+
533+instance ToHie (Context (Located Var)) where
534+ toHie c = case c of
535+ C context (L (RealSrcSpan span) name')
536+ -> do
537+ m <- asks name_remapping
538+ let name = case lookupNameEnv m (varName name') of
539+ Just var -> var
540+ Nothing-> name'
541+ pure
542+ [Node
543+ (NodeInfo S.empty [] $
544+ M.singleton (Right $ varName name)
545+ (IdentifierDetails (Just $ varType name')
546+ (S.singleton context)))
547+ span
548+ []]
549+ _ -> pure []
550+
551+instance ToHie (Context (Located Name)) where
552+ toHie c = case c of
553+ C context (L (RealSrcSpan span) name') -> do
554+ m <- asks name_remapping
555+ let name = case lookupNameEnv m name' of
556+ Just var -> varName var
557+ Nothing -> name'
558+ pure
559+ [Node
560+ (NodeInfo S.empty [] $
561+ M.singleton (Right name)
562+ (IdentifierDetails Nothing
563+ (S.singleton context)))
564+ span
565+ []]
566+ _ -> pure []
567+
568+-- | Dummy instances - never called
569+instance ToHie (TScoped (LHsSigWcType GhcTc)) where
570+ toHie _ = pure []
571+instance ToHie (TScoped (LHsWcType GhcTc)) where
572+ toHie _ = pure []
573+instance ToHie (SigContext (LSig GhcTc)) where
574+ toHie _ = pure []
575+instance ToHie (TScoped Type) where
576+ toHie _ = pure []
577+
578+instance HasType (LHsBind GhcRn) where
579+ getTypeNode (L spn bind) = makeNode bind spn
580+
581+instance HasType (LHsBind GhcTc) where
582+ getTypeNode (L spn bind) = case bind of
583+ FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)
584+ _ -> makeNode bind spn
585+
586+instance HasType (Located (Pat GhcRn)) where
587+ getTypeNode (dL -> L spn pat) = makeNode pat spn
588+
589+instance HasType (Located (Pat GhcTc)) where
590+ getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)
591+
592+instance HasType (LHsExpr GhcRn) where
593+ getTypeNode (L spn e) = makeNode e spn
594+
595+-- | This instance tries to construct 'HieAST' nodes which include the type of
596+-- the expression. It is not yet possible to do this efficiently for all
597+-- expression forms, so we skip filling in the type for those inputs.
598+--
599+-- 'HsApp', for example, doesn't have any type information available directly on
600+-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then
601+-- query the type of that. Yet both the desugaring call and the type query both
602+-- involve recursive calls to the function and argument! This is particularly
603+-- problematic when you realize that the HIE traversal will eventually visit
604+-- those nodes too and ask for their types again.
605+--
606+-- Since the above is quite costly, we just skip cases where computing the
607+-- expression's type is going to be expensive.
608+--
609+-- See #16233
610+instance HasType (LHsExpr GhcTc) where
611+ getTypeNode e@(L spn e') = lift $
612+ -- Some expression forms have their type immediately available
613+ let tyOpt = case e' of
614+ HsLit _ l -> Just (hsLitType l)
615+ HsOverLit _ o -> Just (overLitType o)
616+
617+ HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
618+ HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
619+ HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)
620+
621+ ExplicitList ty _ _ -> Just (mkListTy ty)
622+ ExplicitSum ty _ _ _ -> Just (mkSumTy ty)
623+ HsDo ty _ _ -> Just ty
624+ HsMultiIf ty _ -> Just ty
625+
626+ _ -> Nothing
627+
628+ in
629+ case tyOpt of
630+ Just t -> makeTypeNode e' spn t
631+ Nothing
632+ | skipDesugaring e' -> fallback
633+ | otherwise -> do
634+ hs_env <- Hsc $ \e w -> return (e,w)
635+ (_,mbe) <- liftIO $ deSugarExpr hs_env e
636+ maybe fallback (makeTypeNode e' spn . exprType) mbe
637+ where
638+ fallback = makeNode e' spn
639+
640+ matchGroupType :: MatchGroupTc -> Type
641+ matchGroupType (MatchGroupTc args res) = mkVisFunTys args res
642+
643+ -- | Skip desugaring of these expressions for performance reasons.
644+ --
645+ -- See impact on Haddock output (esp. missing type annotations or links)
646+ -- before marking more things here as 'False'. See impact on Haddock
647+ -- performance before marking more things as 'True'.
648+ skipDesugaring :: HsExpr a -> Bool
649+ skipDesugaring e = case e of
650+ HsVar{} -> False
651+ HsUnboundVar{} -> False
652+ HsConLikeOut{} -> False
653+ HsRecFld{} -> False
654+ HsOverLabel{} -> False
655+ HsIPVar{} -> False
656+ HsWrap{} -> False
657+ _ -> True
658+
659+instance ( ToHie (Context (Located (IdP a)))
660+ , ToHie (MatchGroup a (LHsExpr a))
661+ , ToHie (PScoped (LPat a))
662+ , ToHie (GRHSs a (LHsExpr a))
663+ , ToHie (LHsExpr a)
664+ , ToHie (Located (PatSynBind a a))
665+ , HasType (LHsBind a)
666+ , ModifyState (IdP a)
667+ , Data (HsBind a)
668+ ) => ToHie (BindContext (LHsBind a)) where
669+ toHie (BC context scope b@(L span bind)) =
670+ concatM $ getTypeNode b : case bind of
671+ FunBind{fun_id = name, fun_matches = matches} ->
672+ [ toHie $ C (ValBind context scope $ getRealSpan span) name
673+ , toHie matches
674+ ]
675+ PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
676+ [ toHie $ PS (getRealSpan span) scope NoScope lhs
677+ , toHie rhs
678+ ]
679+ VarBind{var_rhs = expr} ->
680+ [ toHie expr
681+ ]
682+ AbsBinds{abs_exports = xs, abs_binds = binds} ->
683+ [ local (modifyState xs) $ -- Note [Name Remapping]
684+ toHie $ fmap (BC context scope) binds
685+ ]
686+ PatSynBind _ psb ->
687+ [ toHie $ L span psb -- PatSynBinds only occur at the top level
688+ ]
689+ XHsBindsLR _ -> []
690+
691+instance ( ToHie (LMatch a body)
692+ ) => ToHie (MatchGroup a body) where
693+ toHie mg = concatM $ case mg of
694+ MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->
695+ [ pure $ locOnly span
696+ , toHie alts
697+ ]
698+ MG{} -> []
699+ XMatchGroup _ -> []
700+
701+instance ( ToHie (Context (Located (IdP a)))
702+ , ToHie (PScoped (LPat a))
703+ , ToHie (HsPatSynDir a)
704+ ) => ToHie (Located (PatSynBind a a)) where
705+ toHie (L sp psb) = concatM $ case psb of
706+ PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->
707+ [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var
708+ , toHie $ toBind dets
709+ , toHie $ PS Nothing lhsScope NoScope pat
710+ , toHie dir
711+ ]
712+ where
713+ lhsScope = combineScopes varScope detScope
714+ varScope = mkLScope var
715+ detScope = case dets of
716+ (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args
717+ (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)
718+ (RecCon r) -> foldr go NoScope r
719+ go (RecordPatSynField a b) c = combineScopes c
720+ $ combineScopes (mkLScope a) (mkLScope b)
721+ detSpan = case detScope of
722+ LocalScope a -> Just a
723+ _ -> Nothing
724+ toBind (PrefixCon args) = PrefixCon $ map (C Use) args
725+ toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
726+ toBind (RecCon r) = RecCon $ map (PSC detSpan) r
727+ XPatSynBind _ -> []
728+
729+instance ( ToHie (MatchGroup a (LHsExpr a))
730+ ) => ToHie (HsPatSynDir a) where
731+ toHie dir = case dir of
732+ ExplicitBidirectional mg -> toHie mg
733+ _ -> pure []
734+
735+instance ( a ~ GhcPass p
736+ , ToHie body
737+ , ToHie (HsMatchContext (NameOrRdrName (IdP a)))
738+ , ToHie (PScoped (LPat a))
739+ , ToHie (GRHSs a body)
740+ , Data (Match a body)
741+ ) => ToHie (LMatch (GhcPass p) body) where
742+ toHie (L span m ) = concatM $ makeNode m span : case m of
743+ Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->
744+ [ toHie mctx
745+ , let rhsScope = mkScope $ grhss_span grhss
746+ in toHie $ patScopes Nothing rhsScope NoScope pats
747+ , toHie grhss
748+ ]
749+ XMatch _ -> []
750+
751+instance ( ToHie (Context (Located a))
752+ ) => ToHie (HsMatchContext a) where
753+ toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name
754+ toHie (StmtCtxt a) = toHie a
755+ toHie _ = pure []
756+
757+instance ( ToHie (HsMatchContext a)
758+ ) => ToHie (HsStmtContext a) where
759+ toHie (PatGuard a) = toHie a
760+ toHie (ParStmtCtxt a) = toHie a
761+ toHie (TransStmtCtxt a) = toHie a
762+ toHie _ = pure []
763+
764+instance ( a ~ GhcPass p
765+ , ToHie (Context (Located (IdP a)))
766+ , ToHie (RContext (HsRecFields a (PScoped (LPat a))))
767+ , ToHie (LHsExpr a)
768+ , ToHie (TScoped (LHsSigWcType a))
769+ , ProtectSig a
770+ , ToHie (TScoped (ProtectedSig a))
771+ , HasType (LPat a)
772+ , Data (HsSplice a)
773+ ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where
774+ toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =
775+ concatM $ getTypeNode lpat : case opat of
776+ WildPat _ ->
777+ []
778+ VarPat _ lname ->
779+ [ toHie $ C (PatternBind scope pscope rsp) lname
780+ ]
781+ LazyPat _ p ->
782+ [ toHie $ PS rsp scope pscope p
783+ ]
784+ AsPat _ lname pat ->
785+ [ toHie $ C (PatternBind scope
786+ (combineScopes (mkLScope (dL pat)) pscope)
787+ rsp)
788+ lname
789+ , toHie $ PS rsp scope pscope pat
790+ ]
791+ ParPat _ pat ->
792+ [ toHie $ PS rsp scope pscope pat
793+ ]
794+ BangPat _ pat ->
795+ [ toHie $ PS rsp scope pscope pat
796+ ]
797+ ListPat _ pats ->
798+ [ toHie $ patScopes rsp scope pscope pats
799+ ]
800+ TuplePat _ pats _ ->
801+ [ toHie $ patScopes rsp scope pscope pats
802+ ]
803+ SumPat _ pat _ _ ->
804+ [ toHie $ PS rsp scope pscope pat
805+ ]
806+ ConPatIn c dets ->
807+ [ toHie $ C Use c
808+ , toHie $ contextify dets
809+ ]
810+ ConPatOut {pat_con = con, pat_args = dets}->
811+ [ toHie $ C Use $ fmap conLikeName con
812+ , toHie $ contextify dets
813+ ]
814+ ViewPat _ expr pat ->
815+ [ toHie expr
816+ , toHie $ PS rsp scope pscope pat
817+ ]
818+ SplicePat _ sp ->
819+ [ toHie $ L ospan sp
820+ ]
821+ LitPat _ _ ->
822+ []
823+ NPat _ _ _ _ ->
824+ []
825+ NPlusKPat _ n _ _ _ _ ->
826+ [ toHie $ C (PatternBind scope pscope rsp) n
827+ ]
828+ SigPat _ pat sig ->
829+ [ toHie $ PS rsp scope pscope pat
830+ , let cscope = mkLScope (dL pat) in
831+ toHie $ TS (ResolvedScopes [cscope, scope, pscope])
832+ (protectSig @a cscope sig)
833+ -- See Note [Scoping Rules for SigPat]
834+ ]
835+ CoPat _ _ _ _ ->
836+ []
837+ XPat _ -> []
838+ where
839+ contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
840+ contextify (InfixCon a b) = InfixCon a' b'
841+ where [a', b'] = patScopes rsp scope pscope [a,b]
842+ contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r
843+ contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a
844+ where
845+ go (RS fscope (L spn (HsRecField lbl pat pun))) =
846+ L spn $ HsRecField lbl (PS rsp scope fscope pat) pun
847+ scoped_fds = listScopes pscope fds
848+
849+instance ( ToHie body
850+ , ToHie (LGRHS a body)
851+ , ToHie (RScoped (LHsLocalBinds a))
852+ ) => ToHie (GRHSs a body) where
853+ toHie grhs = concatM $ case grhs of
854+ GRHSs _ grhss binds ->
855+ [ toHie grhss
856+ , toHie $ RS (mkScope $ grhss_span grhs) binds
857+ ]
858+ XGRHSs _ -> []
859+
860+instance ( ToHie (Located body)
861+ , ToHie (RScoped (GuardLStmt a))
862+ , Data (GRHS a (Located body))
863+ ) => ToHie (LGRHS a (Located body)) where
864+ toHie (L span g) = concatM $ makeNode g span : case g of
865+ GRHS _ guards body ->
866+ [ toHie $ listScopes (mkLScope body) guards
867+ , toHie body
868+ ]
869+ XGRHS _ -> []
870+
871+instance ( a ~ GhcPass p
872+ , ToHie (Context (Located (IdP a)))
873+ , HasType (LHsExpr a)
874+ , ToHie (PScoped (LPat a))
875+ , ToHie (MatchGroup a (LHsExpr a))
876+ , ToHie (LGRHS a (LHsExpr a))
877+ , ToHie (RContext (HsRecordBinds a))
878+ , ToHie (RFContext (Located (AmbiguousFieldOcc a)))
879+ , ToHie (ArithSeqInfo a)
880+ , ToHie (LHsCmdTop a)
881+ , ToHie (RScoped (GuardLStmt a))
882+ , ToHie (RScoped (LHsLocalBinds a))
883+ , ToHie (TScoped (LHsWcType (NoGhcTc a)))
884+ , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))
885+ , Data (HsExpr a)
886+ , Data (HsSplice a)
887+ , Data (HsTupArg a)
888+ , Data (AmbiguousFieldOcc a)
889+ , (HasRealDataConName a)
890+ ) => ToHie (LHsExpr (GhcPass p)) where
891+ toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
892+ HsVar _ (L _ var) ->
893+ [ toHie $ C Use (L mspan var)
894+ -- Patch up var location since typechecker removes it
895+ ]
896+ HsUnboundVar _ _ ->
897+ []
898+ HsConLikeOut _ con ->
899+ [ toHie $ C Use $ L mspan $ conLikeName con
900+ ]
901+ HsRecFld _ fld ->
902+ [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)
903+ ]
904+ HsOverLabel _ _ _ -> []
905+ HsIPVar _ _ -> []
906+ HsOverLit _ _ -> []
907+ HsLit _ _ -> []
908+ HsLam _ mg ->
909+ [ toHie mg
910+ ]
911+ HsLamCase _ mg ->
912+ [ toHie mg
913+ ]
914+ HsApp _ a b ->
915+ [ toHie a
916+ , toHie b
917+ ]
918+ HsAppType _ expr sig ->
919+ [ toHie expr
920+ , toHie $ TS (ResolvedScopes []) sig
921+ ]
922+ OpApp _ a b c ->
923+ [ toHie a
924+ , toHie b
925+ , toHie c
926+ ]
927+ NegApp _ a _ ->
928+ [ toHie a
929+ ]
930+ HsPar _ a ->
931+ [ toHie a
932+ ]
933+ SectionL _ a b ->
934+ [ toHie a
935+ , toHie b
936+ ]
937+ SectionR _ a b ->
938+ [ toHie a
939+ , toHie b
940+ ]
941+ ExplicitTuple _ args _ ->
942+ [ toHie args
943+ ]
944+ ExplicitSum _ _ _ expr ->
945+ [ toHie expr
946+ ]
947+ HsCase _ expr matches ->
948+ [ toHie expr
949+ , toHie matches
950+ ]
951+ HsIf _ _ a b c ->
952+ [ toHie a
953+ , toHie b
954+ , toHie c
955+ ]
956+ HsMultiIf _ grhss ->
957+ [ toHie grhss
958+ ]
959+ HsLet _ binds expr ->
960+ [ toHie $ RS (mkLScope expr) binds
961+ , toHie expr
962+ ]
963+ HsDo _ _ (L ispan stmts) ->
964+ [ pure $ locOnly ispan
965+ , toHie $ listScopes NoScope stmts
966+ ]
967+ ExplicitList _ _ exprs ->
968+ [ toHie exprs
969+ ]
970+ RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} ->
971+ [ toHie $ C Use (getRealDataCon @a mrealcon name)
972+ -- See Note [Real DataCon Name]
973+ , toHie $ RC RecFieldAssign $ binds
974+ ]
975+ RecordUpd {rupd_expr = expr, rupd_flds = upds}->
976+ [ toHie expr
977+ , toHie $ map (RC RecFieldAssign) upds
978+ ]
979+ ExprWithTySig _ expr sig ->
980+ [ toHie expr
981+ , toHie $ TS (ResolvedScopes [mkLScope expr]) sig
982+ ]
983+ ArithSeq _ _ info ->
984+ [ toHie info
985+ ]
986+ HsSCC _ _ _ expr ->
987+ [ toHie expr
988+ ]
989+ HsCoreAnn _ _ _ expr ->
990+ [ toHie expr
991+ ]
992+ HsProc _ pat cmdtop ->
993+ [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat
994+ , toHie cmdtop
995+ ]
996+ HsStatic _ expr ->
997+ [ toHie expr
998+ ]
999+ HsTick _ _ expr ->
1000+ [ toHie expr
1001+ ]
1002+ HsBinTick _ _ _ expr ->
1003+ [ toHie expr
1004+ ]
1005+ HsTickPragma _ _ _ _ expr ->
1006+ [ toHie expr
1007+ ]
1008+ HsWrap _ _ a ->
1009+ [ toHie $ L mspan a
1010+ ]
1011+ HsBracket _ b ->
1012+ [ toHie b
1013+ ]
1014+ HsRnBracketOut _ b p ->
1015+ [ toHie b
1016+ , toHie p
1017+ ]
1018+ HsTcBracketOut _ b p ->
1019+ [ toHie b
1020+ , toHie p
1021+ ]
1022+ HsSpliceE _ x ->
1023+ [ toHie $ L mspan x
1024+ ]
1025+ XExpr _ -> []
1026+
1027+instance ( a ~ GhcPass p
1028+ , ToHie (LHsExpr a)
1029+ , Data (HsTupArg a)
1030+ ) => ToHie (LHsTupArg (GhcPass p)) where
1031+ toHie (L span arg) = concatM $ makeNode arg span : case arg of
1032+ Present _ expr ->
1033+ [ toHie expr
1034+ ]
1035+ Missing _ -> []
1036+ XTupArg _ -> []
1037+
1038+instance ( a ~ GhcPass p
1039+ , ToHie (PScoped (LPat a))
1040+ , ToHie (LHsExpr a)
1041+ , ToHie (SigContext (LSig a))
1042+ , ToHie (RScoped (LHsLocalBinds a))
1043+ , ToHie (RScoped (ApplicativeArg a))
1044+ , ToHie (Located body)
1045+ , Data (StmtLR a a (Located body))
1046+ , Data (StmtLR a a (Located (HsExpr a)))
1047+ ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where
1048+ toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of
1049+ LastStmt _ body _ _ ->
1050+ [ toHie body
1051+ ]
1052+ BindStmt _ pat body _ _ ->
1053+ [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat
1054+ , toHie body
1055+ ]
1056+ ApplicativeStmt _ stmts _ ->
1057+ [ concatMapM (toHie . RS scope . snd) stmts
1058+ ]
1059+ BodyStmt _ body _ _ ->
1060+ [ toHie body
1061+ ]
1062+ LetStmt _ binds ->
1063+ [ toHie $ RS scope binds
1064+ ]
1065+ ParStmt _ parstmts _ _ ->
1066+ [ concatMapM (\(ParStmtBlock _ stmts _ _) ->
1067+ toHie $ listScopes NoScope stmts)
1068+ parstmts
1069+ ]
1070+ TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->
1071+ [ toHie $ listScopes scope stmts
1072+ , toHie using
1073+ , toHie by
1074+ ]
1075+ RecStmt {recS_stmts = stmts} ->
1076+ [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts
1077+ ]
1078+ XStmtLR _ -> []
1079+
1080+instance ( ToHie (LHsExpr a)
1081+ , ToHie (PScoped (LPat a))
1082+ , ToHie (BindContext (LHsBind a))
1083+ , ToHie (SigContext (LSig a))
1084+ , ToHie (RScoped (HsValBindsLR a a))
1085+ , Data (HsLocalBinds a)
1086+ ) => ToHie (RScoped (LHsLocalBinds a)) where
1087+ toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of
1088+ EmptyLocalBinds _ -> []
1089+ HsIPBinds _ _ -> []
1090+ HsValBinds _ valBinds ->
1091+ [ toHie $ RS (combineScopes scope $ mkScope sp)
1092+ valBinds
1093+ ]
1094+ XHsLocalBindsLR _ -> []
1095+
1096+instance ( ToHie (BindContext (LHsBind a))
1097+ , ToHie (SigContext (LSig a))
1098+ , ToHie (RScoped (XXValBindsLR a a))
1099+ ) => ToHie (RScoped (HsValBindsLR a a)) where
1100+ toHie (RS sc v) = concatM $ case v of
1101+ ValBinds _ binds sigs ->
1102+ [ toHie $ fmap (BC RegularBind sc) binds
1103+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
1104+ ]
1105+ XValBindsLR x -> [ toHie $ RS sc x ]
1106+
1107+instance ToHie (RScoped (NHsValBindsLR GhcTc)) where
1108+ toHie (RS sc (NValBinds binds sigs)) = concatM $
1109+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
1110+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
1111+ ]
1112+instance ToHie (RScoped (NHsValBindsLR GhcRn)) where
1113+ toHie (RS sc (NValBinds binds sigs)) = concatM $
1114+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
1115+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
1116+ ]
1117+
1118+instance ( ToHie (RContext (LHsRecField a arg))
1119+ ) => ToHie (RContext (HsRecFields a arg)) where
1120+ toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields
1121+
1122+instance ( ToHie (RFContext (Located label))
1123+ , ToHie arg
1124+ , HasLoc arg
1125+ , Data label
1126+ , Data arg
1127+ ) => ToHie (RContext (LHsRecField' label arg)) where
1128+ toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of
1129+ HsRecField label expr _ ->
1130+ [ toHie $ RFC c (getRealSpan $ loc expr) label
1131+ , toHie expr
1132+ ]
1133+
1134+removeDefSrcSpan :: Name -> Name
1135+removeDefSrcSpan n = setNameLoc n noSrcSpan
1136+
1137+instance ToHie (RFContext (LFieldOcc GhcRn)) where
1138+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of
1139+ FieldOcc name _ ->
1140+ [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)
1141+ ]
1142+ XFieldOcc _ -> []
1143+
1144+instance ToHie (RFContext (LFieldOcc GhcTc)) where
1145+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of
1146+ FieldOcc var _ ->
1147+ let var' = setVarName var (removeDefSrcSpan $ varName var)
1148+ in [ toHie $ C (RecField c rhs) (L nspan var')
1149+ ]
1150+ XFieldOcc _ -> []
1151+
1152+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
1153+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
1154+ Unambiguous name _ ->
1155+ [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name
1156+ ]
1157+ Ambiguous _name _ ->
1158+ [ ]
1159+ XAmbiguousFieldOcc _ -> []
1160+
1161+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
1162+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
1163+ Unambiguous var _ ->
1164+ let var' = setVarName var (removeDefSrcSpan $ varName var)
1165+ in [ toHie $ C (RecField c rhs) (L nspan var')
1166+ ]
1167+ Ambiguous var _ ->
1168+ let var' = setVarName var (removeDefSrcSpan $ varName var)
1169+ in [ toHie $ C (RecField c rhs) (L nspan var')
1170+ ]
1171+ XAmbiguousFieldOcc _ -> []
1172+
1173+instance ( a ~ GhcPass p
1174+ , ToHie (PScoped (LPat a))
1175+ , ToHie (BindContext (LHsBind a))
1176+ , ToHie (LHsExpr a)
1177+ , ToHie (SigContext (LSig a))
1178+ , ToHie (RScoped (HsValBindsLR a a))
1179+ , Data (StmtLR a a (Located (HsExpr a)))
1180+ , Data (HsLocalBinds a)
1181+ ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
1182+ toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM
1183+ [ toHie $ PS Nothing sc NoScope pat
1184+ , toHie expr
1185+ ]
1186+ toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM
1187+ [ toHie $ listScopes NoScope stmts
1188+ , toHie $ PS Nothing sc NoScope pat
1189+ ]
1190+ toHie (RS _ (XApplicativeArg _)) = pure []
1191+
1192+instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where
1193+ toHie (PrefixCon args) = toHie args
1194+ toHie (RecCon rec) = toHie rec
1195+ toHie (InfixCon a b) = concatM [ toHie a, toHie b]
1196+
1197+instance ( ToHie (LHsCmd a)
1198+ , Data (HsCmdTop a)
1199+ ) => ToHie (LHsCmdTop a) where
1200+ toHie (L span top) = concatM $ makeNode top span : case top of
1201+ HsCmdTop _ cmd ->
1202+ [ toHie cmd
1203+ ]
1204+ XCmdTop _ -> []
1205+
1206+instance ( a ~ GhcPass p
1207+ , ToHie (PScoped (LPat a))
1208+ , ToHie (BindContext (LHsBind a))
1209+ , ToHie (LHsExpr a)
1210+ , ToHie (MatchGroup a (LHsCmd a))
1211+ , ToHie (SigContext (LSig a))
1212+ , ToHie (RScoped (HsValBindsLR a a))
1213+ , Data (HsCmd a)
1214+ , Data (HsCmdTop a)
1215+ , Data (StmtLR a a (Located (HsCmd a)))
1216+ , Data (HsLocalBinds a)
1217+ , Data (StmtLR a a (Located (HsExpr a)))
1218+ ) => ToHie (LHsCmd (GhcPass p)) where
1219+ toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of
1220+ HsCmdArrApp _ a b _ _ ->
1221+ [ toHie a
1222+ , toHie b
1223+ ]
1224+ HsCmdArrForm _ a _ _ cmdtops ->
1225+ [ toHie a
1226+ , toHie cmdtops
1227+ ]
1228+ HsCmdApp _ a b ->
1229+ [ toHie a
1230+ , toHie b
1231+ ]
1232+ HsCmdLam _ mg ->
1233+ [ toHie mg
1234+ ]
1235+ HsCmdPar _ a ->
1236+ [ toHie a
1237+ ]
1238+ HsCmdCase _ expr alts ->
1239+ [ toHie expr
1240+ , toHie alts
1241+ ]
1242+ HsCmdIf _ _ a b c ->
1243+ [ toHie a
1244+ , toHie b
1245+ , toHie c
1246+ ]
1247+ HsCmdLet _ binds cmd' ->
1248+ [ toHie $ RS (mkLScope cmd') binds
1249+ , toHie cmd'
1250+ ]
1251+ HsCmdDo _ (L ispan stmts) ->
1252+ [ pure $ locOnly ispan
1253+ , toHie $ listScopes NoScope stmts
1254+ ]
1255+ HsCmdWrap _ _ _ -> []
1256+ XCmd _ -> []
1257+
1258+instance ToHie (TyClGroup GhcRn) where
1259+ toHie TyClGroup{ group_tyclds = classes
1260+ , group_roles = roles
1261+ , group_kisigs = sigs
1262+ , group_instds = instances } =
1263+ concatM
1264+ [ toHie classes
1265+ , toHie sigs
1266+ , toHie roles
1267+ , toHie instances
1268+ ]
1269+ toHie (XTyClGroup _) = pure []
1270+
1271+instance ToHie (LTyClDecl GhcRn) where
1272+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1273+ FamDecl {tcdFam = fdecl} ->
1274+ [ toHie (L span fdecl)
1275+ ]
1276+ SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->
1277+ [ toHie $ C (Decl SynDec $ getRealSpan span) name
1278+ , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars
1279+ , toHie typ
1280+ ]
1281+ DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->
1282+ [ toHie $ C (Decl DataDec $ getRealSpan span) name
1283+ , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars
1284+ , toHie defn
1285+ ]
1286+ where
1287+ quant_scope = mkLScope $ dd_ctxt defn
1288+ rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc
1289+ sig_sc = maybe NoScope mkLScope $ dd_kindSig defn
1290+ con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn
1291+ deriv_sc = mkLScope $ dd_derivs defn
1292+ ClassDecl { tcdCtxt = context
1293+ , tcdLName = name
1294+ , tcdTyVars = vars
1295+ , tcdFDs = deps
1296+ , tcdSigs = sigs
1297+ , tcdMeths = meths
1298+ , tcdATs = typs
1299+ , tcdATDefs = deftyps
1300+ } ->
1301+ [ toHie $ C (Decl ClassDec $ getRealSpan span) name
1302+ , toHie context
1303+ , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars
1304+ , toHie deps
1305+ , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs
1306+ , toHie $ fmap (BC InstanceBind ModuleScope) meths
1307+ , toHie typs
1308+ , concatMapM (pure . locOnly . getLoc) deftyps
1309+ , toHie deftyps
1310+ ]
1311+ where
1312+ context_scope = mkLScope context
1313+ rhs_scope = foldl1' combineScopes $ map mkScope
1314+ [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
1315+ XTyClDecl _ -> []
1316+
1317+instance ToHie (LFamilyDecl GhcRn) where
1318+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1319+ FamilyDecl _ info name vars _ sig inj ->
1320+ [ toHie $ C (Decl FamDec $ getRealSpan span) name
1321+ , toHie $ TS (ResolvedScopes [rhsSpan]) vars
1322+ , toHie info
1323+ , toHie $ RS injSpan sig
1324+ , toHie inj
1325+ ]
1326+ where
1327+ rhsSpan = sigSpan `combineScopes` injSpan
1328+ sigSpan = mkScope $ getLoc sig
1329+ injSpan = maybe NoScope (mkScope . getLoc) inj
1330+ XFamilyDecl _ -> []
1331+
1332+instance ToHie (FamilyInfo GhcRn) where
1333+ toHie (ClosedTypeFamily (Just eqns)) = concatM $
1334+ [ concatMapM (pure . locOnly . getLoc) eqns
1335+ , toHie $ map go eqns
1336+ ]
1337+ where
1338+ go (L l ib) = TS (ResolvedScopes [mkScope l]) ib
1339+ toHie _ = pure []
1340+
1341+instance ToHie (RScoped (LFamilyResultSig GhcRn)) where
1342+ toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of
1343+ NoSig _ ->
1344+ []
1345+ KindSig _ k ->
1346+ [ toHie k
1347+ ]
1348+ TyVarSig _ bndr ->
1349+ [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr
1350+ ]
1351+ XFamilyResultSig _ -> []
1352+
1353+instance ToHie (Located (FunDep (Located Name))) where
1354+ toHie (L span fd@(lhs, rhs)) = concatM $
1355+ [ makeNode fd span
1356+ , toHie $ map (C Use) lhs
1357+ , toHie $ map (C Use) rhs
1358+ ]
1359+
1360+instance (ToHie rhs, HasLoc rhs)
1361+ => ToHie (TScoped (FamEqn GhcRn rhs)) where
1362+ toHie (TS _ f) = toHie f
1363+
1364+instance (ToHie rhs, HasLoc rhs)
1365+ => ToHie (FamEqn GhcRn rhs) where
1366+ toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $
1367+ [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var
1368+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
1369+ , toHie pats
1370+ , toHie rhs
1371+ ]
1372+ where scope = combineScopes patsScope rhsScope
1373+ patsScope = mkScope (loc pats)
1374+ rhsScope = mkScope (loc rhs)
1375+ toHie (XFamEqn _) = pure []
1376+
1377+instance ToHie (LInjectivityAnn GhcRn) where
1378+ toHie (L span ann) = concatM $ makeNode ann span : case ann of
1379+ InjectivityAnn lhs rhs ->
1380+ [ toHie $ C Use lhs
1381+ , toHie $ map (C Use) rhs
1382+ ]
1383+
1384+instance ToHie (HsDataDefn GhcRn) where
1385+ toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM
1386+ [ toHie ctx
1387+ , toHie mkind
1388+ , toHie cons
1389+ , toHie derivs
1390+ ]
1391+ toHie (XHsDataDefn _) = pure []
1392+
1393+instance ToHie (HsDeriving GhcRn) where
1394+ toHie (L span clauses) = concatM
1395+ [ pure $ locOnly span
1396+ , toHie clauses
1397+ ]
1398+
1399+instance ToHie (LHsDerivingClause GhcRn) where
1400+ toHie (L span cl) = concatM $ makeNode cl span : case cl of
1401+ HsDerivingClause _ strat (L ispan tys) ->
1402+ [ toHie strat
1403+ , pure $ locOnly ispan
1404+ , toHie $ map (TS (ResolvedScopes [])) tys
1405+ ]
1406+ XHsDerivingClause _ -> []
1407+
1408+instance ToHie (Located (DerivStrategy GhcRn)) where
1409+ toHie (L span strat) = concatM $ makeNode strat span : case strat of
1410+ StockStrategy -> []
1411+ AnyclassStrategy -> []
1412+ NewtypeStrategy -> []
1413+ ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]
1414+
1415+instance ToHie (Located OverlapMode) where
1416+ toHie (L span _) = pure $ locOnly span
1417+
1418+instance ToHie (LConDecl GhcRn) where
1419+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1420+ ConDeclGADT { con_names = names, con_qvars = qvars
1421+ , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
1422+ [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names
1423+ , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars
1424+ , toHie ctx
1425+ , toHie args
1426+ , toHie typ
1427+ ]
1428+ where
1429+ rhsScope = combineScopes argsScope tyScope
1430+ ctxScope = maybe NoScope mkLScope ctx
1431+ argsScope = condecl_scope args
1432+ tyScope = mkLScope typ
1433+ ConDeclH98 { con_name = name, con_ex_tvs = qvars
1434+ , con_mb_cxt = ctx, con_args = dets } ->
1435+ [ toHie $ C (Decl ConDec $ getRealSpan span) name
1436+ , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars
1437+ , toHie ctx
1438+ , toHie dets
1439+ ]
1440+ where
1441+ rhsScope = combineScopes ctxScope argsScope
1442+ ctxScope = maybe NoScope mkLScope ctx
1443+ argsScope = condecl_scope dets
1444+ XConDecl _ -> []
1445+ where condecl_scope args = case args of
1446+ PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs
1447+ InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)
1448+ RecCon x -> mkLScope x
1449+
1450+instance ToHie (Located [LConDeclField GhcRn]) where
1451+ toHie (L span decls) = concatM $
1452+ [ pure $ locOnly span
1453+ , toHie decls
1454+ ]
1455+
1456+instance ( HasLoc thing
1457+ , ToHie (TScoped thing)
1458+ ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where
1459+ toHie (TS sc (HsIB ibrn a)) = concatM $
1460+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
1461+ , toHie $ TS sc a
1462+ ]
1463+ where span = loc a
1464+ toHie (TS _ (XHsImplicitBndrs _)) = pure []
1465+
1466+instance ( HasLoc thing
1467+ , ToHie (TScoped thing)
1468+ ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where
1469+ toHie (TS sc (HsWC names a)) = concatM $
1470+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
1471+ , toHie $ TS sc a
1472+ ]
1473+ where span = loc a
1474+ toHie (TS _ (XHsWildCardBndrs _)) = pure []
1475+
1476+instance ToHie (LStandaloneKindSig GhcRn) where
1477+ toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]
1478+
1479+instance ToHie (StandaloneKindSig GhcRn) where
1480+ toHie sig = concatM $ case sig of
1481+ StandaloneKindSig _ name typ ->
1482+ [ toHie $ C TyDecl name
1483+ , toHie $ TS (ResolvedScopes []) typ
1484+ ]
1485+ XStandaloneKindSig _ -> []
1486+
1487+instance ToHie (SigContext (LSig GhcRn)) where
1488+ toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of
1489+ TypeSig _ names typ ->
1490+ [ toHie $ map (C TyDecl) names
1491+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1492+ ]
1493+ PatSynSig _ names typ ->
1494+ [ toHie $ map (C TyDecl) names
1495+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1496+ ]
1497+ ClassOpSig _ _ names typ ->
1498+ [ case styp of
1499+ ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names
1500+ _ -> toHie $ map (C $ TyDecl) names
1501+ , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
1502+ ]
1503+ IdSig _ _ -> []
1504+ FixSig _ fsig ->
1505+ [ toHie $ L sp fsig
1506+ ]
1507+ InlineSig _ name _ ->
1508+ [ toHie $ (C Use) name
1509+ ]
1510+ SpecSig _ name typs _ ->
1511+ [ toHie $ (C Use) name
1512+ , toHie $ map (TS (ResolvedScopes [])) typs
1513+ ]
1514+ SpecInstSig _ _ typ ->
1515+ [ toHie $ TS (ResolvedScopes []) typ
1516+ ]
1517+ MinimalSig _ _ form ->
1518+ [ toHie form
1519+ ]
1520+ SCCFunSig _ _ name mtxt ->
1521+ [ toHie $ (C Use) name
1522+ , pure $ maybe [] (locOnly . getLoc) mtxt
1523+ ]
1524+ CompleteMatchSig _ _ (L ispan names) typ ->
1525+ [ pure $ locOnly ispan
1526+ , toHie $ map (C Use) names
1527+ , toHie $ fmap (C Use) typ
1528+ ]
1529+ XSig _ -> []
1530+
1531+instance ToHie (LHsType GhcRn) where
1532+ toHie x = toHie $ TS (ResolvedScopes []) x
1533+
1534+instance ToHie (TScoped (LHsType GhcRn)) where
1535+ toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of
1536+ HsForAllTy _ _ bndrs body ->
1537+ [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs
1538+ , toHie body
1539+ ]
1540+ HsQualTy _ ctx body ->
1541+ [ toHie ctx
1542+ , toHie body
1543+ ]
1544+ HsTyVar _ _ var ->
1545+ [ toHie $ C Use var
1546+ ]
1547+ HsAppTy _ a b ->
1548+ [ toHie a
1549+ , toHie b
1550+ ]
1551+ HsAppKindTy _ ty ki ->
1552+ [ toHie ty
1553+ , toHie $ TS (ResolvedScopes []) ki
1554+ ]
1555+ HsFunTy _ a b ->
1556+ [ toHie a
1557+ , toHie b
1558+ ]
1559+ HsListTy _ a ->
1560+ [ toHie a
1561+ ]
1562+ HsTupleTy _ _ tys ->
1563+ [ toHie tys
1564+ ]
1565+ HsSumTy _ tys ->
1566+ [ toHie tys
1567+ ]
1568+ HsOpTy _ a op b ->
1569+ [ toHie a
1570+ , toHie $ C Use op
1571+ , toHie b
1572+ ]
1573+ HsParTy _ a ->
1574+ [ toHie a
1575+ ]
1576+ HsIParamTy _ ip ty ->
1577+ [ toHie ip
1578+ , toHie ty
1579+ ]
1580+ HsKindSig _ a b ->
1581+ [ toHie a
1582+ , toHie b
1583+ ]
1584+ HsSpliceTy _ a ->
1585+ [ toHie $ L span a
1586+ ]
1587+ HsDocTy _ a _ ->
1588+ [ toHie a
1589+ ]
1590+ HsBangTy _ _ ty ->
1591+ [ toHie ty
1592+ ]
1593+ HsRecTy _ fields ->
1594+ [ toHie fields
1595+ ]
1596+ HsExplicitListTy _ _ tys ->
1597+ [ toHie tys
1598+ ]
1599+ HsExplicitTupleTy _ tys ->
1600+ [ toHie tys
1601+ ]
1602+ HsTyLit _ _ -> []
1603+ HsWildCardTy _ -> []
1604+ HsStarTy _ _ -> []
1605+ XHsType _ -> []
1606+
1607+instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
1608+ toHie (HsValArg tm) = toHie tm
1609+ toHie (HsTypeArg _ ty) = toHie ty
1610+ toHie (HsArgPar sp) = pure $ locOnly sp
1611+
1612+instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where
1613+ toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
1614+ UserTyVar _ var ->
1615+ [ toHie $ C (TyVarBind sc tsc) var
1616+ ]
1617+ KindedTyVar _ var kind ->
1618+ [ toHie $ C (TyVarBind sc tsc) var
1619+ , toHie kind
1620+ ]
1621+ XTyVarBndr _ -> []
1622+
1623+instance ToHie (TScoped (LHsQTyVars GhcRn)) where
1624+ toHie (TS sc (HsQTvs implicits vars)) = concatM $
1625+ [ pure $ bindingsOnly bindings
1626+ , toHie $ tvScopes sc NoScope vars
1627+ ]
1628+ where
1629+ varLoc = loc vars
1630+ bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits
1631+ toHie (TS _ (XLHsQTyVars _)) = pure []
1632+
1633+instance ToHie (LHsContext GhcRn) where
1634+ toHie (L span tys) = concatM $
1635+ [ pure $ locOnly span
1636+ , toHie tys
1637+ ]
1638+
1639+instance ToHie (LConDeclField GhcRn) where
1640+ toHie (L span field) = concatM $ makeNode field span : case field of
1641+ ConDeclField _ fields typ _ ->
1642+ [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields
1643+ , toHie typ
1644+ ]
1645+ XConDeclField _ -> []
1646+
1647+instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
1648+ toHie (From expr) = toHie expr
1649+ toHie (FromThen a b) = concatM $
1650+ [ toHie a
1651+ , toHie b
1652+ ]
1653+ toHie (FromTo a b) = concatM $
1654+ [ toHie a
1655+ , toHie b
1656+ ]
1657+ toHie (FromThenTo a b c) = concatM $
1658+ [ toHie a
1659+ , toHie b
1660+ , toHie c
1661+ ]
1662+
1663+instance ToHie (LSpliceDecl GhcRn) where
1664+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1665+ SpliceDecl _ splice _ ->
1666+ [ toHie splice
1667+ ]
1668+ XSpliceDecl _ -> []
1669+
1670+instance ToHie (HsBracket a) where
1671+ toHie _ = pure []
1672+
1673+instance ToHie PendingRnSplice where
1674+ toHie _ = pure []
1675+
1676+instance ToHie PendingTcSplice where
1677+ toHie _ = pure []
1678+
1679+instance ToHie (LBooleanFormula (Located Name)) where
1680+ toHie (L span form) = concatM $ makeNode form span : case form of
1681+ Var a ->
1682+ [ toHie $ C Use a
1683+ ]
1684+ And forms ->
1685+ [ toHie forms
1686+ ]
1687+ Or forms ->
1688+ [ toHie forms
1689+ ]
1690+ Parens f ->
1691+ [ toHie f
1692+ ]
1693+
1694+instance ToHie (Located HsIPName) where
1695+ toHie (L span e) = makeNode e span
1696+
1697+instance ( ToHie (LHsExpr a)
1698+ , Data (HsSplice a)
1699+ ) => ToHie (Located (HsSplice a)) where
1700+ toHie (L span sp) = concatM $ makeNode sp span : case sp of
1701+ HsTypedSplice _ _ _ expr ->
1702+ [ toHie expr
1703+ ]
1704+ HsUntypedSplice _ _ _ expr ->
1705+ [ toHie expr
1706+ ]
1707+ HsQuasiQuote _ _ _ ispan _ ->
1708+ [ pure $ locOnly ispan
1709+ ]
1710+ HsSpliced _ _ _ ->
1711+ []
1712+ HsSplicedT _ ->
1713+ []
1714+ XSplice _ -> []
1715+
1716+instance ToHie (LRoleAnnotDecl GhcRn) where
1717+ toHie (L span annot) = concatM $ makeNode annot span : case annot of
1718+ RoleAnnotDecl _ var roles ->
1719+ [ toHie $ C Use var
1720+ , concatMapM (pure . locOnly . getLoc) roles
1721+ ]
1722+ XRoleAnnotDecl _ -> []
1723+
1724+instance ToHie (LInstDecl GhcRn) where
1725+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1726+ ClsInstD _ d ->
1727+ [ toHie $ L span d
1728+ ]
1729+ DataFamInstD _ d ->
1730+ [ toHie $ L span d
1731+ ]
1732+ TyFamInstD _ d ->
1733+ [ toHie $ L span d
1734+ ]
1735+ XInstDecl _ -> []
1736+
1737+instance ToHie (LClsInstDecl GhcRn) where
1738+ toHie (L span decl) = concatM
1739+ [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
1740+ , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
1741+ , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl
1742+ , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl
1743+ , toHie $ cid_tyfam_insts decl
1744+ , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl
1745+ , toHie $ cid_datafam_insts decl
1746+ , toHie $ cid_overlap_mode decl
1747+ ]
1748+
1749+instance ToHie (LDataFamInstDecl GhcRn) where
1750+ toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
1751+
1752+instance ToHie (LTyFamInstDecl GhcRn) where
1753+ toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
1754+
1755+instance ToHie (Context a)
1756+ => ToHie (PatSynFieldContext (RecordPatSynField a)) where
1757+ toHie (PSC sp (RecordPatSynField a b)) = concatM $
1758+ [ toHie $ C (RecField RecFieldDecl sp) a
1759+ , toHie $ C Use b
1760+ ]
1761+
1762+instance ToHie (LDerivDecl GhcRn) where
1763+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1764+ DerivDecl _ typ strat overlap ->
1765+ [ toHie $ TS (ResolvedScopes []) typ
1766+ , toHie strat
1767+ , toHie overlap
1768+ ]
1769+ XDerivDecl _ -> []
1770+
1771+instance ToHie (LFixitySig GhcRn) where
1772+ toHie (L span sig) = concatM $ makeNode sig span : case sig of
1773+ FixitySig _ vars _ ->
1774+ [ toHie $ map (C Use) vars
1775+ ]
1776+ XFixitySig _ -> []
1777+
1778+instance ToHie (LDefaultDecl GhcRn) where
1779+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1780+ DefaultDecl _ typs ->
1781+ [ toHie typs
1782+ ]
1783+ XDefaultDecl _ -> []
1784+
1785+instance ToHie (LForeignDecl GhcRn) where
1786+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1787+ ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->
1788+ [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name
1789+ , toHie $ TS (ResolvedScopes []) sig
1790+ , toHie fi
1791+ ]
1792+ ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->
1793+ [ toHie $ C Use name
1794+ , toHie $ TS (ResolvedScopes []) sig
1795+ , toHie fe
1796+ ]
1797+ XForeignDecl _ -> []
1798+
1799+instance ToHie ForeignImport where
1800+ toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $
1801+ [ locOnly a
1802+ , locOnly b
1803+ , locOnly c
1804+ ]
1805+
1806+instance ToHie ForeignExport where
1807+ toHie (CExport (L a _) (L b _)) = pure $ concat $
1808+ [ locOnly a
1809+ , locOnly b
1810+ ]
1811+
1812+instance ToHie (LWarnDecls GhcRn) where
1813+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1814+ Warnings _ _ warnings ->
1815+ [ toHie warnings
1816+ ]
1817+ XWarnDecls _ -> []
1818+
1819+instance ToHie (LWarnDecl GhcRn) where
1820+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1821+ Warning _ vars _ ->
1822+ [ toHie $ map (C Use) vars
1823+ ]
1824+ XWarnDecl _ -> []
1825+
1826+instance ToHie (LAnnDecl GhcRn) where
1827+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1828+ HsAnnotation _ _ prov expr ->
1829+ [ toHie prov
1830+ , toHie expr
1831+ ]
1832+ XAnnDecl _ -> []
1833+
1834+instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where
1835+ toHie (ValueAnnProvenance a) = toHie $ C Use a
1836+ toHie (TypeAnnProvenance a) = toHie $ C Use a
1837+ toHie ModuleAnnProvenance = pure []
1838+
1839+instance ToHie (LRuleDecls GhcRn) where
1840+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1841+ HsRules _ _ rules ->
1842+ [ toHie rules
1843+ ]
1844+ XRuleDecls _ -> []
1845+
1846+instance ToHie (LRuleDecl GhcRn) where
1847+ toHie (L _ (XRuleDecl _)) = pure []
1848+ toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
1849+ [ makeNode r span
1850+ , pure $ locOnly $ getLoc rname
1851+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
1852+ , toHie $ map (RS $ mkScope span) bndrs
1853+ , toHie exprA
1854+ , toHie exprB
1855+ ]
1856+ where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc
1857+ bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)
1858+ exprA_sc = mkLScope exprA
1859+ exprB_sc = mkLScope exprB
1860+
1861+instance ToHie (RScoped (LRuleBndr GhcRn)) where
1862+ toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
1863+ RuleBndr _ var ->
1864+ [ toHie $ C (ValBind RegularBind sc Nothing) var
1865+ ]
1866+ RuleBndrSig _ var typ ->
1867+ [ toHie $ C (ValBind RegularBind sc Nothing) var
1868+ , toHie $ TS (ResolvedScopes [sc]) typ
1869+ ]
1870+ XRuleBndr _ -> []
1871+
1872+instance ToHie (LImportDecl GhcRn) where
1873+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1874+ ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->
1875+ [ toHie $ IEC Import name
1876+ , toHie $ fmap (IEC ImportAs) as
1877+ , maybe (pure []) goIE hidden
1878+ ]
1879+ XImportDecl _ -> []
1880+ where
1881+ goIE (hiding, (L sp liens)) = concatM $
1882+ [ pure $ locOnly sp
1883+ , toHie $ map (IEC c) liens
1884+ ]
1885+ where
1886+ c = if hiding then ImportHiding else Import
1887+
1888+instance ToHie (IEContext (LIE GhcRn)) where
1889+ toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of
1890+ IEVar _ n ->
1891+ [ toHie $ IEC c n
1892+ ]
1893+ IEThingAbs _ n ->
1894+ [ toHie $ IEC c n
1895+ ]
1896+ IEThingAll _ n ->
1897+ [ toHie $ IEC c n
1898+ ]
1899+ IEThingWith _ n _ ns flds ->
1900+ [ toHie $ IEC c n
1901+ , toHie $ map (IEC c) ns
1902+ , toHie $ map (IEC c) flds
1903+ ]
1904+ IEModuleContents _ n ->
1905+ [ toHie $ IEC c n
1906+ ]
1907+ IEGroup _ _ _ -> []
1908+ IEDoc _ _ -> []
1909+ IEDocNamed _ _ -> []
1910+ XIE _ -> []
1911+
1912+instance ToHie (IEContext (LIEWrappedName Name)) where
1913+ toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of
1914+ IEName n ->
1915+ [ toHie $ C (IEThing c) n
1916+ ]
1917+ IEPattern p ->
1918+ [ toHie $ C (IEThing c) p
1919+ ]
1920+ IEType n ->
1921+ [ toHie $ C (IEThing c) n
1922+ ]
1923+
1924+instance ToHie (IEContext (Located (FieldLbl Name))) where
1925+ toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of
1926+ FieldLabel _ _ n ->
1927+ [ toHie $ C (IEThing c) $ L span n
1928+ ]
src-ghc88/Development/IDE/GHC/HieAst.hsnew file+1789
@@ -0,0 +1,1789 @@
1+
2+{-
3+Forked from GHC v8.8.1 to work around the readFile side effect in mkHiefile
4+
5+Main functions for .hie file generation
6+-}
7+{- HLINT ignore -}
8+{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE FlexibleInstances #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+{-# LANGUAGE FlexibleContexts #-}
12+{-# LANGUAGE TypeSynonymInstances #-}
13+{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE TypeApplications #-}
16+{-# LANGUAGE AllowAmbiguousTypes #-}
17+{-# LANGUAGE ViewPatterns #-}
18+{-# LANGUAGE DeriveDataTypeable #-}
19+module Development.IDE.GHC.HieAst ( mkHieFile ) where
20+
21+import Avail ( Avails )
22+import Bag ( Bag, bagToList )
23+import BasicTypes
24+import BooleanFormula
25+import Class ( FunDep )
26+import CoreUtils ( exprType )
27+import ConLike ( conLikeName )
28+import Desugar ( deSugarExpr )
29+import FieldLabel
30+import HsSyn
31+import HscTypes
32+import Module ( ModuleName, ml_hs_file )
33+import MonadUtils ( concatMapM, liftIO )
34+import Name ( Name, nameSrcSpan, setNameLoc )
35+import SrcLoc
36+import TcHsSyn ( hsLitType, hsPatType )
37+import Type ( mkFunTys, Type )
38+import TysWiredIn ( mkListTy, mkSumTy )
39+import Var ( Id, Var, setVarName, varName, varType )
40+import TcRnTypes
41+import MkIface ( mkIfaceExports )
42+
43+import HieTypes
44+import HieUtils
45+
46+import qualified Data.Array as A
47+import qualified Data.ByteString as BS
48+import qualified Data.Map as M
49+import qualified Data.Set as S
50+import Data.Data ( Data, Typeable )
51+import Data.List (foldl', foldl1' )
52+import Data.Maybe ( listToMaybe )
53+import Control.Monad.Trans.Reader
54+import Control.Monad.Trans.Class ( lift )
55+
56+-- These synonyms match those defined in main/GHC.hs
57+type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn]
58+ , Maybe [(LIE GhcRn, Avails)]
59+ , Maybe LHsDocString )
60+type TypecheckedSource = LHsBinds GhcTc
61+
62+
63+{- Note [Name Remapping]
64+The Typechecker introduces new names for mono names in AbsBinds.
65+We don't care about the distinction between mono and poly bindings,
66+so we replace all occurrences of the mono name with the poly name.
67+-}
68+newtype HieState = HieState
69+ { name_remapping :: M.Map Name Id
70+ }
71+
72+initState :: HieState
73+initState = HieState M.empty
74+
75+class ModifyState a where -- See Note [Name Remapping]
76+ addSubstitution :: a -> a -> HieState -> HieState
77+
78+instance ModifyState Name where
79+ addSubstitution _ _ hs = hs
80+
81+instance ModifyState Id where
82+ addSubstitution mono poly hs =
83+ hs{name_remapping = M.insert (varName mono) poly (name_remapping hs)}
84+
85+modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState
86+modifyState = foldr go id
87+ where
88+ go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f
89+ go _ f = f
90+
91+type HieM = ReaderT HieState Hsc
92+
93+-- | Construct an 'HieFile' from the outputs of the typechecker.
94+mkHieFile :: ModSummary
95+ -> TcGblEnv
96+ -> RenamedSource
97+ -> BS.ByteString
98+ -> Hsc HieFile
99+mkHieFile ms ts rs src = do
100+ let tc_binds = tcg_binds ts
101+ (asts', arr) <- getCompressedAsts tc_binds rs
102+ let Just src_file = ml_hs_file $ ms_location ms
103+ return $ HieFile
104+ { hie_hs_file = src_file
105+ , hie_module = ms_mod ms
106+ , hie_types = arr
107+ , hie_asts = asts'
108+ -- mkIfaceExports sorts the AvailInfos for stability
109+ , hie_exports = mkIfaceExports (tcg_exports ts)
110+ , hie_hs_src = src
111+ }
112+
113+getCompressedAsts :: TypecheckedSource -> RenamedSource
114+ -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
115+getCompressedAsts ts rs = do
116+ asts <- enrichHie ts rs
117+ return $ compressTypes asts
118+
119+enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)
120+enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do
121+ tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts
122+ rasts <- processGrp hsGrp
123+ imps <- toHie $ filter (not . ideclImplicit . unLoc) imports
124+ exps <- toHie $ fmap (map $ IEC Export . fst) exports
125+ let spanFile children = case children of
126+ [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)
127+ _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)
128+ (realSrcSpanEnd $ nodeSpan $ last children)
129+
130+ modulify xs =
131+ Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs
132+
133+ asts = HieASTs
134+ $ resolveTyVarScopes
135+ $ M.map (modulify . mergeSortAsts)
136+ $ M.fromListWith (++)
137+ $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
138+
139+ flat_asts = concat
140+ [ tasts
141+ , rasts
142+ , imps
143+ , exps
144+ ]
145+ return asts
146+ where
147+ processGrp grp = concatM
148+ [ toHie $ fmap (RS ModuleScope ) hs_valds grp
149+ , toHie $ hs_splcds grp
150+ , toHie $ hs_tyclds grp
151+ , toHie $ hs_derivds grp
152+ , toHie $ hs_fixds grp
153+ , toHie $ hs_defds grp
154+ , toHie $ hs_fords grp
155+ , toHie $ hs_warnds grp
156+ , toHie $ hs_annds grp
157+ , toHie $ hs_ruleds grp
158+ ]
159+
160+getRealSpan :: SrcSpan -> Maybe Span
161+getRealSpan (RealSrcSpan sp) = Just sp
162+getRealSpan _ = Nothing
163+
164+grhss_span :: GRHSs p body -> SrcSpan
165+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)
166+grhss_span (XGRHSs _) = error "XGRHS has no span"
167+
168+bindingsOnly :: [Context Name] -> [HieAST a]
169+bindingsOnly [] = []
170+bindingsOnly (C c n : xs) = case nameSrcSpan n of
171+ RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs
172+ where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
173+ info = mempty{identInfo = S.singleton c}
174+ _ -> bindingsOnly xs
175+
176+concatM :: Monad m => [m [a]] -> m [a]
177+concatM xs = concat <$> sequence xs
178+
179+{- Note [Capturing Scopes and other non local information]
180+toHie is a local tranformation, but scopes of bindings cannot be known locally,
181+hence we have to push the relevant info down into the binding nodes.
182+We use the following types (*Context and *Scoped) to wrap things and
183+carry the required info
184+(Maybe Span) always carries the span of the entire binding, including rhs
185+-}
186+data Context a = C ContextInfo a -- Used for names and bindings
187+
188+data RContext a = RC RecFieldContext a
189+data RFContext a = RFC RecFieldContext (Maybe Span) a
190+-- ^ context for record fields
191+
192+data IEContext a = IEC IEType a
193+-- ^ context for imports/exports
194+
195+data BindContext a = BC BindType Scope a
196+-- ^ context for imports/exports
197+
198+data PatSynFieldContext a = PSC (Maybe Span) a
199+-- ^ context for pattern synonym fields.
200+
201+data SigContext a = SC SigInfo a
202+-- ^ context for type signatures
203+
204+data SigInfo = SI SigType (Maybe Span)
205+
206+data SigType = BindSig | ClassSig | InstSig
207+
208+data RScoped a = RS Scope a
209+-- ^ Scope spans over everything to the right of a, (mostly) not
210+-- including a itself
211+-- (Includes a in a few special cases like recursive do bindings) or
212+-- let/where bindings
213+
214+-- | Pattern scope
215+data PScoped a = PS (Maybe Span)
216+ Scope -- ^ use site of the pattern
217+ Scope -- ^ pattern to the right of a, not including a
218+ a
219+ deriving (Typeable, Data) -- Pattern Scope
220+
221+{- Note [TyVar Scopes]
222+Due to -XScopedTypeVariables, type variables can be in scope quite far from
223+their original binding. We resolve the scope of these type variables
224+in a separate pass
225+-}
226+data TScoped a = TS TyVarScope a -- TyVarScope
227+
228+data TVScoped a = TVS TyVarScope Scope a -- TyVarScope
229+-- ^ First scope remains constant
230+-- Second scope is used to build up the scope of a tyvar over
231+-- things to its right, ala RScoped
232+
233+-- | Each element scopes over the elements to the right
234+listScopes :: Scope -> [Located a] -> [RScoped (Located a)]
235+listScopes _ [] = []
236+listScopes rhsScope [pat] = [RS rhsScope pat]
237+listScopes rhsScope (pat : pats) = RS sc pat : pats'
238+ where
239+ pats'@((RS scope p):_) = listScopes rhsScope pats
240+ sc = combineScopes scope $ mkScope $ getLoc p
241+
242+-- | 'listScopes' specialised to 'PScoped' things
243+patScopes
244+ :: Maybe Span
245+ -> Scope
246+ -> Scope
247+ -> [LPat (GhcPass p)]
248+ -> [PScoped (LPat (GhcPass p))]
249+patScopes rsp useScope patScope xs =
250+ map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $
251+ listScopes patScope (map dL xs)
252+
253+-- | 'listScopes' specialised to 'TVScoped' things
254+tvScopes
255+ :: TyVarScope
256+ -> Scope
257+ -> [LHsTyVarBndr a]
258+ -> [TVScoped (LHsTyVarBndr a)]
259+tvScopes tvScope rhsScope xs =
260+ map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs
261+
262+{- Note [Scoping Rules for SigPat]
263+Explicitly quantified variables in pattern type signatures are not
264+brought into scope in the rhs, but implicitly quantified variables
265+are (HsWC and HsIB).
266+This is unlike other signatures, where explicitly quantified variables
267+are brought into the RHS Scope
268+For example
269+foo :: forall a. ...;
270+foo = ... -- a is in scope here
271+
272+bar (x :: forall a. a -> a) = ... -- a is not in scope here
273+-- ^ a is in scope here (pattern body)
274+
275+bax (x :: a) = ... -- a is in scope here
276+Because of HsWC and HsIB pass on their scope to their children
277+we must wrap the LHsType in pattern signatures in a
278+Shielded explictly, so that the HsWC/HsIB scope is not passed
279+on the the LHsType
280+-}
281+
282+data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead
283+
284+type family ProtectedSig a where
285+ ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs
286+ GhcRn
287+ (Shielded (LHsType GhcRn)))
288+ ProtectedSig GhcTc = NoExt
289+
290+class ProtectSig a where
291+ protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a
292+
293+instance (HasLoc a) => HasLoc (Shielded a) where
294+ loc (SH _ a) = loc a
295+
296+instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where
297+ toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)
298+
299+instance ProtectSig GhcTc where
300+ protectSig _ _ = NoExt
301+
302+instance ProtectSig GhcRn where
303+ protectSig sc (HsWC a (HsIB b sig)) =
304+ HsWC a (HsIB b (SH sc sig))
305+ protectSig _ _ = error "protectSig not given HsWC (HsIB)"
306+
307+class HasLoc a where
308+ -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can
309+ -- know what their implicit bindings are scoping over
310+ loc :: a -> SrcSpan
311+
312+instance HasLoc thing => HasLoc (TScoped thing) where
313+ loc (TS _ a) = loc a
314+
315+instance HasLoc thing => HasLoc (PScoped thing) where
316+ loc (PS _ _ _ a) = loc a
317+
318+instance HasLoc (LHsQTyVars GhcRn) where
319+ loc (HsQTvs _ vs) = loc vs
320+ loc _ = noSrcSpan
321+
322+instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where
323+ loc (HsIB _ a) = loc a
324+ loc _ = noSrcSpan
325+
326+instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where
327+ loc (HsWC _ a) = loc a
328+ loc _ = noSrcSpan
329+
330+instance HasLoc (Located a) where
331+ loc (L l _) = l
332+
333+instance HasLoc a => HasLoc [a] where
334+ loc [] = noSrcSpan
335+ loc xs = foldl1' combineSrcSpans $ map loc xs
336+
337+instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where
338+ loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]
339+ loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
340+ [loc a, loc tvs, loc b, loc c]
341+ loc _ = noSrcSpan
342+instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
343+ loc (HsValArg tm) = loc tm
344+ loc (HsTypeArg _ ty) = loc ty
345+ loc (HsArgPar sp) = sp
346+
347+instance HasLoc (HsDataDefn GhcRn) where
348+ loc def@(HsDataDefn{}) = loc $ dd_cons def
349+ -- Only used for data family instances, so we only need rhs
350+ -- Most probably the rest will be unhelpful anyway
351+ loc _ = noSrcSpan
352+
353+instance HasLoc (Pat (GhcPass a)) where
354+ loc (dL -> L l _) = l
355+
356+-- | The main worker class
357+class ToHie a where
358+ toHie :: a -> HieM [HieAST Type]
359+
360+-- | Used to collect type info
361+class Data a => HasType a where
362+ getTypeNode :: a -> HieM [HieAST Type]
363+
364+instance (ToHie a) => ToHie [a] where
365+ toHie = concatMapM toHie
366+
367+instance (ToHie a) => ToHie (Bag a) where
368+ toHie = toHie . bagToList
369+
370+instance (ToHie a) => ToHie (Maybe a) where
371+ toHie = maybe (pure []) toHie
372+
373+instance ToHie (Context (Located NoExt)) where
374+ toHie _ = pure []
375+
376+instance ToHie (TScoped NoExt) where
377+ toHie _ = pure []
378+
379+instance ToHie (IEContext (Located ModuleName)) where
380+ toHie (IEC c (L (RealSrcSpan span) mname)) =
381+ pure $ [Node (NodeInfo S.empty [] idents) span []]
382+ where details = mempty{identInfo = S.singleton (IEThing c)}
383+ idents = M.singleton (Left mname) details
384+ toHie _ = pure []
385+
386+instance ToHie (Context (Located Var)) where
387+ toHie c = case c of
388+ C context (L (RealSrcSpan span) name')
389+ -> do
390+ m <- asks name_remapping
391+ let name = M.findWithDefault name' (varName name') m
392+ pure
393+ [Node
394+ (NodeInfo S.empty [] $
395+ M.singleton (Right $ varName name)
396+ (IdentifierDetails (Just $ varType name')
397+ (S.singleton context)))
398+ span
399+ []]
400+ _ -> pure []
401+
402+instance ToHie (Context (Located Name)) where
403+ toHie c = case c of
404+ C context (L (RealSrcSpan span) name') -> do
405+ m <- asks name_remapping
406+ let name = case M.lookup name' m of
407+ Just var -> varName var
408+ Nothing -> name'
409+ pure
410+ [Node
411+ (NodeInfo S.empty [] $
412+ M.singleton (Right name)
413+ (IdentifierDetails Nothing
414+ (S.singleton context)))
415+ span
416+ []]
417+ _ -> pure []
418+
419+-- | Dummy instances - never called
420+instance ToHie (TScoped (LHsSigWcType GhcTc)) where
421+ toHie _ = pure []
422+instance ToHie (TScoped (LHsWcType GhcTc)) where
423+ toHie _ = pure []
424+instance ToHie (SigContext (LSig GhcTc)) where
425+ toHie _ = pure []
426+instance ToHie (TScoped Type) where
427+ toHie _ = pure []
428+
429+instance HasType (LHsBind GhcRn) where
430+ getTypeNode (L spn bind) = makeNode bind spn
431+
432+instance HasType (LHsBind GhcTc) where
433+ getTypeNode (L spn bind) = case bind of
434+ FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)
435+ _ -> makeNode bind spn
436+
437+instance HasType (LPat GhcRn) where
438+ getTypeNode (dL -> L spn pat) = makeNode pat spn
439+
440+instance HasType (LPat GhcTc) where
441+ getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)
442+
443+instance HasType (LHsExpr GhcRn) where
444+ getTypeNode (L spn e) = makeNode e spn
445+
446+-- | This instance tries to construct 'HieAST' nodes which include the type of
447+-- the expression. It is not yet possible to do this efficiently for all
448+-- expression forms, so we skip filling in the type for those inputs.
449+--
450+-- 'HsApp', for example, doesn't have any type information available directly on
451+-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then
452+-- query the type of that. Yet both the desugaring call and the type query both
453+-- involve recursive calls to the function and argument! This is particularly
454+-- problematic when you realize that the HIE traversal will eventually visit
455+-- those nodes too and ask for their types again.
456+--
457+-- Since the above is quite costly, we just skip cases where computing the
458+-- expression's type is going to be expensive.
459+--
460+-- See #16233
461+instance HasType (LHsExpr GhcTc) where
462+ getTypeNode e@(L spn e') = lift $
463+ -- Some expression forms have their type immediately available
464+ let tyOpt = case e' of
465+ HsLit _ l -> Just (hsLitType l)
466+ HsOverLit _ o -> Just (overLitType o)
467+
468+ HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
469+ HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
470+ HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)
471+
472+ ExplicitList ty _ _ -> Just (mkListTy ty)
473+ ExplicitSum ty _ _ _ -> Just (mkSumTy ty)
474+ HsDo ty _ _ -> Just ty
475+ HsMultiIf ty _ -> Just ty
476+
477+ _ -> Nothing
478+
479+ in
480+ case tyOpt of
481+ _ | skipDesugaring e' -> fallback
482+ | otherwise -> do
483+ hs_env <- Hsc $ \e w -> return (e,w)
484+ (_,mbe) <- liftIO $ deSugarExpr hs_env e
485+ maybe fallback (makeTypeNode e' spn . exprType) mbe
486+ where
487+ fallback = makeNode e' spn
488+
489+ matchGroupType :: MatchGroupTc -> Type
490+ matchGroupType (MatchGroupTc args res) = mkFunTys args res
491+
492+ -- | Skip desugaring of these expressions for performance reasons.
493+ --
494+ -- See impact on Haddock output (esp. missing type annotations or links)
495+ -- before marking more things here as 'False'. See impact on Haddock
496+ -- performance before marking more things as 'True'.
497+ skipDesugaring :: HsExpr a -> Bool
498+ skipDesugaring e = case e of
499+ HsVar{} -> False
500+ HsUnboundVar{} -> False
501+ HsConLikeOut{} -> False
502+ HsRecFld{} -> False
503+ HsOverLabel{} -> False
504+ HsIPVar{} -> False
505+ HsWrap{} -> False
506+ _ -> True
507+
508+instance ( ToHie (Context (Located (IdP a)))
509+ , ToHie (MatchGroup a (LHsExpr a))
510+ , ToHie (PScoped (LPat a))
511+ , ToHie (GRHSs a (LHsExpr a))
512+ , ToHie (LHsExpr a)
513+ , ToHie (Located (PatSynBind a a))
514+ , HasType (LHsBind a)
515+ , ModifyState (IdP a)
516+ , Data (HsBind a)
517+ ) => ToHie (BindContext (LHsBind a)) where
518+ toHie (BC context scope b@(L span bind)) =
519+ concatM $ getTypeNode b : case bind of
520+ FunBind{fun_id = name, fun_matches = matches} ->
521+ [ toHie $ C (ValBind context scope $ getRealSpan span) name
522+ , toHie matches
523+ ]
524+ PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
525+ [ toHie $ PS (getRealSpan span) scope NoScope lhs
526+ , toHie rhs
527+ ]
528+ VarBind{var_rhs = expr} ->
529+ [ toHie expr
530+ ]
531+ AbsBinds{abs_exports = xs, abs_binds = binds} ->
532+ [ local (modifyState xs) $ -- Note [Name Remapping]
533+ toHie $ fmap (BC context scope) binds
534+ ]
535+ PatSynBind _ psb ->
536+ [ toHie $ L span psb -- PatSynBinds only occur at the top level
537+ ]
538+ XHsBindsLR _ -> []
539+
540+instance ( ToHie (LMatch a body)
541+ ) => ToHie (MatchGroup a body) where
542+ toHie mg = concatM $ case mg of
543+ MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->
544+ [ pure $ locOnly span
545+ , toHie alts
546+ ]
547+ MG{} -> []
548+ XMatchGroup _ -> []
549+
550+instance ( ToHie (Context (Located (IdP a)))
551+ , ToHie (PScoped (LPat a))
552+ , ToHie (HsPatSynDir a)
553+ ) => ToHie (Located (PatSynBind a a)) where
554+ toHie (L sp psb) = concatM $ case psb of
555+ PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->
556+ [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var
557+ , toHie $ toBind dets
558+ , toHie $ PS Nothing lhsScope NoScope pat
559+ , toHie dir
560+ ]
561+ where
562+ lhsScope = combineScopes varScope detScope
563+ varScope = mkLScope var
564+ detScope = case dets of
565+ (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args
566+ (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)
567+ (RecCon r) -> foldr go NoScope r
568+ go (RecordPatSynField a b) c = combineScopes c
569+ $ combineScopes (mkLScope a) (mkLScope b)
570+ detSpan = case detScope of
571+ LocalScope a -> Just a
572+ _ -> Nothing
573+ toBind (PrefixCon args) = PrefixCon $ map (C Use) args
574+ toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
575+ toBind (RecCon r) = RecCon $ map (PSC detSpan) r
576+ XPatSynBind _ -> []
577+
578+instance ( ToHie (MatchGroup a (LHsExpr a))
579+ ) => ToHie (HsPatSynDir a) where
580+ toHie dir = case dir of
581+ ExplicitBidirectional mg -> toHie mg
582+ _ -> pure []
583+
584+instance ( a ~ GhcPass p
585+ , ToHie body
586+ , ToHie (HsMatchContext (NameOrRdrName (IdP a)))
587+ , ToHie (PScoped (LPat a))
588+ , ToHie (GRHSs a body)
589+ , Data (Match a body)
590+ ) => ToHie (LMatch (GhcPass p) body) where
591+ toHie (L span m ) = concatM $ makeNode m span : case m of
592+ Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->
593+ [ toHie mctx
594+ , let rhsScope = mkScope $ grhss_span grhss
595+ in toHie $ patScopes Nothing rhsScope NoScope pats
596+ , toHie grhss
597+ ]
598+ XMatch _ -> []
599+
600+instance ( ToHie (Context (Located a))
601+ ) => ToHie (HsMatchContext a) where
602+ toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name
603+ toHie (StmtCtxt a) = toHie a
604+ toHie _ = pure []
605+
606+instance ( ToHie (HsMatchContext a)
607+ ) => ToHie (HsStmtContext a) where
608+ toHie (PatGuard a) = toHie a
609+ toHie (ParStmtCtxt a) = toHie a
610+ toHie (TransStmtCtxt a) = toHie a
611+ toHie _ = pure []
612+
613+instance ( a ~ GhcPass p
614+ , ToHie (Context (Located (IdP a)))
615+ , ToHie (RContext (HsRecFields a (PScoped (LPat a))))
616+ , ToHie (LHsExpr a)
617+ , ToHie (TScoped (LHsSigWcType a))
618+ , ProtectSig a
619+ , ToHie (TScoped (ProtectedSig a))
620+ , HasType (LPat a)
621+ , Data (HsSplice a)
622+ ) => ToHie (PScoped (LPat (GhcPass p))) where
623+ toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =
624+ concatM $ getTypeNode lpat : case opat of
625+ WildPat _ ->
626+ []
627+ VarPat _ lname ->
628+ [ toHie $ C (PatternBind scope pscope rsp) lname
629+ ]
630+ LazyPat _ p ->
631+ [ toHie $ PS rsp scope pscope p
632+ ]
633+ AsPat _ lname pat ->
634+ [ toHie $ C (PatternBind scope
635+ (combineScopes (mkLScope (dL pat)) pscope)
636+ rsp)
637+ lname
638+ , toHie $ PS rsp scope pscope pat
639+ ]
640+ ParPat _ pat ->
641+ [ toHie $ PS rsp scope pscope pat
642+ ]
643+ BangPat _ pat ->
644+ [ toHie $ PS rsp scope pscope pat
645+ ]
646+ ListPat _ pats ->
647+ [ toHie $ patScopes rsp scope pscope pats
648+ ]
649+ TuplePat _ pats _ ->
650+ [ toHie $ patScopes rsp scope pscope pats
651+ ]
652+ SumPat _ pat _ _ ->
653+ [ toHie $ PS rsp scope pscope pat
654+ ]
655+ ConPatIn c dets ->
656+ [ toHie $ C Use c
657+ , toHie $ contextify dets
658+ ]
659+ ConPatOut {pat_con = con, pat_args = dets}->
660+ [ toHie $ C Use $ fmap conLikeName con
661+ , toHie $ contextify dets
662+ ]
663+ ViewPat _ expr pat ->
664+ [ toHie expr
665+ , toHie $ PS rsp scope pscope pat
666+ ]
667+ SplicePat _ sp ->
668+ [ toHie $ L ospan sp
669+ ]
670+ LitPat _ _ ->
671+ []
672+ NPat _ _ _ _ ->
673+ []
674+ NPlusKPat _ n _ _ _ _ ->
675+ [ toHie $ C (PatternBind scope pscope rsp) n
676+ ]
677+ SigPat _ pat sig ->
678+ [ toHie $ PS rsp scope pscope pat
679+ , let cscope = mkLScope (dL pat) in
680+ toHie $ TS (ResolvedScopes [cscope, scope, pscope])
681+ (protectSig @a cscope sig)
682+ -- See Note [Scoping Rules for SigPat]
683+ ]
684+ CoPat _ _ _ _ ->
685+ []
686+ XPat _ -> []
687+ where
688+ contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
689+ contextify (InfixCon a b) = InfixCon a' b'
690+ where [a', b'] = patScopes rsp scope pscope [a,b]
691+ contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r
692+ contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a
693+ where
694+ go (RS fscope (L spn (HsRecField lbl pat pun))) =
695+ L spn $ HsRecField lbl (PS rsp scope fscope pat) pun
696+ scoped_fds = listScopes pscope fds
697+
698+instance ( ToHie body
699+ , ToHie (LGRHS a body)
700+ , ToHie (RScoped (LHsLocalBinds a))
701+ ) => ToHie (GRHSs a body) where
702+ toHie grhs = concatM $ case grhs of
703+ GRHSs _ grhss binds ->
704+ [ toHie grhss
705+ , toHie $ RS (mkScope $ grhss_span grhs) binds
706+ ]
707+ XGRHSs _ -> []
708+
709+instance ( ToHie (Located body)
710+ , ToHie (RScoped (GuardLStmt a))
711+ , Data (GRHS a (Located body))
712+ ) => ToHie (LGRHS a (Located body)) where
713+ toHie (L span g) = concatM $ makeNode g span : case g of
714+ GRHS _ guards body ->
715+ [ toHie $ listScopes (mkLScope body) guards
716+ , toHie body
717+ ]
718+ XGRHS _ -> []
719+
720+instance ( a ~ GhcPass p
721+ , ToHie (Context (Located (IdP a)))
722+ , HasType (LHsExpr a)
723+ , ToHie (PScoped (LPat a))
724+ , ToHie (MatchGroup a (LHsExpr a))
725+ , ToHie (LGRHS a (LHsExpr a))
726+ , ToHie (RContext (HsRecordBinds a))
727+ , ToHie (RFContext (Located (AmbiguousFieldOcc a)))
728+ , ToHie (ArithSeqInfo a)
729+ , ToHie (LHsCmdTop a)
730+ , ToHie (RScoped (GuardLStmt a))
731+ , ToHie (RScoped (LHsLocalBinds a))
732+ , ToHie (TScoped (LHsWcType (NoGhcTc a)))
733+ , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))
734+ , Data (HsExpr a)
735+ , Data (HsSplice a)
736+ , Data (HsTupArg a)
737+ , Data (AmbiguousFieldOcc a)
738+ ) => ToHie (LHsExpr (GhcPass p)) where
739+ toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
740+ HsVar _ (L _ var) ->
741+ [ toHie $ C Use (L mspan var)
742+ -- Patch up var location since typechecker removes it
743+ ]
744+ HsUnboundVar _ _ ->
745+ []
746+ HsConLikeOut _ con ->
747+ [ toHie $ C Use $ L mspan $ conLikeName con
748+ ]
749+ HsRecFld _ fld ->
750+ [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)
751+ ]
752+ HsOverLabel _ _ _ -> []
753+ HsIPVar _ _ -> []
754+ HsOverLit _ _ -> []
755+ HsLit _ _ -> []
756+ HsLam _ mg ->
757+ [ toHie mg
758+ ]
759+ HsLamCase _ mg ->
760+ [ toHie mg
761+ ]
762+ HsApp _ a b ->
763+ [ toHie a
764+ , toHie b
765+ ]
766+ HsAppType _ expr sig ->
767+ [ toHie expr
768+ , toHie $ TS (ResolvedScopes []) sig
769+ ]
770+ OpApp _ a b c ->
771+ [ toHie a
772+ , toHie b
773+ , toHie c
774+ ]
775+ NegApp _ a _ ->
776+ [ toHie a
777+ ]
778+ HsPar _ a ->
779+ [ toHie a
780+ ]
781+ SectionL _ a b ->
782+ [ toHie a
783+ , toHie b
784+ ]
785+ SectionR _ a b ->
786+ [ toHie a
787+ , toHie b
788+ ]
789+ ExplicitTuple _ args _ ->
790+ [ toHie args
791+ ]
792+ ExplicitSum _ _ _ expr ->
793+ [ toHie expr
794+ ]
795+ HsCase _ expr matches ->
796+ [ toHie expr
797+ , toHie matches
798+ ]
799+ HsIf _ _ a b c ->
800+ [ toHie a
801+ , toHie b
802+ , toHie c
803+ ]
804+ HsMultiIf _ grhss ->
805+ [ toHie grhss
806+ ]
807+ HsLet _ binds expr ->
808+ [ toHie $ RS (mkLScope expr) binds
809+ , toHie expr
810+ ]
811+ HsDo _ _ (L ispan stmts) ->
812+ [ pure $ locOnly ispan
813+ , toHie $ listScopes NoScope stmts
814+ ]
815+ ExplicitList _ _ exprs ->
816+ [ toHie exprs
817+ ]
818+ RecordCon {rcon_con_name = name, rcon_flds = binds}->
819+ [ toHie $ C Use name
820+ , toHie $ RC RecFieldAssign $ binds
821+ ]
822+ RecordUpd {rupd_expr = expr, rupd_flds = upds}->
823+ [ toHie expr
824+ , toHie $ map (RC RecFieldAssign) upds
825+ ]
826+ ExprWithTySig _ expr sig ->
827+ [ toHie expr
828+ , toHie $ TS (ResolvedScopes [mkLScope expr]) sig
829+ ]
830+ ArithSeq _ _ info ->
831+ [ toHie info
832+ ]
833+ HsSCC _ _ _ expr ->
834+ [ toHie expr
835+ ]
836+ HsCoreAnn _ _ _ expr ->
837+ [ toHie expr
838+ ]
839+ HsProc _ pat cmdtop ->
840+ [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat
841+ , toHie cmdtop
842+ ]
843+ HsStatic _ expr ->
844+ [ toHie expr
845+ ]
846+ HsArrApp _ a b _ _ ->
847+ [ toHie a
848+ , toHie b
849+ ]
850+ HsArrForm _ expr _ cmds ->
851+ [ toHie expr
852+ , toHie cmds
853+ ]
854+ HsTick _ _ expr ->
855+ [ toHie expr
856+ ]
857+ HsBinTick _ _ _ expr ->
858+ [ toHie expr
859+ ]
860+ HsTickPragma _ _ _ _ expr ->
861+ [ toHie expr
862+ ]
863+ HsWrap _ _ a ->
864+ [ toHie $ L mspan a
865+ ]
866+ HsBracket _ b ->
867+ [ toHie b
868+ ]
869+ HsRnBracketOut _ b p ->
870+ [ toHie b
871+ , toHie p
872+ ]
873+ HsTcBracketOut _ b p ->
874+ [ toHie b
875+ , toHie p
876+ ]
877+ HsSpliceE _ x ->
878+ [ toHie $ L mspan x
879+ ]
880+ EWildPat _ -> []
881+ EAsPat _ a b ->
882+ [ toHie $ C Use a
883+ , toHie b
884+ ]
885+ EViewPat _ a b ->
886+ [ toHie a
887+ , toHie b
888+ ]
889+ ELazyPat _ a ->
890+ [ toHie a
891+ ]
892+ XExpr _ -> []
893+
894+instance ( a ~ GhcPass p
895+ , ToHie (LHsExpr a)
896+ , Data (HsTupArg a)
897+ ) => ToHie (LHsTupArg (GhcPass p)) where
898+ toHie (L span arg) = concatM $ makeNode arg span : case arg of
899+ Present _ expr ->
900+ [ toHie expr
901+ ]
902+ Missing _ -> []
903+ XTupArg _ -> []
904+
905+instance ( a ~ GhcPass p
906+ , ToHie (PScoped (LPat a))
907+ , ToHie (LHsExpr a)
908+ , ToHie (SigContext (LSig a))
909+ , ToHie (RScoped (LHsLocalBinds a))
910+ , ToHie (RScoped (ApplicativeArg a))
911+ , ToHie (Located body)
912+ , Data (StmtLR a a (Located body))
913+ , Data (StmtLR a a (Located (HsExpr a)))
914+ ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where
915+ toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of
916+ LastStmt _ body _ _ ->
917+ [ toHie body
918+ ]
919+ BindStmt _ pat body _ _ ->
920+ [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat
921+ , toHie body
922+ ]
923+ ApplicativeStmt _ stmts _ ->
924+ [ concatMapM (toHie . RS scope . snd) stmts
925+ ]
926+ BodyStmt _ body _ _ ->
927+ [ toHie body
928+ ]
929+ LetStmt _ binds ->
930+ [ toHie $ RS scope binds
931+ ]
932+ ParStmt _ parstmts _ _ ->
933+ [ concatMapM (\(ParStmtBlock _ stmts _ _) ->
934+ toHie $ listScopes NoScope stmts)
935+ parstmts
936+ ]
937+ TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->
938+ [ toHie $ listScopes scope stmts
939+ , toHie using
940+ , toHie by
941+ ]
942+ RecStmt {recS_stmts = stmts} ->
943+ [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts
944+ ]
945+ XStmtLR _ -> []
946+
947+instance ( ToHie (LHsExpr a)
948+ , ToHie (PScoped (LPat a))
949+ , ToHie (BindContext (LHsBind a))
950+ , ToHie (SigContext (LSig a))
951+ , ToHie (RScoped (HsValBindsLR a a))
952+ , Data (HsLocalBinds a)
953+ ) => ToHie (RScoped (LHsLocalBinds a)) where
954+ toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of
955+ EmptyLocalBinds _ -> []
956+ HsIPBinds _ _ -> []
957+ HsValBinds _ valBinds ->
958+ [ toHie $ RS (combineScopes scope $ mkScope sp)
959+ valBinds
960+ ]
961+ XHsLocalBindsLR _ -> []
962+
963+instance ( ToHie (BindContext (LHsBind a))
964+ , ToHie (SigContext (LSig a))
965+ , ToHie (RScoped (XXValBindsLR a a))
966+ ) => ToHie (RScoped (HsValBindsLR a a)) where
967+ toHie (RS sc v) = concatM $ case v of
968+ ValBinds _ binds sigs ->
969+ [ toHie $ fmap (BC RegularBind sc) binds
970+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
971+ ]
972+ XValBindsLR x -> [ toHie $ RS sc x ]
973+
974+instance ToHie (RScoped (NHsValBindsLR GhcTc)) where
975+ toHie (RS sc (NValBinds binds sigs)) = concatM $
976+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
977+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
978+ ]
979+instance ToHie (RScoped (NHsValBindsLR GhcRn)) where
980+ toHie (RS sc (NValBinds binds sigs)) = concatM $
981+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
982+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs
983+ ]
984+
985+instance ( ToHie (RContext (LHsRecField a arg))
986+ ) => ToHie (RContext (HsRecFields a arg)) where
987+ toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields
988+
989+instance ( ToHie (RFContext (Located label))
990+ , ToHie arg
991+ , HasLoc arg
992+ , Data label
993+ , Data arg
994+ ) => ToHie (RContext (LHsRecField' label arg)) where
995+ toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of
996+ HsRecField label expr _ ->
997+ [ toHie $ RFC c (getRealSpan $ loc expr) label
998+ , toHie expr
999+ ]
1000+
1001+removeDefSrcSpan :: Name -> Name
1002+removeDefSrcSpan n = setNameLoc n noSrcSpan
1003+
1004+instance ToHie (RFContext (LFieldOcc GhcRn)) where
1005+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of
1006+ FieldOcc name _ ->
1007+ [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)
1008+ ]
1009+ XFieldOcc _ -> []
1010+
1011+instance ToHie (RFContext (LFieldOcc GhcTc)) where
1012+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of
1013+ FieldOcc var _ ->
1014+ let var' = setVarName var (removeDefSrcSpan $ varName var)
1015+ in [ toHie $ C (RecField c rhs) (L nspan var')
1016+ ]
1017+ XFieldOcc _ -> []
1018+
1019+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
1020+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
1021+ Unambiguous name _ ->
1022+ [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name
1023+ ]
1024+ Ambiguous _name _ ->
1025+ [ ]
1026+ XAmbiguousFieldOcc _ -> []
1027+
1028+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
1029+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
1030+ Unambiguous var _ ->
1031+ let var' = setVarName var (removeDefSrcSpan $ varName var)
1032+ in [ toHie $ C (RecField c rhs) (L nspan var')
1033+ ]
1034+ Ambiguous var _ ->
1035+ let var' = setVarName var (removeDefSrcSpan $ varName var)
1036+ in [ toHie $ C (RecField c rhs) (L nspan var')
1037+ ]
1038+ XAmbiguousFieldOcc _ -> []
1039+
1040+instance ( a ~ GhcPass p
1041+ , ToHie (PScoped (LPat a))
1042+ , ToHie (BindContext (LHsBind a))
1043+ , ToHie (LHsExpr a)
1044+ , ToHie (SigContext (LSig a))
1045+ , ToHie (RScoped (HsValBindsLR a a))
1046+ , Data (StmtLR a a (Located (HsExpr a)))
1047+ , Data (HsLocalBinds a)
1048+ ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
1049+ toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM
1050+ [ toHie $ PS Nothing sc NoScope pat
1051+ , toHie expr
1052+ ]
1053+ toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM
1054+ [ toHie $ listScopes NoScope stmts
1055+ , toHie $ PS Nothing sc NoScope pat
1056+ ]
1057+ toHie (RS _ (XApplicativeArg _)) = pure []
1058+
1059+instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where
1060+ toHie (PrefixCon args) = toHie args
1061+ toHie (RecCon rec) = toHie rec
1062+ toHie (InfixCon a b) = concatM [ toHie a, toHie b]
1063+
1064+instance ( ToHie (LHsCmd a)
1065+ , Data (HsCmdTop a)
1066+ ) => ToHie (LHsCmdTop a) where
1067+ toHie (L span top) = concatM $ makeNode top span : case top of
1068+ HsCmdTop _ cmd ->
1069+ [ toHie cmd
1070+ ]
1071+ XCmdTop _ -> []
1072+
1073+instance ( a ~ GhcPass p
1074+ , ToHie (PScoped (LPat a))
1075+ , ToHie (BindContext (LHsBind a))
1076+ , ToHie (LHsExpr a)
1077+ , ToHie (MatchGroup a (LHsCmd a))
1078+ , ToHie (SigContext (LSig a))
1079+ , ToHie (RScoped (HsValBindsLR a a))
1080+ , Data (HsCmd a)
1081+ , Data (HsCmdTop a)
1082+ , Data (StmtLR a a (Located (HsCmd a)))
1083+ , Data (HsLocalBinds a)
1084+ , Data (StmtLR a a (Located (HsExpr a)))
1085+ ) => ToHie (LHsCmd (GhcPass p)) where
1086+ toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of
1087+ HsCmdArrApp _ a b _ _ ->
1088+ [ toHie a
1089+ , toHie b
1090+ ]
1091+ HsCmdArrForm _ a _ _ cmdtops ->
1092+ [ toHie a
1093+ , toHie cmdtops
1094+ ]
1095+ HsCmdApp _ a b ->
1096+ [ toHie a
1097+ , toHie b
1098+ ]
1099+ HsCmdLam _ mg ->
1100+ [ toHie mg
1101+ ]
1102+ HsCmdPar _ a ->
1103+ [ toHie a
1104+ ]
1105+ HsCmdCase _ expr alts ->
1106+ [ toHie expr
1107+ , toHie alts
1108+ ]
1109+ HsCmdIf _ _ a b c ->
1110+ [ toHie a
1111+ , toHie b
1112+ , toHie c
1113+ ]
1114+ HsCmdLet _ binds cmd' ->
1115+ [ toHie $ RS (mkLScope cmd') binds
1116+ , toHie cmd'
1117+ ]
1118+ HsCmdDo _ (L ispan stmts) ->
1119+ [ pure $ locOnly ispan
1120+ , toHie $ listScopes NoScope stmts
1121+ ]
1122+ HsCmdWrap _ _ _ -> []
1123+ XCmd _ -> []
1124+
1125+instance ToHie (TyClGroup GhcRn) where
1126+ toHie (TyClGroup _ classes roles instances) = concatM
1127+ [ toHie classes
1128+ , toHie roles
1129+ , toHie instances
1130+ ]
1131+ toHie (XTyClGroup _) = pure []
1132+
1133+instance ToHie (LTyClDecl GhcRn) where
1134+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1135+ FamDecl {tcdFam = fdecl} ->
1136+ [ toHie (L span fdecl)
1137+ ]
1138+ SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->
1139+ [ toHie $ C (Decl SynDec $ getRealSpan span) name
1140+ , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars
1141+ , toHie typ
1142+ ]
1143+ DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->
1144+ [ toHie $ C (Decl DataDec $ getRealSpan span) name
1145+ , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars
1146+ , toHie defn
1147+ ]
1148+ where
1149+ quant_scope = mkLScope $ dd_ctxt defn
1150+ rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc
1151+ sig_sc = maybe NoScope mkLScope $ dd_kindSig defn
1152+ con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn
1153+ deriv_sc = mkLScope $ dd_derivs defn
1154+ ClassDecl { tcdCtxt = context
1155+ , tcdLName = name
1156+ , tcdTyVars = vars
1157+ , tcdFDs = deps
1158+ , tcdSigs = sigs
1159+ , tcdMeths = meths
1160+ , tcdATs = typs
1161+ , tcdATDefs = deftyps
1162+ } ->
1163+ [ toHie $ C (Decl ClassDec $ getRealSpan span) name
1164+ , toHie context
1165+ , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars
1166+ , toHie deps
1167+ , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs
1168+ , toHie $ fmap (BC InstanceBind ModuleScope) meths
1169+ , toHie typs
1170+ , concatMapM (pure . locOnly . getLoc) deftyps
1171+ , toHie $ map (go . unLoc) deftyps
1172+ ]
1173+ where
1174+ context_scope = mkLScope context
1175+ rhs_scope = foldl1' combineScopes $ map mkScope
1176+ [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
1177+
1178+ go :: TyFamDefltEqn GhcRn
1179+ -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)
1180+ go (FamEqn a var bndrs pat b rhs) =
1181+ FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs
1182+ go (XFamEqn NoExt) = XFamEqn NoExt
1183+ XTyClDecl _ -> []
1184+
1185+instance ToHie (LFamilyDecl GhcRn) where
1186+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1187+ FamilyDecl _ info name vars _ sig inj ->
1188+ [ toHie $ C (Decl FamDec $ getRealSpan span) name
1189+ , toHie $ TS (ResolvedScopes [rhsSpan]) vars
1190+ , toHie info
1191+ , toHie $ RS injSpan sig
1192+ , toHie inj
1193+ ]
1194+ where
1195+ rhsSpan = sigSpan `combineScopes` injSpan
1196+ sigSpan = mkScope $ getLoc sig
1197+ injSpan = maybe NoScope (mkScope . getLoc) inj
1198+ XFamilyDecl _ -> []
1199+
1200+instance ToHie (FamilyInfo GhcRn) where
1201+ toHie (ClosedTypeFamily (Just eqns)) = concatM $
1202+ [ concatMapM (pure . locOnly . getLoc) eqns
1203+ , toHie $ map go eqns
1204+ ]
1205+ where
1206+ go (L l ib) = TS (ResolvedScopes [mkScope l]) ib
1207+ toHie _ = pure []
1208+
1209+instance ToHie (RScoped (LFamilyResultSig GhcRn)) where
1210+ toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of
1211+ NoSig _ ->
1212+ []
1213+ KindSig _ k ->
1214+ [ toHie k
1215+ ]
1216+ TyVarSig _ bndr ->
1217+ [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr
1218+ ]
1219+ XFamilyResultSig _ -> []
1220+
1221+instance ToHie (Located (FunDep (Located Name))) where
1222+ toHie (L span fd@(lhs, rhs)) = concatM $
1223+ [ makeNode fd span
1224+ , toHie $ map (C Use) lhs
1225+ , toHie $ map (C Use) rhs
1226+ ]
1227+
1228+instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs)
1229+ => ToHie (TScoped (FamEqn GhcRn pats rhs)) where
1230+ toHie (TS _ f) = toHie f
1231+
1232+instance ( ToHie pats
1233+ , ToHie rhs
1234+ , HasLoc pats
1235+ , HasLoc rhs
1236+ ) => ToHie (FamEqn GhcRn pats rhs) where
1237+ toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $
1238+ [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var
1239+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
1240+ , toHie pats
1241+ , toHie rhs
1242+ ]
1243+ where scope = combineScopes patsScope rhsScope
1244+ patsScope = mkScope (loc pats)
1245+ rhsScope = mkScope (loc rhs)
1246+ toHie (XFamEqn _) = pure []
1247+
1248+instance ToHie (LInjectivityAnn GhcRn) where
1249+ toHie (L span ann) = concatM $ makeNode ann span : case ann of
1250+ InjectivityAnn lhs rhs ->
1251+ [ toHie $ C Use lhs
1252+ , toHie $ map (C Use) rhs
1253+ ]
1254+
1255+instance ToHie (HsDataDefn GhcRn) where
1256+ toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM
1257+ [ toHie ctx
1258+ , toHie mkind
1259+ , toHie cons
1260+ , toHie derivs
1261+ ]
1262+ toHie (XHsDataDefn _) = pure []
1263+
1264+instance ToHie (HsDeriving GhcRn) where
1265+ toHie (L span clauses) = concatM
1266+ [ pure $ locOnly span
1267+ , toHie clauses
1268+ ]
1269+
1270+instance ToHie (LHsDerivingClause GhcRn) where
1271+ toHie (L span cl) = concatM $ makeNode cl span : case cl of
1272+ HsDerivingClause _ strat (L ispan tys) ->
1273+ [ toHie strat
1274+ , pure $ locOnly ispan
1275+ , toHie $ map (TS (ResolvedScopes [])) tys
1276+ ]
1277+ XHsDerivingClause _ -> []
1278+
1279+instance ToHie (Located (DerivStrategy GhcRn)) where
1280+ toHie (L span strat) = concatM $ makeNode strat span : case strat of
1281+ StockStrategy -> []
1282+ AnyclassStrategy -> []
1283+ NewtypeStrategy -> []
1284+ ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]
1285+
1286+instance ToHie (Located OverlapMode) where
1287+ toHie (L span _) = pure $ locOnly span
1288+
1289+instance ToHie (LConDecl GhcRn) where
1290+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1291+ ConDeclGADT { con_names = names, con_qvars = qvars
1292+ , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
1293+ [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names
1294+ , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars
1295+ , toHie ctx
1296+ , toHie args
1297+ , toHie typ
1298+ ]
1299+ where
1300+ rhsScope = combineScopes argsScope tyScope
1301+ ctxScope = maybe NoScope mkLScope ctx
1302+ argsScope = condecl_scope args
1303+ tyScope = mkLScope typ
1304+ ConDeclH98 { con_name = name, con_ex_tvs = qvars
1305+ , con_mb_cxt = ctx, con_args = dets } ->
1306+ [ toHie $ C (Decl ConDec $ getRealSpan span) name
1307+ , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars
1308+ , toHie ctx
1309+ , toHie dets
1310+ ]
1311+ where
1312+ rhsScope = combineScopes ctxScope argsScope
1313+ ctxScope = maybe NoScope mkLScope ctx
1314+ argsScope = condecl_scope dets
1315+ XConDecl _ -> []
1316+ where condecl_scope args = case args of
1317+ PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs
1318+ InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)
1319+ RecCon x -> mkLScope x
1320+
1321+instance ToHie (Located [LConDeclField GhcRn]) where
1322+ toHie (L span decls) = concatM $
1323+ [ pure $ locOnly span
1324+ , toHie decls
1325+ ]
1326+
1327+instance ( HasLoc thing
1328+ , ToHie (TScoped thing)
1329+ ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where
1330+ toHie (TS sc (HsIB ibrn a)) = concatM $
1331+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
1332+ , toHie $ TS sc a
1333+ ]
1334+ where span = loc a
1335+ toHie (TS _ (XHsImplicitBndrs _)) = pure []
1336+
1337+instance ( HasLoc thing
1338+ , ToHie (TScoped thing)
1339+ ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where
1340+ toHie (TS sc (HsWC names a)) = concatM $
1341+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
1342+ , toHie $ TS sc a
1343+ ]
1344+ where span = loc a
1345+ toHie (TS _ (XHsWildCardBndrs _)) = pure []
1346+
1347+instance ToHie (SigContext (LSig GhcRn)) where
1348+ toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of
1349+ TypeSig _ names typ ->
1350+ [ toHie $ map (C TyDecl) names
1351+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1352+ ]
1353+ PatSynSig _ names typ ->
1354+ [ toHie $ map (C TyDecl) names
1355+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
1356+ ]
1357+ ClassOpSig _ _ names typ ->
1358+ [ case styp of
1359+ ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names
1360+ _ -> toHie $ map (C $ TyDecl) names
1361+ , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
1362+ ]
1363+ IdSig _ _ -> []
1364+ FixSig _ fsig ->
1365+ [ toHie $ L sp fsig
1366+ ]
1367+ InlineSig _ name _ ->
1368+ [ toHie $ (C Use) name
1369+ ]
1370+ SpecSig _ name typs _ ->
1371+ [ toHie $ (C Use) name
1372+ , toHie $ map (TS (ResolvedScopes [])) typs
1373+ ]
1374+ SpecInstSig _ _ typ ->
1375+ [ toHie $ TS (ResolvedScopes []) typ
1376+ ]
1377+ MinimalSig _ _ form ->
1378+ [ toHie form
1379+ ]
1380+ SCCFunSig _ _ name mtxt ->
1381+ [ toHie $ (C Use) name
1382+ , pure $ maybe [] (locOnly . getLoc) mtxt
1383+ ]
1384+ CompleteMatchSig _ _ (L ispan names) typ ->
1385+ [ pure $ locOnly ispan
1386+ , toHie $ map (C Use) names
1387+ , toHie $ fmap (C Use) typ
1388+ ]
1389+ XSig _ -> []
1390+
1391+instance ToHie (LHsType GhcRn) where
1392+ toHie x = toHie $ TS (ResolvedScopes []) x
1393+
1394+instance ToHie (TScoped (LHsType GhcRn)) where
1395+ toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of
1396+ HsForAllTy _ bndrs body ->
1397+ [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs
1398+ , toHie body
1399+ ]
1400+ HsQualTy _ ctx body ->
1401+ [ toHie ctx
1402+ , toHie body
1403+ ]
1404+ HsTyVar _ _ var ->
1405+ [ toHie $ C Use var
1406+ ]
1407+ HsAppTy _ a b ->
1408+ [ toHie a
1409+ , toHie b
1410+ ]
1411+ HsAppKindTy _ ty ki ->
1412+ [ toHie ty
1413+ , toHie $ TS (ResolvedScopes []) ki
1414+ ]
1415+ HsFunTy _ a b ->
1416+ [ toHie a
1417+ , toHie b
1418+ ]
1419+ HsListTy _ a ->
1420+ [ toHie a
1421+ ]
1422+ HsTupleTy _ _ tys ->
1423+ [ toHie tys
1424+ ]
1425+ HsSumTy _ tys ->
1426+ [ toHie tys
1427+ ]
1428+ HsOpTy _ a op b ->
1429+ [ toHie a
1430+ , toHie $ C Use op
1431+ , toHie b
1432+ ]
1433+ HsParTy _ a ->
1434+ [ toHie a
1435+ ]
1436+ HsIParamTy _ ip ty ->
1437+ [ toHie ip
1438+ , toHie ty
1439+ ]
1440+ HsKindSig _ a b ->
1441+ [ toHie a
1442+ , toHie b
1443+ ]
1444+ HsSpliceTy _ a ->
1445+ [ toHie $ L span a
1446+ ]
1447+ HsDocTy _ a _ ->
1448+ [ toHie a
1449+ ]
1450+ HsBangTy _ _ ty ->
1451+ [ toHie ty
1452+ ]
1453+ HsRecTy _ fields ->
1454+ [ toHie fields
1455+ ]
1456+ HsExplicitListTy _ _ tys ->
1457+ [ toHie tys
1458+ ]
1459+ HsExplicitTupleTy _ tys ->
1460+ [ toHie tys
1461+ ]
1462+ HsTyLit _ _ -> []
1463+ HsWildCardTy _ -> []
1464+ HsStarTy _ _ -> []
1465+ XHsType _ -> []
1466+
1467+instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
1468+ toHie (HsValArg tm) = toHie tm
1469+ toHie (HsTypeArg _ ty) = toHie ty
1470+ toHie (HsArgPar sp) = pure $ locOnly sp
1471+
1472+instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where
1473+ toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
1474+ UserTyVar _ var ->
1475+ [ toHie $ C (TyVarBind sc tsc) var
1476+ ]
1477+ KindedTyVar _ var kind ->
1478+ [ toHie $ C (TyVarBind sc tsc) var
1479+ , toHie kind
1480+ ]
1481+ XTyVarBndr _ -> []
1482+
1483+instance ToHie (TScoped (LHsQTyVars GhcRn)) where
1484+ toHie (TS sc (HsQTvs (HsQTvsRn implicits _) vars)) = concatM $
1485+ [ pure $ bindingsOnly bindings
1486+ , toHie $ tvScopes sc NoScope vars
1487+ ]
1488+ where
1489+ varLoc = loc vars
1490+ bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits
1491+ toHie (TS _ (XLHsQTyVars _)) = pure []
1492+
1493+instance ToHie (LHsContext GhcRn) where
1494+ toHie (L span tys) = concatM $
1495+ [ pure $ locOnly span
1496+ , toHie tys
1497+ ]
1498+
1499+instance ToHie (LConDeclField GhcRn) where
1500+ toHie (L span field) = concatM $ makeNode field span : case field of
1501+ ConDeclField _ fields typ _ ->
1502+ [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields
1503+ , toHie typ
1504+ ]
1505+ XConDeclField _ -> []
1506+
1507+instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
1508+ toHie (From expr) = toHie expr
1509+ toHie (FromThen a b) = concatM $
1510+ [ toHie a
1511+ , toHie b
1512+ ]
1513+ toHie (FromTo a b) = concatM $
1514+ [ toHie a
1515+ , toHie b
1516+ ]
1517+ toHie (FromThenTo a b c) = concatM $
1518+ [ toHie a
1519+ , toHie b
1520+ , toHie c
1521+ ]
1522+
1523+instance ToHie (LSpliceDecl GhcRn) where
1524+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1525+ SpliceDecl _ splice _ ->
1526+ [ toHie splice
1527+ ]
1528+ XSpliceDecl _ -> []
1529+
1530+instance ToHie (HsBracket a) where
1531+ toHie _ = pure []
1532+
1533+instance ToHie PendingRnSplice where
1534+ toHie _ = pure []
1535+
1536+instance ToHie PendingTcSplice where
1537+ toHie _ = pure []
1538+
1539+instance ToHie (LBooleanFormula (Located Name)) where
1540+ toHie (L span form) = concatM $ makeNode form span : case form of
1541+ Var a ->
1542+ [ toHie $ C Use a
1543+ ]
1544+ And forms ->
1545+ [ toHie forms
1546+ ]
1547+ Or forms ->
1548+ [ toHie forms
1549+ ]
1550+ Parens f ->
1551+ [ toHie f
1552+ ]
1553+
1554+instance ToHie (Located HsIPName) where
1555+ toHie (L span e) = makeNode e span
1556+
1557+instance ( ToHie (LHsExpr a)
1558+ , Data (HsSplice a)
1559+ ) => ToHie (Located (HsSplice a)) where
1560+ toHie (L span sp) = concatM $ makeNode sp span : case sp of
1561+ HsTypedSplice _ _ _ expr ->
1562+ [ toHie expr
1563+ ]
1564+ HsUntypedSplice _ _ _ expr ->
1565+ [ toHie expr
1566+ ]
1567+ HsQuasiQuote _ _ _ ispan _ ->
1568+ [ pure $ locOnly ispan
1569+ ]
1570+ HsSpliced _ _ _ ->
1571+ []
1572+ HsSplicedT _ ->
1573+ []
1574+ XSplice _ -> []
1575+
1576+instance ToHie (LRoleAnnotDecl GhcRn) where
1577+ toHie (L span annot) = concatM $ makeNode annot span : case annot of
1578+ RoleAnnotDecl _ var roles ->
1579+ [ toHie $ C Use var
1580+ , concatMapM (pure . locOnly . getLoc) roles
1581+ ]
1582+ XRoleAnnotDecl _ -> []
1583+
1584+instance ToHie (LInstDecl GhcRn) where
1585+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1586+ ClsInstD _ d ->
1587+ [ toHie $ L span d
1588+ ]
1589+ DataFamInstD _ d ->
1590+ [ toHie $ L span d
1591+ ]
1592+ TyFamInstD _ d ->
1593+ [ toHie $ L span d
1594+ ]
1595+ XInstDecl _ -> []
1596+
1597+instance ToHie (LClsInstDecl GhcRn) where
1598+ toHie (L span decl) = concatM
1599+ [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
1600+ , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
1601+ , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl
1602+ , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl
1603+ , toHie $ cid_tyfam_insts decl
1604+ , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl
1605+ , toHie $ cid_datafam_insts decl
1606+ , toHie $ cid_overlap_mode decl
1607+ ]
1608+
1609+instance ToHie (LDataFamInstDecl GhcRn) where
1610+ toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
1611+
1612+instance ToHie (LTyFamInstDecl GhcRn) where
1613+ toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
1614+
1615+instance ToHie (Context a)
1616+ => ToHie (PatSynFieldContext (RecordPatSynField a)) where
1617+ toHie (PSC sp (RecordPatSynField a b)) = concatM $
1618+ [ toHie $ C (RecField RecFieldDecl sp) a
1619+ , toHie $ C Use b
1620+ ]
1621+
1622+instance ToHie (LDerivDecl GhcRn) where
1623+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1624+ DerivDecl _ typ strat overlap ->
1625+ [ toHie $ TS (ResolvedScopes []) typ
1626+ , toHie strat
1627+ , toHie overlap
1628+ ]
1629+ XDerivDecl _ -> []
1630+
1631+instance ToHie (LFixitySig GhcRn) where
1632+ toHie (L span sig) = concatM $ makeNode sig span : case sig of
1633+ FixitySig _ vars _ ->
1634+ [ toHie $ map (C Use) vars
1635+ ]
1636+ XFixitySig _ -> []
1637+
1638+instance ToHie (LDefaultDecl GhcRn) where
1639+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1640+ DefaultDecl _ typs ->
1641+ [ toHie typs
1642+ ]
1643+ XDefaultDecl _ -> []
1644+
1645+instance ToHie (LForeignDecl GhcRn) where
1646+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1647+ ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->
1648+ [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name
1649+ , toHie $ TS (ResolvedScopes []) sig
1650+ , toHie fi
1651+ ]
1652+ ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->
1653+ [ toHie $ C Use name
1654+ , toHie $ TS (ResolvedScopes []) sig
1655+ , toHie fe
1656+ ]
1657+ XForeignDecl _ -> []
1658+
1659+instance ToHie ForeignImport where
1660+ toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $
1661+ [ locOnly a
1662+ , locOnly b
1663+ , locOnly c
1664+ ]
1665+
1666+instance ToHie ForeignExport where
1667+ toHie (CExport (L a _) (L b _)) = pure $ concat $
1668+ [ locOnly a
1669+ , locOnly b
1670+ ]
1671+
1672+instance ToHie (LWarnDecls GhcRn) where
1673+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1674+ Warnings _ _ warnings ->
1675+ [ toHie warnings
1676+ ]
1677+ XWarnDecls _ -> []
1678+
1679+instance ToHie (LWarnDecl GhcRn) where
1680+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1681+ Warning _ vars _ ->
1682+ [ toHie $ map (C Use) vars
1683+ ]
1684+ XWarnDecl _ -> []
1685+
1686+instance ToHie (LAnnDecl GhcRn) where
1687+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1688+ HsAnnotation _ _ prov expr ->
1689+ [ toHie prov
1690+ , toHie expr
1691+ ]
1692+ XAnnDecl _ -> []
1693+
1694+instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where
1695+ toHie (ValueAnnProvenance a) = toHie $ C Use a
1696+ toHie (TypeAnnProvenance a) = toHie $ C Use a
1697+ toHie ModuleAnnProvenance = pure []
1698+
1699+instance ToHie (LRuleDecls GhcRn) where
1700+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1701+ HsRules _ _ rules ->
1702+ [ toHie rules
1703+ ]
1704+ XRuleDecls _ -> []
1705+
1706+instance ToHie (LRuleDecl GhcRn) where
1707+ toHie (L _ (XRuleDecl _)) = pure []
1708+ toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
1709+ [ makeNode r span
1710+ , pure $ locOnly $ getLoc rname
1711+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
1712+ , toHie $ map (RS $ mkScope span) bndrs
1713+ , toHie exprA
1714+ , toHie exprB
1715+ ]
1716+ where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc
1717+ bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)
1718+ exprA_sc = mkLScope exprA
1719+ exprB_sc = mkLScope exprB
1720+
1721+instance ToHie (RScoped (LRuleBndr GhcRn)) where
1722+ toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
1723+ RuleBndr _ var ->
1724+ [ toHie $ C (ValBind RegularBind sc Nothing) var
1725+ ]
1726+ RuleBndrSig _ var typ ->
1727+ [ toHie $ C (ValBind RegularBind sc Nothing) var
1728+ , toHie $ TS (ResolvedScopes [sc]) typ
1729+ ]
1730+ XRuleBndr _ -> []
1731+
1732+instance ToHie (LImportDecl GhcRn) where
1733+ toHie (L span decl) = concatM $ makeNode decl span : case decl of
1734+ ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->
1735+ [ toHie $ IEC Import name
1736+ , toHie $ fmap (IEC ImportAs) as
1737+ , maybe (pure []) goIE hidden
1738+ ]
1739+ XImportDecl _ -> []
1740+ where
1741+ goIE (hiding, (L sp liens)) = concatM $
1742+ [ pure $ locOnly sp
1743+ , toHie $ map (IEC c) liens
1744+ ]
1745+ where
1746+ c = if hiding then ImportHiding else Import
1747+
1748+instance ToHie (IEContext (LIE GhcRn)) where
1749+ toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of
1750+ IEVar _ n ->
1751+ [ toHie $ IEC c n
1752+ ]
1753+ IEThingAbs _ n ->
1754+ [ toHie $ IEC c n
1755+ ]
1756+ IEThingAll _ n ->
1757+ [ toHie $ IEC c n
1758+ ]
1759+ IEThingWith _ n _ ns flds ->
1760+ [ toHie $ IEC c n
1761+ , toHie $ map (IEC c) ns
1762+ , toHie $ map (IEC c) flds
1763+ ]
1764+ IEModuleContents _ n ->
1765+ [ toHie $ IEC c n
1766+ ]
1767+ IEGroup _ _ _ -> []
1768+ IEDoc _ _ -> []
1769+ IEDocNamed _ _ -> []
1770+ XIE _ -> []
1771+
1772+instance ToHie (IEContext (LIEWrappedName Name)) where
1773+ toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of
1774+ IEName n ->
1775+ [ toHie $ C (IEThing c) n
1776+ ]
1777+ IEPattern p ->
1778+ [ toHie $ C (IEThing c) p
1779+ ]
1780+ IEType n ->
1781+ [ toHie $ C (IEThing c) n
1782+ ]
1783+
1784+instance ToHie (IEContext (Located (FieldLbl Name))) where
1785+ toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of
1786+ FieldLabel _ _ n ->
1787+ [ toHie $ C (IEThing c) $ L span n
1788+ ]
1789+
src/Development/IDE/Compat.hsnew file+19
@@ -0,0 +1,19 @@
1+{-# LANGUAGE CPP #-}
2+module Development.IDE.Compat
3+ (
4+ getProcessID
5+ ) where
6+
7+#ifdef mingw32_HOST_OS
8+
9+import qualified System.Win32.Process as P (getCurrentProcessId)
10+getProcessID :: IO Int
11+getProcessID = fromIntegral <$> P.getCurrentProcessId
12+
13+#else
14+
15+import qualified System.Posix.Process as P (getProcessID)
16+getProcessID :: IO Int
17+getProcessID = fromIntegral <$> P.getProcessID
18+
19+#endif
src/Development/IDE/Core/Compile.hs+299−99
@@ -9,6 +9,7 @@
9-- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.
9-- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.
10module Development.IDE.Core.Compile
10module Development.IDE.Core.Compile
11 ( TcModuleResult(..)
11 ( TcModuleResult(..)
12+ , RunSimplifier(..)
12 , compileModule
13 , compileModule
13 , parseModule
14 , parseModule
14 , typecheckModule
15 , typecheckModule
@@ -16,10 +17,18 @@ module Development.IDE.Core.Compile
16 , addRelativeImport
17 , addRelativeImport
17 , mkTcModuleResult
18 , mkTcModuleResult
18 , generateByteCode
19 , generateByteCode
20+ , generateAndWriteHieFile
21+ , generateAndWriteHiFile
22+ , getModSummaryFromImports
23+ , loadHieFile
24+ , loadInterface
25+ , loadDepModule
26+ , loadModuleHome
19 ) where
27 ) where
20
28
21import Development.IDE.Core.RuleTypes
29import Development.IDE.Core.RuleTypes
22import Development.IDE.Core.Preprocessor
30import Development.IDE.Core.Preprocessor
31+import Development.IDE.Core.Shake
23import Development.IDE.GHC.Error
32import Development.IDE.GHC.Error
24import Development.IDE.GHC.Warnings
33import Development.IDE.GHC.Warnings
25import Development.IDE.Types.Diagnostics
34import Development.IDE.Types.Diagnostics
@@ -28,6 +37,7 @@ import Development.IDE.GHC.Util
28import qualified GHC.LanguageExtensions.Type as GHC
37import qualified GHC.LanguageExtensions.Type as GHC
29import Development.IDE.Types.Options
38import Development.IDE.Types.Options
30import Development.IDE.Types.Location
39import Development.IDE.Types.Location
40+import Outputable
31
41
32#if MIN_GHC_API_VERSION(8,6,0)
42#if MIN_GHC_API_VERSION(8,6,0)
33import DynamicLoading (initializePlugins)
43import DynamicLoading (initializePlugins)
@@ -36,43 +46,59 @@ import DynamicLoading (initializePlugins)
36import GHC hiding (parseModule, typecheckModule)
46import GHC hiding (parseModule, typecheckModule)
37import qualified Parser
47import qualified Parser
38import Lexer
48import Lexer
49+#if MIN_GHC_API_VERSION(8,10,0)
50+#else
39import ErrUtils
51import ErrUtils
52+#endif
40
53
41−import qualified GHC
54+import Finder
55+import qualified Development.IDE.GHC.Compat as GHC
56+import qualified Development.IDE.GHC.Compat as Compat
42import GhcMonad
57import GhcMonad
43import GhcPlugins as GHC hiding (fst3, (<>))
58import GhcPlugins as GHC hiding (fst3, (<>))
44import qualified HeaderInfo as Hdr
59import qualified HeaderInfo as Hdr
45−import HscMain (hscInteractive)
60+import HscMain (hscInteractive, hscSimplify)
61+import LoadIface (readIface)
62+import qualified Maybes
46import MkIface
63import MkIface
64+import NameCache
47import StringBuffer as SB
65import StringBuffer as SB
66+import TcRnMonad (initIfaceLoad, tcg_th_coreplugins)
67+import TcIface (typecheckIface)
48import TidyPgm
68import TidyPgm
49
69
70+import Control.Exception.Safe
50import Control.Monad.Extra
71import Control.Monad.Extra
51import Control.Monad.Except
72import Control.Monad.Except
52import Control.Monad.Trans.Except
73import Control.Monad.Trans.Except
53−import Data.Function
74+import Data.Bifunctor (first, second)
54−import Data.Ord
55import qualified Data.Text as T
75import qualified Data.Text as T
56import Data.IORef
76import Data.IORef
57import Data.List.Extra
77import Data.List.Extra
58import Data.Maybe
78import Data.Maybe
59−import Data.Tuple.Extra
60import qualified Data.Map.Strict as Map
79import qualified Data.Map.Strict as Map
61import System.FilePath
80import System.FilePath
81+import System.Directory
82+import System.IO.Extra
83+import Data.Either.Extra (maybeToEither)
84+import Control.DeepSeq (rnf)
85+import Control.Exception (evaluate)
86+import Exception (ExceptionMonad)
62
87
63
88
64-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
89-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
65parseModule
90parseModule
66 :: IdeOptions
91 :: IdeOptions
67 -> HscEnv
92 -> HscEnv
93+ -> [PackageName]
68 -> FilePath
94 -> FilePath
69 -> Maybe SB.StringBuffer
95 -> Maybe SB.StringBuffer
70− -> IO ([FileDiagnostic], Maybe (StringBuffer, ParsedModule))
96+ -> IO (IdeResult (StringBuffer, ParsedModule))
71−parseModule IdeOptions{..} env filename mbContents =
97+parseModule IdeOptions{..} env comp_pkgs filename mbContents =
72 fmap (either (, Nothing) id) $
98 fmap (either (, Nothing) id) $
73− runGhcEnv env $ runExceptT $ do
99+ evalGhcEnv env $ runExceptT $ do
74 (contents, dflags) <- preprocessor filename mbContents
100 (contents, dflags) <- preprocessor filename mbContents
75− (diag, modu) <- parseFileContents optPreprocessor dflags filename contents
101+ (diag, modu) <- parseFileContents optPreprocessor dflags comp_pkgs filename contents
76 return (diag, Just (contents, modu))
102 return (diag, Just (contents, modu))
77
103
78
104
@@ -84,34 +110,39 @@ computePackageDeps
84computePackageDeps env pkg = do
110computePackageDeps env pkg = do
85 let dflags = hsc_dflags env
111 let dflags = hsc_dflags env
86 case lookupInstalledPackage dflags pkg of
112 case lookupInstalledPackage dflags pkg of
87− Nothing -> return $ Left [ideErrorText (toNormalizedFilePath noFilePath) $
113+ Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $
88 T.pack $ "unknown package: " ++ show pkg]
114 T.pack $ "unknown package: " ++ show pkg]
89 Just pkgInfo -> return $ Right $ depends pkgInfo
115 Just pkgInfo -> return $ Right $ depends pkgInfo
90
116
91−
92−-- | Typecheck a single module using the supplied dependencies and packages.
93−typecheckModule
94− :: IdeDefer
117+typecheckModule :: IdeDefer
95− -> HscEnv
118+ -> HscEnv
96− -> [TcModuleResult]
119+ -> [(ModSummary, (ModIface, Maybe Linkable))]
97− -> ParsedModule
120+ -> ParsedModule
98− -> IO ([FileDiagnostic], Maybe TcModuleResult)
121+ -> IO (IdeResult (HscEnv, TcModuleResult))
99−typecheckModule (IdeDefer defer) packageState deps pm =
122+typecheckModule (IdeDefer defer) hsc depsIn pm = do
100− let demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
101− in
102− fmap (either (, Nothing) (second Just)) $
123+ fmap (either (, Nothing) (second Just . sequence) . sequence) $
103− runGhcEnv packageState $
124+ runGhcEnv hsc $
104− catchSrcErrors "typecheck" $ do
125+ catchSrcErrors "typecheck" $ do
105− setupEnv deps
126+ -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.
127+ -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.
128+ -- Long-term we might just want to change the order returned by GetDependencies
129+ let deps = reverse depsIn
130+
131+ setupFinderCache (map fst deps)
132+
106− let modSummary = pm_mod_summary pm
133+ let modSummary = pm_mod_summary pm
107− dflags = ms_hspp_opts modSummary
134+ dflags = ms_hspp_opts modSummary
135+
136+ mapM_ (uncurry loadDepModule . snd) deps
108− modSummary' <- initPlugins modSummary
137+ modSummary' <- initPlugins modSummary
109− (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
138+ (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
110− GHC.typecheckModule $ enableTopLevelWarnings
139+ GHC.typecheckModule $ enableTopLevelWarnings
111− $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
140+ $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
112− tcm2 <- mkTcModuleResult tcm
141+ tcm2 <- mkTcModuleResult tcm
113− let errorPipeline = unDefer . hideDiag dflags
142+ let errorPipeline = unDefer . hideDiag dflags
114− return (map errorPipeline warnings, tcm2)
143+ return (map errorPipeline warnings, tcm2)
144+ where
145+ demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
115
146
116initPlugins :: GhcMonad m => ModSummary -> m ModSummary
147initPlugins :: GhcMonad m => ModSummary -> m ModSummary
117initPlugins modSummary = do
148initPlugins modSummary = do
@@ -123,18 +154,25 @@ initPlugins modSummary = do
123 return modSummary
154 return modSummary
124#endif
155#endif
125
156
157+-- | Whether we should run the -O0 simplifier when generating core.
158+--
159+-- This is required for template Haskell to work but we disable this in DAML.
160+-- See #256
161+newtype RunSimplifier = RunSimplifier Bool
162+
126-- | Compile a single type-checked module to a 'CoreModule' value, or
163-- | Compile a single type-checked module to a 'CoreModule' value, or
127-- provide errors.
164-- provide errors.
128compileModule
165compileModule
166+ :: RunSimplifier
129− :: HscEnv
167+ -> HscEnv
130− -> [TcModuleResult]
168+ -> [(ModSummary, HomeModInfo)]
131 -> TcModuleResult
169 -> TcModuleResult
132− -> IO ([FileDiagnostic], Maybe (SafeHaskellMode, CgGuts, ModDetails))
170+ -> IO (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
133−compileModule packageState deps tmr =
171+compileModule (RunSimplifier simplify) packageState deps tmr =
134 fmap (either (, Nothing) (second Just)) $
172 fmap (either (, Nothing) (second Just)) $
135− runGhcEnv packageState $
173+ evalGhcEnv packageState $
136 catchSrcErrors "compile" $ do
174 catchSrcErrors "compile" $ do
137− setupEnv (deps ++ [tmr])
175+ setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])
138
176
139 let tm = tmrModule tmr
177 let tm = tmrModule tmr
140 session <- getSession
178 session <- getSession
@@ -143,20 +181,30 @@ compileModule packageState deps tmr =
143 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
181 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
144 let tm' = tm{tm_parsed_module = pm'}
182 let tm' = tm{tm_parsed_module = pm'}
145 GHC.dm_core_module <$> GHC.desugarModule tm'
183 GHC.dm_core_module <$> GHC.desugarModule tm'
146−
184+ let tc_result = fst (tm_internals_ (tmrModule tmr))
185+ desugared_guts <-
186+ if simplify
187+ then do
188+ plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
189+ liftIO $ hscSimplify session plugins desugar
190+ else pure desugar
147 -- give variables unique OccNames
191 -- give variables unique OccNames
148− (guts, details) <- liftIO $ tidyProgram session desugar
192+ (guts, details) <- liftIO $ tidyProgram session desugared_guts
149 return (map snd warnings, (mg_safe_haskell desugar, guts, details))
193 return (map snd warnings, (mg_safe_haskell desugar, guts, details))
150
194
151−generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO ([FileDiagnostic], Maybe Linkable)
195+generateByteCode :: HscEnv -> [(ModSummary, HomeModInfo)] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable)
152generateByteCode hscEnv deps tmr guts =
196generateByteCode hscEnv deps tmr guts =
153 fmap (either (, Nothing) (second Just)) $
197 fmap (either (, Nothing) (second Just)) $
154− runGhcEnv hscEnv $
198+ evalGhcEnv hscEnv $
155 catchSrcErrors "bytecode" $ do
199 catchSrcErrors "bytecode" $ do
156− setupEnv (deps ++ [tmr])
200+ setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])
157 session <- getSession
201 session <- getSession
158 (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->
202 (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->
203+#if MIN_GHC_API_VERSION(8,10,0)
159− liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)
204+ liftIO $ hscInteractive session guts (GHC.ms_location $ tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)
205+#else
206+ liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)
207+#endif
160 let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr
208 let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr
161 let unlinked = BCOs bytecode sptEntries
209 let unlinked = BCOs bytecode sptEntries
162 let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
210 let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
@@ -178,9 +226,10 @@ demoteTypeErrorsToWarnings =
178enableTopLevelWarnings :: ParsedModule -> ParsedModule
226enableTopLevelWarnings :: ParsedModule -> ParsedModule
179enableTopLevelWarnings =
227enableTopLevelWarnings =
180 (update_pm_mod_summary . update_hspp_opts)
228 (update_pm_mod_summary . update_hspp_opts)
229+ ((`wopt_set` Opt_WarnMissingPatternSynonymSignatures) .
181− (`wopt_set` Opt_WarnMissingSignatures)
230+ (`wopt_set` Opt_WarnMissingSignatures))
182 -- the line below would show also warnings for let bindings without signature
231 -- the line below would show also warnings for let bindings without signature
183− -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures))
232+ -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures)))
184
233
185update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary
234update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary
186update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}
235update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}
@@ -204,9 +253,9 @@ upgradeWarningToError (nfp, sh, fd) =
204hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
253hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
205hideDiag originalFlags (Reason warning, (nfp, _sh, fd))
254hideDiag originalFlags (Reason warning, (nfp, _sh, fd))
206 | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))
255 | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))
207−hideDiag _originalFlags t = t
256+hideDiag _originalFlags t = t
208
257
209−addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags
258+addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags
210addRelativeImport fp modu dflags = dflags
259addRelativeImport fp modu dflags = dflags
211 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
260 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
212
261
@@ -216,25 +265,81 @@ mkTcModuleResult
216 -> m TcModuleResult
265 -> m TcModuleResult
217mkTcModuleResult tcm = do
266mkTcModuleResult tcm = do
218 session <- getSession
267 session <- getSession
268+ let sf = modInfoSafe (tm_checked_module_info tcm)
269+#if MIN_GHC_API_VERSION(8,10,0)
270+ iface <- liftIO $ mkIfaceTc session sf details tcGblEnv
271+#else
219− (iface, _) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv
272+ (iface, _) <- liftIO $ mkIfaceTc session Nothing sf details tcGblEnv
273+#endif
220 let mod_info = HomeModInfo iface details Nothing
274 let mod_info = HomeModInfo iface details Nothing
221 return $ TcModuleResult tcm mod_info
275 return $ TcModuleResult tcm mod_info
222 where
276 where
223 (tcGblEnv, details) = tm_internals_ tcm
277 (tcGblEnv, details) = tm_internals_ tcm
224
278
279+atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO ()
280+atomicFileWrite targetPath write = do
281+ let dir = takeDirectory targetPath
282+ createDirectoryIfMissing True dir
283+ (tempFilePath, cleanUp) <- newTempFileWithin dir
284+ (write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp
285+
286+generateAndWriteHieFile :: HscEnv -> TypecheckedModule -> IO [FileDiagnostic]
287+generateAndWriteHieFile hscEnv tcm =
288+ handleGenerationErrors dflags "extended interface generation" $ do
289+ case tm_renamed_source tcm of
290+ Just rnsrc -> do
291+ hf <- runHsc hscEnv $
292+ GHC.mkHieFile mod_summary (fst $ tm_internals_ tcm) rnsrc ""
293+ atomicFileWrite targetPath $ flip GHC.writeHieFile hf
294+ _ ->
295+ return ()
296+ where
297+ dflags = hsc_dflags hscEnv
298+ mod_summary = pm_mod_summary $ tm_parsed_module tcm
299+ mod_location = ms_location mod_summary
300+ targetPath = Compat.ml_hie_file mod_location
301+
302+generateAndWriteHiFile :: HscEnv -> TcModuleResult -> IO [FileDiagnostic]
303+generateAndWriteHiFile hscEnv tc =
304+ handleGenerationErrors dflags "interface generation" $ do
305+ atomicFileWrite targetPath $ \fp ->
306+ writeIfaceFile dflags fp modIface
307+ where
308+ modIface = hm_iface $ tmrModInfo tc
309+ modSummary = tmrModSummary tc
310+ targetPath = withBootSuffix $ ml_hi_file $ ms_location $ tmrModSummary tc
311+ withBootSuffix = case ms_hsc_src modSummary of
312+ HsBootFile -> addBootSuffix
313+ _ -> id
314+ dflags = hsc_dflags hscEnv
315+
316+handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]
317+handleGenerationErrors dflags source action =
318+ action >> return [] `catches`
319+ [ Handler $ return . diagFromGhcException source dflags
320+ , Handler $ return . diagFromString source DsError (noSpan "<internal>")
321+ . (("Error during " ++ T.unpack source) ++) . show @SomeException
322+ ]
323+
324+
225-- | Setup the environment that GHC needs according to our
325-- | Setup the environment that GHC needs according to our
226-- best understanding (!)
326-- best understanding (!)
327+--
328+-- This involves setting up the finder cache and populating the
329+-- HPT.
227−setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
330+setupEnv :: GhcMonad m => [(ModSummary, HomeModInfo)] -> m ()
228−setupEnv tmsIn = do
331+setupEnv tms = do
229− -- if both a .hs-boot file and a .hs file appear here, we want to make sure that the .hs file
332+ setupFinderCache (map fst tms)
230− -- takes precedence, so put the .hs-boot file earlier in the list
333+ -- load dependent modules, which must be in topological order.
231− let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule
334+ modifySession $ \e ->
232− tms = sortBy (compare `on` Down . isSourceFile) tmsIn
335+ foldl' (\e (_, hmi) -> loadModuleHome hmi e) e tms
233
336
337+-- | Initialise the finder cache, dependencies should be topologically
338+-- sorted.
339+setupFinderCache :: GhcMonad m => [ModSummary] -> m ()
340+setupFinderCache mss = do
234 session <- getSession
341 session <- getSession
235
342
236− let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
237−
238 -- set the target and module graph in the session
343 -- set the target and module graph in the session
239 let graph = mkModuleGraph mss
344 let graph = mkModuleGraph mss
240 setSession session { hsc_mod_graph = graph }
345 setSession session { hsc_mod_graph = graph }
@@ -253,26 +358,40 @@ setupEnv tmsIn = do
253 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache
358 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache
254 modifySession $ \s -> s { hsc_FC = newFinderCacheVar }
359 modifySession $ \s -> s { hsc_FC = newFinderCacheVar }
255
360
256− -- load dependent modules, which must be in topological order.
257− mapM_ loadModuleHome tms
258−
259
361
260-- | Load a module, quickly. Input doesn't need to be desugared.
362-- | Load a module, quickly. Input doesn't need to be desugared.
261-- A module must be loaded before dependent modules can be typechecked.
363-- A module must be loaded before dependent modules can be typechecked.
262-- This variant of loadModuleHome will *never* cause recompilation, it just
364-- This variant of loadModuleHome will *never* cause recompilation, it just
263-- modifies the session.
365-- modifies the session.
366+--
367+-- The order modules are loaded is important when there are hs-boot files.
368+-- In particular you should make sure to load the .hs version of a file after the
369+-- .hs-boot version.
264loadModuleHome
370loadModuleHome
265− :: (GhcMonad m)
371+ :: HomeModInfo
266− => TcModuleResult
372+ -> HscEnv
267− -> m ()
373+ -> HscEnv
268−loadModuleHome tmr = modifySession $ \e ->
374+loadModuleHome mod_info e =
375+ e { hsc_HPT = addToHpt (hsc_HPT e) mod_name mod_info }
376+ where
377+ mod_name = moduleName $ mi_module $ hm_iface mod_info
378+
379+-- | Load module interface.
380+loadDepModuleIO :: ModIface -> Maybe Linkable -> HscEnv -> IO HscEnv
381+loadDepModuleIO iface linkable hsc = do
382+ details <- liftIO $ fixIO $ \details -> do
269− e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
383+ let hsc' = hsc { hsc_HPT = addToHpt (hsc_HPT hsc) mod (HomeModInfo iface details linkable) }
270− where
384+ initIfaceLoad hsc' (typecheckIface iface)
271− ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
385+ let mod_info = HomeModInfo iface details linkable
272− mod_info = tmrModInfo tmr
386+ return $ loadModuleHome mod_info hsc
273− mod = ms_mod_name ms
387+ where
274−
388+ mod = moduleName $ mi_module iface
275
389
390+loadDepModule :: GhcMonad m => ModIface -> Maybe Linkable -> m ()
391+loadDepModule iface linkable = do
392+ e <- getSession
393+ e' <- liftIO $ loadDepModuleIO iface linkable e
394+ setSession e'
276
395
277-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's
396-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's
278-- name and its imports.
397-- name and its imports.
@@ -293,30 +412,18 @@ getImportsParsed dflags (L loc parsed) = do
293 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
412 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
294 ])
413 ])
295
414
296−
297-- | Produce a module summary from a StringBuffer.
415-- | Produce a module summary from a StringBuffer.
298getModSummaryFromBuffer
416getModSummaryFromBuffer
299 :: GhcMonad m
417 :: GhcMonad m
300 => FilePath
418 => FilePath
301− -> SB.StringBuffer
302 -> DynFlags
419 -> DynFlags
303 -> GHC.ParsedSource
420 -> GHC.ParsedSource
304 -> ExceptT [FileDiagnostic] m ModSummary
421 -> ExceptT [FileDiagnostic] m ModSummary
305−getModSummaryFromBuffer fp contents dflags parsed = do
422+getModSummaryFromBuffer fp dflags parsed = do
306 (modName, imports) <- liftEither $ getImportsParsed dflags parsed
423 (modName, imports) <- liftEither $ getImportsParsed dflags parsed
307
424
308− let modLoc = ModLocation
425+ modLoc <- liftIO $ mkHomeModLocation dflags modName fp
309− { ml_hs_file = Just fp
310− , ml_hi_file = derivedFile "hi"
311− , ml_obj_file = derivedFile "o"
312−#if MIN_GHC_API_VERSION(8,8,0)
313− , ml_hie_file = derivedFile "hie"
314−#endif
315− -- This does not consider the dflags configuration
316− -- (-osuf and -hisuf, object and hi dir.s).
317− -- However, we anyway don't want to generate them.
318− }
319− InstalledUnitId unitId = thisInstalledUnitId dflags
426+ let InstalledUnitId unitId = thisInstalledUnitId dflags
320 return $ ModSummary
427 return $ ModSummary
321 { ms_mod = mkModule (fsToUnitId unitId) modName
428 { ms_mod = mkModule (fsToUnitId unitId) modName
322 , ms_location = modLoc
429 , ms_location = modLoc
@@ -328,7 +435,7 @@ getModSummaryFromBuffer fp contents dflags parsed = do
328 , ms_textual_imps = [imp | (False, imp) <- imports]
435 , ms_textual_imps = [imp | (False, imp) <- imports]
329 , ms_hspp_file = fp
436 , ms_hspp_file = fp
330 , ms_hspp_opts = dflags
437 , ms_hspp_opts = dflags
331− , ms_hspp_buf = Just contents
438+ , ms_hspp_buf = Nothing
332
439
333 -- defaults:
440 -- defaults:
334 , ms_hsc_src = sourceType
441 , ms_hsc_src = sourceType
@@ -341,27 +448,71 @@ getModSummaryFromBuffer fp contents dflags parsed = do
341 , ms_parsed_mod = Nothing
448 , ms_parsed_mod = Nothing
342 }
449 }
343 where
450 where
344− (sourceType, derivedFile) =
451+ sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile
345− let (stem, ext) = splitExtension fp in
452+
346− if "-boot" `isSuffixOf` ext
453+-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports.
347− then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")
454+-- Runs preprocessors as needed.
348− else (HsSrcFile , \newExt -> stem <.> newExt)
455+getModSummaryFromImports
349−
456+ :: (HasDynFlags m, ExceptionMonad m, MonadIO m)
350−
457+ => FilePath
458+ -> Maybe SB.StringBuffer
459+ -> ExceptT [FileDiagnostic] m ModSummary
460+getModSummaryFromImports fp contents = do
461+ (contents, dflags) <- preprocessor fp contents
462+ (srcImports, textualImports, L _ moduleName) <-
463+ ExceptT $ liftIO $ first (diagFromErrMsgs "parser" dflags) <$> GHC.getHeaderImports dflags contents fp fp
464+
465+ -- Force bits that might keep the string buffer and DynFlags alive unnecessarily
466+ liftIO $ evaluate $ rnf srcImports
467+ liftIO $ evaluate $ rnf textualImports
468+
469+ modLoc <- liftIO $ mkHomeModLocation dflags moduleName fp
470+
471+ let mod = mkModule (thisPackage dflags) moduleName
472+ sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile
473+ summary =
474+ ModSummary
475+ { ms_mod = mod
476+#if MIN_GHC_API_VERSION(8,8,0)
477+ , ms_hie_date = Nothing
478+#endif
479+ , ms_hs_date = error "Rules should not depend on ms_hs_date"
480+ -- When we are working with a virtual file we do not have a file date.
481+ -- To avoid silent issues where something is not processed because the date
482+ -- has not changed, we make sure that things blow up if they depend on the date.
483+ , ms_hsc_src = sourceType
484+ , ms_hspp_buf = Nothing
485+ , ms_hspp_file = fp
486+ , ms_hspp_opts = dflags
487+ , ms_iface_date = Nothing
488+ , ms_location = modLoc
489+ , ms_obj_date = Nothing
490+ , ms_parsed_mod = Nothing
491+ , ms_srcimps = srcImports
492+ , ms_textual_imps = textualImports
493+ }
494+ return summary
495+
496+
351−-- | Given a buffer, flags, file path and module summary, produce a
497+-- | Given a buffer, flags, and file path, produce a
352-- parsed module (or errors) and any parse warnings. Does not run any preprocessors
498-- parsed module (or errors) and any parse warnings. Does not run any preprocessors
353parseFileContents
499parseFileContents
354 :: GhcMonad m
500 :: GhcMonad m
355 => (GHC.ParsedSource -> IdePreprocessedSource)
501 => (GHC.ParsedSource -> IdePreprocessedSource)
356 -> DynFlags -- ^ flags to use
502 -> DynFlags -- ^ flags to use
503+ -> [PackageName] -- ^ The package imports to ignore
357 -> FilePath -- ^ the filename (for source locations)
504 -> FilePath -- ^ the filename (for source locations)
358 -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
505 -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
359 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
506 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
360−parseFileContents customPreprocessor dflags filename contents = do
507+parseFileContents customPreprocessor dflags comp_pkgs filename contents = do
361 let loc = mkRealSrcLoc (mkFastString filename) 1 1
508 let loc = mkRealSrcLoc (mkFastString filename) 1 1
362 case unP Parser.parseModule (mkPState dflags contents loc) of
509 case unP Parser.parseModule (mkPState dflags contents loc) of
510+#if MIN_GHC_API_VERSION(8,10,0)
511+ PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags
512+#else
363 PFailed _ locErr msgErr ->
513 PFailed _ locErr msgErr ->
364 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
514 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
515+#endif
365 POk pst rdr_module ->
516 POk pst rdr_module ->
366 let hpm_annotations =
517 let hpm_annotations =
367 (Map.fromListWith (++) $ annotations pst,
518 (Map.fromListWith (++) $ annotations pst,
@@ -385,14 +536,63 @@ parseFileContents customPreprocessor dflags filename contents = do
385 -- Ok, we got here. It's safe to continue.
536 -- Ok, we got here. It's safe to continue.
386 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
537 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
387 unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs
538 unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs
539+ let parsed' = removePackageImports comp_pkgs parsed
388 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
540 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
389− ms <- getModSummaryFromBuffer filename contents dflags parsed
541+ ms <- getModSummaryFromBuffer filename dflags parsed'
390 let pm =
542 let pm =
391 ParsedModule {
543 ParsedModule {
392 pm_mod_summary = ms
544 pm_mod_summary = ms
393− , pm_parsed_source = parsed
545+ , pm_parsed_source = parsed'
394 , pm_extra_src_files=[] -- src imports not allowed
546 , pm_extra_src_files=[] -- src imports not allowed
395 , pm_annotations = hpm_annotations
547 , pm_annotations = hpm_annotations
396 }
548 }
397 warnings = diagFromErrMsgs "parser" dflags warns
549 warnings = diagFromErrMsgs "parser" dflags warns
398 pure (warnings ++ preproc_warnings, pm)
550 pure (warnings ++ preproc_warnings, pm)
551+
552+
553+-- | After parsing the module remove all package imports referring to
554+-- these packages as we have already dealt with what they map to.
555+removePackageImports :: [PackageName] -> GHC.ParsedSource -> GHC.ParsedSource
556+removePackageImports pkgs (L l h@HsModule {hsmodImports} ) = L l (h { hsmodImports = imports' })
557+ where
558+ imports' = map do_one_import hsmodImports
559+ do_one_import (L l i@ImportDecl{ideclPkgQual}) =
560+ case PackageName . sl_fs <$> ideclPkgQual of
561+ Just pn | pn `elem` pkgs -> L l (i { ideclPkgQual = Nothing })
562+ _ -> L l i
563+#if MIN_GHC_API_VERSION(8,6,0)
564+ do_one_import l = l
565+#endif
566+
567+loadHieFile :: FilePath -> IO GHC.HieFile
568+loadHieFile f = do
569+ u <- mkSplitUniqSupply 'a'
570+ let nameCache = initNameCache u []
571+ fmap (GHC.hie_file_result . fst) $ GHC.readHieFile nameCache f
572+
573+-- | Retuns an up-to-date module interface if available.
574+-- Assumes file exists.
575+-- Requires the 'HscEnv' to be set up with dependencies
576+loadInterface
577+ :: HscEnv
578+ -> ModSummary
579+ -> [HiFileResult]
580+ -> IO (Either String ModIface)
581+loadInterface session ms deps = do
582+ let hiFile = case ms_hsc_src ms of
583+ HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)
584+ _ -> ml_hi_file $ ms_location ms
585+ r <- initIfaceLoad session $ readIface (ms_mod ms) hiFile
586+ case r of
587+ Maybes.Succeeded iface -> do
588+ session' <- foldM (\e d -> loadDepModuleIO (hirModIface d) Nothing e) session deps
589+ (reason, iface') <- checkOldIface session' ms SourceUnmodified (Just iface)
590+ return $ maybeToEither (showReason reason) iface'
591+ Maybes.Failed err -> do
592+ let errMsg = showSDoc (hsc_dflags session) err
593+ return $ Left errMsg
594+
595+showReason :: RecompileRequired -> String
596+showReason MustCompile = "Stale"
597+showReason (RecompBecause reason) = "Stale (" ++ reason ++ ")"
598+showReason UpToDate = "Up to date"
src/Development/IDE/Core/Debouncer.hs+18−11
@@ -3,16 +3,18 @@
3
3
4module Development.IDE.Core.Debouncer
4module Development.IDE.Core.Debouncer
5 ( Debouncer
5 ( Debouncer
6− , newDebouncer
7 , registerEvent
6 , registerEvent
7+ , newAsyncDebouncer
8+ , noopDebouncer
8 ) where
9 ) where
9
10
10import Control.Concurrent.Extra
11import Control.Concurrent.Extra
11import Control.Concurrent.Async
12import Control.Concurrent.Async
12import Control.Exception
13import Control.Exception
13import Control.Monad.Extra
14import Control.Monad.Extra
14−import Data.Map.Strict (Map)
15+import Data.Hashable
16+import Data.HashMap.Strict (HashMap)
15−import qualified Data.Map.Strict as Map
17+import qualified Data.HashMap.Strict as Map
16import System.Time.Extra
18import System.Time.Extra
17
19
18-- | A debouncer can be used to avoid triggering many events
20-- | A debouncer can be used to avoid triggering many events
@@ -21,13 +23,14 @@ import System.Time.Extra
21-- by delaying each event for a given time. If another event
23-- by delaying each event for a given time. If another event
22-- is registered for the same key within that timeframe,
24-- is registered for the same key within that timeframe,
23-- only the new event will fire.
25-- only the new event will fire.
26+--
27+-- We abstract over the debouncer used so we an use a proper debouncer in the IDE but disable
28+-- debouncing in the DAML CLI compiler.
24−newtype Debouncer k = Debouncer (Var (Map k (Async ())))
29+newtype Debouncer k = Debouncer { registerEvent :: Seconds -> k -> IO () -> IO () }
25
30
26−-- | Create a new empty debouncer.
31+-- | Debouncer used in the IDE that delays events as expected.
27−newDebouncer :: IO (Debouncer k)
32+newAsyncDebouncer :: (Eq k, Hashable k) => IO (Debouncer k)
28−newDebouncer = do
33+newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty
29− m <- newVar Map.empty
30− pure $ Debouncer m
31
34
32-- | Register an event that will fire after the given delay if no other event
35-- | Register an event that will fire after the given delay if no other event
33-- for the same key gets registered until then.
36-- for the same key gets registered until then.
@@ -35,11 +38,15 @@ newDebouncer = do
35-- If there is a pending event for the same key, the pending event will be killed.
38-- If there is a pending event for the same key, the pending event will be killed.
36-- Events are run unmasked so it is up to the user of `registerEvent`
39-- Events are run unmasked so it is up to the user of `registerEvent`
37-- to mask if required.
40-- to mask if required.
38−registerEvent :: Ord k => Debouncer k -> Seconds -> k -> IO () -> IO ()
41+asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()
39−registerEvent (Debouncer d) delay k fire = modifyVar_ d $ \m -> mask_ $ do
42+asyncRegisterEvent d delay k fire = modifyVar_ d $ \m -> mask_ $ do
40 whenJust (Map.lookup k m) cancel
43 whenJust (Map.lookup k m) cancel
41 a <- asyncWithUnmask $ \unmask -> unmask $ do
44 a <- asyncWithUnmask $ \unmask -> unmask $ do
42 sleep delay
45 sleep delay
43 fire
46 fire
44 modifyVar_ d (pure . Map.delete k)
47 modifyVar_ d (pure . Map.delete k)
45 pure $ Map.insert k a m
48 pure $ Map.insert k a m
49+
50+-- | Debouncer used in the DAML CLI compiler that emits events immediately.
51+noopDebouncer :: Debouncer k
52+noopDebouncer = Debouncer $ \_ _ a -> a
src/Development/IDE/Core/FileExists.hs+40−46
@@ -14,13 +14,15 @@ import Control.Monad.Extra
14import qualified Data.Aeson as A
14import qualified Data.Aeson as A
15import Data.Binary
15import Data.Binary
16import qualified Data.ByteString as BS
16import qualified Data.ByteString as BS
17−import Data.Map.Strict ( Map )
17+import Data.HashMap.Strict (HashMap)
18−import qualified Data.Map.Strict as Map
18+import qualified Data.HashMap.Strict as HashMap
19import Data.Maybe
19import Data.Maybe
20import qualified Data.Text as T
20import qualified Data.Text as T
21import Development.IDE.Core.FileStore
21import Development.IDE.Core.FileStore
22+import Development.IDE.Core.IdeConfiguration
22import Development.IDE.Core.Shake
23import Development.IDE.Core.Shake
23import Development.IDE.Types.Location
24import Development.IDE.Types.Location
25+import Development.IDE.Types.Logger
24import Development.Shake
26import Development.Shake
25import Development.Shake.Classes
27import Development.Shake.Classes
26import GHC.Generics
28import GHC.Generics
@@ -30,7 +32,7 @@ import Language.Haskell.LSP.Types.Capabilities
30import qualified System.Directory as Dir
32import qualified System.Directory as Dir
31
33
32-- | A map for tracking the file existence
34-- | A map for tracking the file existence
33−type FileExistsMap = (Map NormalizedFilePath Bool)
35+type FileExistsMap = (HashMap NormalizedFilePath Bool)
34
36
35-- | A wrapper around a mutable 'FileExistsMap'
37-- | A wrapper around a mutable 'FileExistsMap'
36newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap)
38newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap)
@@ -53,12 +55,12 @@ modifyFileExistsAction f = do
53modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO ()
55modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO ()
54modifyFileExists state changes = do
56modifyFileExists state changes = do
55 FileExistsMapVar var <- getIdeGlobalState state
57 FileExistsMapVar var <- getIdeGlobalState state
56− changesMap <- evaluate $ Map.fromList changes
58+ changesMap <- evaluate $ HashMap.fromList changes
57
59
58 -- Masked to ensure that the previous values are flushed together with the map update
60 -- Masked to ensure that the previous values are flushed together with the map update
59 mask $ \_ -> do
61 mask $ \_ -> do
60 -- update the map
62 -- update the map
61− modifyVar_ var $ evaluate . Map.union changesMap
63+ modifyVar_ var $ evaluate . HashMap.union changesMap
62 -- flush previous values
64 -- flush previous values
63 mapM_ (deleteValue state GetFileExists . fst) changes
65 mapM_ (deleteValue state GetFileExists . fst) changes
64
66
@@ -89,20 +91,34 @@ getFileExists fp = use_ GetFileExists fp
89-- Provides a fast implementation if client supports dynamic watched files.
91-- Provides a fast implementation if client supports dynamic watched files.
90-- Creates a global state as a side effect in that case.
92-- Creates a global state as a side effect in that case.
91fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules ()
93fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules ()
92−fileExistsRules getLspId ClientCapabilities{_workspace}
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
93− | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
100+ _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
94− , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
101+ , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
95− , Just True <- _dynamicRegistration
102+ , Just True <- _dynamicRegistration
96− = fileExistsRulesFast getLspId
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"
97− | otherwise = fileExistsRulesSlow
107+ fileExistsRulesSlow vfs
98
108
99-- Requires an lsp client that provides WatchedFiles notifications.
109-- Requires an lsp client that provides WatchedFiles notifications.
100fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()
110fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()
101−fileExistsRulesFast getLspId vfs = do
111+fileExistsRulesFast getLspId vfs =
102− addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])
103 defineEarlyCutoff $ \GetFileExists file -> do
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
104 fileExistsMap <- getFileExistsMapUntracked
120 fileExistsMap <- getFileExistsMapUntracked
105− let mbFilesWatched = Map.lookup file fileExistsMap
121+ let mbFilesWatched = HashMap.lookup file fileExistsMap
106 case mbFilesWatched of
122 case mbFilesWatched of
107 Just fv -> pure (summarizeExists fv, ([], Just fv))
123 Just fv -> pure (summarizeExists fv, ([], Just fv))
108 Nothing -> do
124 Nothing -> do
@@ -113,7 +129,7 @@ fileExistsRulesFast getLspId vfs = do
113 -- taking the FileExistsMap lock to prevent race conditions
129 -- taking the FileExistsMap lock to prevent race conditions
114 -- that would lead to multiple listeners for the same path
130 -- that would lead to multiple listeners for the same path
115 modifyFileExistsAction $ \x -> do
131 modifyFileExistsAction $ \x -> do
116− case Map.insertLookupWithKey (\_ x _ -> x) file exist x of
132+ case HashMap.alterF (,Just exist) file x of
117 (Nothing, x') -> do
133 (Nothing, x') -> do
118 -- if the listener addition fails, we never recover. This is a bug.
134 -- if the listener addition fails, we never recover. This is a bug.
119 addListener eventer file
135 addListener eventer file
@@ -134,9 +150,10 @@ fileExistsRulesFast getLspId vfs = do
134 WorkspaceDidChangeWatchedFiles
150 WorkspaceDidChangeWatchedFiles
135 (Just (A.toJSON regOptions))
151 (Just (A.toJSON regOptions))
136 regOptions =
152 regOptions =
137− DidChangeWatchedFilesRegistrationOptions { watchers = List [watcher] }
153+ DidChangeWatchedFilesRegistrationOptions { _watchers = List [watcher] }
154+ watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True}
138− watcher = FileSystemWatcher { globPattern = fromNormalizedFilePath fp
155+ watcher = FileSystemWatcher { _globPattern = fromNormalizedFilePath fp
139− , kind = Just 5 -- Create and Delete events only
156+ , _kind = Just watchKind
140 }
157 }
141
158
142 eventer $ ReqRegisterCapability req
159 eventer $ ReqRegisterCapability req
@@ -145,8 +162,11 @@ summarizeExists :: Bool -> Maybe BS.ByteString
145summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty
162summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty
146
163
147fileExistsRulesSlow:: VFSHandle -> Rules ()
164fileExistsRulesSlow:: VFSHandle -> Rules ()
148−fileExistsRulesSlow vfs = do
165+fileExistsRulesSlow vfs =
149− defineEarlyCutoff $ \GetFileExists file -> do
166+ defineEarlyCutoff $ \GetFileExists file -> fileExistsSlow vfs file
167+
168+fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))
169+fileExistsSlow vfs file = do
150 alwaysRerun
170 alwaysRerun
151 exist <- liftIO $ getFileExistsVFS vfs file
171 exist <- liftIO $ getFileExistsVFS vfs file
152 pure (summarizeExists exist, ([], Just exist))
172 pure (summarizeExists exist, ([], Just exist))
@@ -159,29 +179,3 @@ getFileExistsVFS vfs file = do
159 handle (\(_ :: IOException) -> return False) $
179 handle (\(_ :: IOException) -> return False) $
160 (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
180 (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
161 Dir.doesFileExist (fromNormalizedFilePath file)
181 Dir.doesFileExist (fromNormalizedFilePath file)
162−
163−--------------------------------------------------------------------------------------------------
164−-- The message definitions below probably belong in haskell-lsp-types
165−
166−data DidChangeWatchedFilesRegistrationOptions = DidChangeWatchedFilesRegistrationOptions
167− { watchers :: List FileSystemWatcher
168− }
169−
170−instance A.ToJSON DidChangeWatchedFilesRegistrationOptions where
171− toJSON DidChangeWatchedFilesRegistrationOptions {..} =
172− A.object ["watchers" A..= watchers]
173−
174−data FileSystemWatcher = FileSystemWatcher
175− { -- | The glob pattern to watch.
176− -- For details on glob pattern syntax, check the spec: https://microsoft.github.io/language-server-protocol/specifications/specification-3-14/#workspace_didChangeWatchedFiles
177− globPattern :: String
178− -- | The kind of event to subscribe to. Defaults to all.
179− -- Defined as a bitmap of Create(1), Change(2), and Delete(4)
180− , kind :: Maybe Int
181− }
182−
183−instance A.ToJSON FileSystemWatcher where
184− toJSON FileSystemWatcher {..} =
185− A.object
186− $ ["globPattern" A..= globPattern]
187− ++ [ "kind" A..= x | Just x <- [kind] ]
src/Development/IDE/Core/FileStore.hs+11−10
@@ -14,9 +14,7 @@ module Development.IDE.Core.FileStore(
14 makeLSPVFSHandle
14 makeLSPVFSHandle
15 ) where
15 ) where
16
16
17−import StringBuffer
18import Development.IDE.GHC.Orphans()
17import Development.IDE.GHC.Orphans()
19−import Development.IDE.GHC.Util
20import Development.IDE.Core.Shake
18import Development.IDE.Core.Shake
21import Control.Concurrent.Extra
19import Control.Concurrent.Extra
22import qualified Data.Map.Strict as Map
20import qualified Data.Map.Strict as Map
@@ -85,7 +83,7 @@ makeLSPVFSHandle lspFuncs = VFSHandle
85
83
86
84
87-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
85-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
88−type instance RuleResult GetFileContents = (FileVersion, Maybe StringBuffer)
86+type instance RuleResult GetFileContents = (FileVersion, Maybe T.Text)
89
87
90data GetFileContents = GetFileContents
88data GetFileContents = GetFileContents
91 deriving (Eq, Show, Generic)
89 deriving (Eq, Show, Generic)
@@ -97,11 +95,12 @@ getModificationTimeRule :: VFSHandle -> Rules ()
97getModificationTimeRule vfs =
95getModificationTimeRule vfs =
98 defineEarlyCutoff $ \GetModificationTime file -> do
96 defineEarlyCutoff $ \GetModificationTime file -> do
99 let file' = fromNormalizedFilePath file
97 let file' = fromNormalizedFilePath file
100− let wrap time = (Just time, ([], Just $ ModificationTime time))
98+ let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s))
101 alwaysRerun
99 alwaysRerun
102 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
100 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
103 case mbVirtual of
101 case mbVirtual of
102+ Just (virtualFileVersion -> ver) ->
104− Just (virtualFileVersion -> ver) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
103+ pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
105 Nothing -> liftIO $ fmap wrap (getModTime file')
104 Nothing -> liftIO $ fmap wrap (getModTime file')
106 `catch` \(e :: IOException) -> do
105 `catch` \(e :: IOException) -> do
107 let err | isDoesNotExistError e = "File does not exist: " ++ file'
106 let err | isDoesNotExistError e = "File does not exist: " ++ file'
@@ -117,11 +116,13 @@ getModificationTimeRule vfs =
117 -- We might also want to try speeding this up on Windows at some point.
116 -- We might also want to try speeding this up on Windows at some point.
118 -- TODO leverage DidChangeWatchedFile lsp notifications on clients that
117 -- TODO leverage DidChangeWatchedFile lsp notifications on clients that
119 -- support them, as done for GetFileExists
118 -- support them, as done for GetFileExists
120− getModTime :: FilePath -> IO BS.ByteString
119+ getModTime :: FilePath -> IO (Int,Int)
121 getModTime f =
120 getModTime f =
122#ifdef mingw32_HOST_OS
121#ifdef mingw32_HOST_OS
123 do time <- Dir.getModificationTime f
122 do time <- Dir.getModificationTime f
123+ let !day = fromInteger $ toModifiedJulianDay $ utctDay time
124− pure $! BS.pack $ show (toModifiedJulianDay $ utctDay time, diffTimeToPicoseconds $ utctDayTime time)
124+ !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time
125+ pure (day, dayTime)
125#else
126#else
126 withCString f $ \f' ->
127 withCString f $ \f' ->
127 alloca $ \secPtr ->
128 alloca $ \secPtr ->
@@ -129,7 +130,7 @@ getModificationTimeRule vfs =
129 Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr
130 Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr
130 sec <- peek secPtr
131 sec <- peek secPtr
131 nsec <- peek nsecPtr
132 nsec <- peek nsecPtr
132− pure $! BS.pack $ show sec <> "." <> show nsec
133+ pure (fromEnum sec, fromIntegral nsec)
133
134
134-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow
135-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow
135-- as doing the FFI call ourselves :(.
136-- as doing the FFI call ourselves :(.
@@ -143,7 +144,7 @@ getFileContentsRule vfs =
143 time <- use_ GetModificationTime file
144 time <- use_ GetModificationTime file
144 res <- liftIO $ ideTryIOException file $ do
145 res <- liftIO $ ideTryIOException file $ do
145 mbVirtual <- getVirtualFile vfs $ filePathToUri' file
146 mbVirtual <- getVirtualFile vfs $ filePathToUri' file
146− pure $ textToStringBuffer . Rope.toText . _text <$> mbVirtual
147+ pure $ Rope.toText . _text <$> mbVirtual
147 case res of
148 case res of
148 Left err -> return ([err], Nothing)
149 Left err -> return ([err], Nothing)
149 Right contents -> return ([], Just (time, contents))
150 Right contents -> return ([], Just (time, contents))
@@ -155,7 +156,7 @@ ideTryIOException fp act =
155 <$> try act
156 <$> try act
156
157
157
158
158−getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe StringBuffer)
159+getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe T.Text)
159getFileContents = use_ GetFileContents
160getFileContents = use_ GetFileContents
160
161
161fileStoreRules :: VFSHandle -> Rules ()
162fileStoreRules :: VFSHandle -> Rules ()
src/Development/IDE/Core/IdeConfiguration.hsnew file+71
@@ -0,0 +1,71 @@
1+{-# LANGUAGE DuplicateRecordFields #-}
2+module Development.IDE.Core.IdeConfiguration
3+ ( IdeConfiguration(..)
4+ , registerIdeConfiguration
5+ , parseConfiguration
6+ , parseWorkspaceFolder
7+ , isWorkspaceFile
8+ , modifyWorkspaceFolders
9+ )
10+where
11+
12+import Control.Concurrent.Extra
13+import Control.Monad
14+import Data.HashSet (HashSet, singleton)
15+import Data.Text (Text, isPrefixOf)
16+import Development.IDE.Core.Shake
17+import Development.IDE.Types.Location
18+import Development.Shake
19+import Language.Haskell.LSP.Types
20+import System.FilePath (isRelative)
21+
22+-- | Lsp client relevant configuration details
23+data IdeConfiguration = IdeConfiguration
24+ { workspaceFolders :: HashSet NormalizedUri
25+ }
26+ deriving (Show)
27+
28+newtype IdeConfigurationVar = IdeConfigurationVar {unIdeConfigurationRef :: Var IdeConfiguration}
29+
30+instance IsIdeGlobal IdeConfigurationVar
31+
32+registerIdeConfiguration :: ShakeExtras -> IdeConfiguration -> IO ()
33+registerIdeConfiguration extras =
34+ addIdeGlobalExtras extras . IdeConfigurationVar <=< newVar
35+
36+getIdeConfiguration :: Action IdeConfiguration
37+getIdeConfiguration =
38+ getIdeGlobalAction >>= liftIO . readVar . unIdeConfigurationRef
39+
40+parseConfiguration :: InitializeParams -> IdeConfiguration
41+parseConfiguration InitializeParams {..} =
42+ IdeConfiguration { .. }
43+ where
44+ workspaceFolders =
45+ foldMap (singleton . toNormalizedUri) _rootUri
46+ <> (foldMap . foldMap)
47+ (singleton . parseWorkspaceFolder)
48+ _workspaceFolders
49+
50+parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri
51+parseWorkspaceFolder =
52+ toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text)
53+
54+modifyWorkspaceFolders
55+ :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()
56+modifyWorkspaceFolders ide f = do
57+ IdeConfigurationVar var <- getIdeGlobalState ide
58+ IdeConfiguration ws <- readVar var
59+ writeVar var (IdeConfiguration (f ws))
60+
61+isWorkspaceFile :: NormalizedFilePath -> Action Bool
62+isWorkspaceFile file =
63+ if isRelative (fromNormalizedFilePath file)
64+ then return True
65+ else do
66+ IdeConfiguration {..} <- getIdeConfiguration
67+ let toText = getUri . fromNormalizedUri
68+ return $
69+ any
70+ (\root -> toText root `isPrefixOf` toText (filePathToUri' file))
71+ workspaceFolders
src/Development/IDE/Core/OfInterest.hs+10−10
@@ -19,8 +19,8 @@ import GHC.Generics
19import Data.Typeable
19import Data.Typeable
20import qualified Data.ByteString.UTF8 as BS
20import qualified Data.ByteString.UTF8 as BS
21import Control.Exception
21import Control.Exception
22−import Data.Set (Set)
22+import Data.HashSet (HashSet)
23−import qualified Data.Set as Set
23+import qualified Data.HashSet as HashSet
24import qualified Data.Text as T
24import qualified Data.Text as T
25import Data.Tuple.Extra
25import Data.Tuple.Extra
26import Data.Functor
26import Data.Functor
@@ -31,10 +31,10 @@ import Development.IDE.Types.Logger
31import Development.IDE.Core.Shake
31import Development.IDE.Core.Shake
32
32
33
33
34−newtype OfInterestVar = OfInterestVar (Var (Set NormalizedFilePath))
34+newtype OfInterestVar = OfInterestVar (Var (HashSet NormalizedFilePath))
35instance IsIdeGlobal OfInterestVar
35instance IsIdeGlobal OfInterestVar
36
36
37−type instance RuleResult GetFilesOfInterest = Set NormalizedFilePath
37+type instance RuleResult GetFilesOfInterest = HashSet NormalizedFilePath
38
38
39data GetFilesOfInterest = GetFilesOfInterest
39data GetFilesOfInterest = GetFilesOfInterest
40 deriving (Eq, Show, Typeable, Generic)
40 deriving (Eq, Show, Typeable, Generic)
@@ -46,7 +46,7 @@ instance Binary GetFilesOfInterest
46-- | The rule that initialises the files of interest state.
46-- | The rule that initialises the files of interest state.
47ofInterestRules :: Rules ()
47ofInterestRules :: Rules ()
48ofInterestRules = do
48ofInterestRules = do
49− addIdeGlobal . OfInterestVar =<< liftIO (newVar Set.empty)
49+ addIdeGlobal . OfInterestVar =<< liftIO (newVar HashSet.empty)
50 defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do
50 defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do
51 alwaysRerun
51 alwaysRerun
52 filesOfInterest <- getFilesOfInterestUntracked
52 filesOfInterest <- getFilesOfInterestUntracked
@@ -54,7 +54,7 @@ ofInterestRules = do
54
54
55
55
56-- | Get the files that are open in the IDE.
56-- | Get the files that are open in the IDE.
57−getFilesOfInterest :: Action (Set NormalizedFilePath)
57+getFilesOfInterest :: Action (HashSet NormalizedFilePath)
58getFilesOfInterest = useNoFile_ GetFilesOfInterest
58getFilesOfInterest = useNoFile_ GetFilesOfInterest
59
59
60
60
@@ -64,19 +64,19 @@ getFilesOfInterest = useNoFile_ GetFilesOfInterest
64
64
65-- | Set the files-of-interest - not usually necessary or advisable.
65-- | Set the files-of-interest - not usually necessary or advisable.
66-- The LSP client will keep this information up to date.
66-- The LSP client will keep this information up to date.
67−setFilesOfInterest :: IdeState -> Set NormalizedFilePath -> IO ()
67+setFilesOfInterest :: IdeState -> HashSet NormalizedFilePath -> IO ()
68setFilesOfInterest state files = modifyFilesOfInterest state (const files)
68setFilesOfInterest state files = modifyFilesOfInterest state (const files)
69
69
70−getFilesOfInterestUntracked :: Action (Set NormalizedFilePath)
70+getFilesOfInterestUntracked :: Action (HashSet NormalizedFilePath)
71getFilesOfInterestUntracked = do
71getFilesOfInterestUntracked = do
72 OfInterestVar var <- getIdeGlobalAction
72 OfInterestVar var <- getIdeGlobalAction
73 liftIO $ readVar var
73 liftIO $ readVar var
74
74
75-- | Modify the files-of-interest - not usually necessary or advisable.
75-- | Modify the files-of-interest - not usually necessary or advisable.
76-- The LSP client will keep this information up to date.
76-- The LSP client will keep this information up to date.
77−modifyFilesOfInterest :: IdeState -> (Set NormalizedFilePath -> Set NormalizedFilePath) -> IO ()
77+modifyFilesOfInterest :: IdeState -> (HashSet NormalizedFilePath -> HashSet NormalizedFilePath) -> IO ()
78modifyFilesOfInterest state f = do
78modifyFilesOfInterest state f = do
79 OfInterestVar var <- getIdeGlobalState state
79 OfInterestVar var <- getIdeGlobalState state
80 files <- modifyVar var $ pure . dupe . f
80 files <- modifyVar var $ pure . dupe . f
81− logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ Set.toList files)
81+ logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashSet.toList files)
82 void $ shakeRun state []
82 void $ shakeRun state []
src/Development/IDE/Core/PositionMapping.hs+48−10
@@ -2,10 +2,15 @@
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3module Development.IDE.Core.PositionMapping
3module Development.IDE.Core.PositionMapping
4 ( PositionMapping(..)
4 ( PositionMapping(..)
5+ , fromCurrentPosition
6+ , toCurrentPosition
7+ , PositionDelta(..)
8+ , addDelta
9+ , mkDelta
5 , toCurrentRange
10 , toCurrentRange
6 , fromCurrentRange
11 , fromCurrentRange
7 , applyChange
12 , applyChange
8− , idMapping
13+ , zeroMapping
9 -- toCurrent and fromCurrent are mainly exposed for testing
14 -- toCurrent and fromCurrent are mainly exposed for testing
10 , toCurrent
15 , toCurrent
11 , fromCurrent
16 , fromCurrent
@@ -14,12 +19,25 @@ module Development.IDE.Core.PositionMapping
14import Control.Monad
19import Control.Monad
15import qualified Data.Text as T
20import qualified Data.Text as T
16import Language.Haskell.LSP.Types
21import Language.Haskell.LSP.Types
22+import Data.List
17
23
18−data PositionMapping = PositionMapping
24+-- The position delta is the difference between two versions
25+data PositionDelta = PositionDelta
19− { toCurrentPosition :: !(Position -> Maybe Position)
26+ { toDelta :: !(Position -> Maybe Position)
20− , fromCurrentPosition :: !(Position -> Maybe Position)
27+ , fromDelta :: !(Position -> Maybe Position)
21 }
28 }
22
29
30+fromCurrentPosition :: PositionMapping -> Position -> Maybe Position
31+fromCurrentPosition (PositionMapping pm) = fromDelta pm
32+
33+toCurrentPosition :: PositionMapping -> Position -> Maybe Position
34+toCurrentPosition (PositionMapping pm) = toDelta pm
35+
36+-- A position mapping is the difference from the current version to
37+-- a specific version
38+newtype PositionMapping = PositionMapping PositionDelta
39+
40+
23toCurrentRange :: PositionMapping -> Range -> Maybe Range
41toCurrentRange :: PositionMapping -> Range -> Maybe Range
24toCurrentRange mapping (Range a b) =
42toCurrentRange mapping (Range a b) =
25 Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b
43 Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b
@@ -28,13 +46,33 @@ fromCurrentRange :: PositionMapping -> Range -> Maybe Range
28fromCurrentRange mapping (Range a b) =
46fromCurrentRange mapping (Range a b) =
29 Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b
47 Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b
30
48
31−idMapping :: PositionMapping
49+zeroMapping :: PositionMapping
32−idMapping = PositionMapping Just Just
50+zeroMapping = PositionMapping idDelta
51+
52+-- | Compose two position mappings. Composes in the same way as function
53+-- composition (ie the second argument is applyed to the position first).
54+composeDelta :: PositionDelta
55+ -> PositionDelta
56+ -> PositionDelta
57+composeDelta (PositionDelta to1 from1) (PositionDelta to2 from2) =
58+ PositionDelta (to1 <=< to2)
59+ (from1 >=> from2)
60+
61+idDelta :: PositionDelta
62+idDelta = PositionDelta Just Just
63+
64+-- | Convert a set of changes into a delta from k to k + 1
65+mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta
66+mkDelta cs = foldl' applyChange idDelta cs
67+
68+-- | Add a new delta onto a Mapping k n to make a Mapping (k - 1) n
69+addDelta :: PositionDelta -> PositionMapping -> PositionMapping
70+addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm)
33
71
34−applyChange :: PositionMapping -> TextDocumentContentChangeEvent -> PositionMapping
72+applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta
35−applyChange posMapping (TextDocumentContentChangeEvent (Just r) _ t) = PositionMapping
73+applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta
36− { toCurrentPosition = toCurrent r t <=< toCurrentPosition posMapping
74+ { toDelta = toCurrent r t <=< toDelta
37− , fromCurrentPosition = fromCurrentPosition posMapping <=< fromCurrent r t
75+ , fromDelta = fromDelta <=< fromCurrent r t
38 }
76 }
39applyChange posMapping _ = posMapping
77applyChange posMapping _ = posMapping
40
78
src/Development/IDE/Core/Preprocessor.hs+15−13
@@ -29,11 +29,15 @@ import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
29import Data.Text (Text)
29import Data.Text (Text)
30import qualified Data.Text as T
30import qualified Data.Text as T
31import Outputable (showSDoc)
31import Outputable (showSDoc)
32+import Control.DeepSeq (NFData(rnf))
33+import Control.Exception (evaluate)
34+import Control.Monad.IO.Class (MonadIO)
35+import Exception (ExceptionMonad)
32
36
33
37
34-- | Given a file and some contents, apply any necessary preprocessors,
38-- | Given a file and some contents, apply any necessary preprocessors,
35-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.
39-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.
36−preprocessor :: GhcMonad m => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)
40+preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)
37preprocessor filename mbContents = do
41preprocessor filename mbContents = do
38 -- Perform unlit
42 -- Perform unlit
39 (isOnDisk, contents) <-
43 (isOnDisk, contents) <-
@@ -96,7 +100,7 @@ data CPPDiag
96
100
97diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic]
101diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic]
98diagsFromCPPLogs filename logs =
102diagsFromCPPLogs filename logs =
99− map (\d -> (toNormalizedFilePath filename, ShowDiag, cppDiagToDiagnostic d)) $
103+ map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $
100 go [] logs
104 go [] logs
101 where
105 where
102 -- On errors, CPP calls logAction with a real span for the initial log and
106 -- On errors, CPP calls logAction with a real span for the initial log and
@@ -118,7 +122,8 @@ diagsFromCPPLogs filename logs =
118 _code = Nothing,
122 _code = Nothing,
119 _source = Just "CPP",
123 _source = Just "CPP",
120 _message = T.unlines $ cdMessage d,
124 _message = T.unlines $ cdMessage d,
121− _relatedInformation = Nothing
125+ _relatedInformation = Nothing,
126+ _tags = Nothing
122 }
127 }
123
128
124
129
@@ -128,13 +133,17 @@ isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]
128
133
129-- | This reads the pragma information directly from the provided buffer.
134-- | This reads the pragma information directly from the provided buffer.
130parsePragmasIntoDynFlags
135parsePragmasIntoDynFlags
131− :: GhcMonad m
136+ :: (ExceptionMonad m, HasDynFlags m, MonadIO m)
132 => FilePath
137 => FilePath
133 -> SB.StringBuffer
138 -> SB.StringBuffer
134 -> m (Either [FileDiagnostic] DynFlags)
139 -> m (Either [FileDiagnostic] DynFlags)
135parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do
140parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do
136− dflags0 <- getSessionDynFlags
141+ dflags0 <- getDynFlags
137 let opts = Hdr.getOptions dflags0 contents fp
142 let opts = Hdr.getOptions dflags0 contents fp
143+
144+ -- Force bits that might keep the dflags and stringBuffer alive unnecessarily
145+ liftIO $ evaluate $ rnf opts
146+
138 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
147 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
139 return dflags
148 return dflags
140
149
@@ -166,18 +175,11 @@ runLhs dflags filename contents = withTempDir $ \dir -> do
166 escape (c:cs) = c : escape cs
175 escape (c:cs) = c : escape cs
167 escape [] = []
176 escape [] = []
168
177
169−
170−modifyOptP :: ([String] -> [String]) -> DynFlags -> DynFlags
171−modifyOptP op = onSettings (onOptP op)
172− where
173− onSettings f x = x{settings = f $ settings x}
174− onOptP f x = x{sOpt_P = f $ sOpt_P x}
175−
176-- | Run CPP on a file
178-- | Run CPP on a file
177runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
179runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
178runCpp dflags filename contents = withTempDir $ \dir -> do
180runCpp dflags filename contents = withTempDir $ \dir -> do
179 let out = dir </> takeFileName filename <.> "out"
181 let out = dir </> takeFileName filename <.> "out"
180− dflags <- pure $ modifyOptP ("-D__GHCIDE__":) dflags
182+ dflags <- pure $ addOptP "-D__GHCIDE__" dflags
181
183
182 case contents of
184 case contents of
183 Nothing -> do
185 Nothing -> do
src/Development/IDE/Core/RuleTypes.hs+50−11
@@ -15,7 +15,6 @@ import Control.DeepSeq
15import Data.Binary
15import Data.Binary
16import Development.IDE.Import.DependencyInformation
16import Development.IDE.Import.DependencyInformation
17import Development.IDE.GHC.Util
17import Development.IDE.GHC.Util
18−import Development.IDE.Types.Location
19import Data.Hashable
18import Data.Hashable
20import Data.Typeable
19import Data.Typeable
21import qualified Data.Set as S
20import qualified Data.Set as S
@@ -25,9 +24,9 @@ import GHC.Generics (Generic)
25import GHC
24import GHC
26import Module (InstalledUnitId)
25import Module (InstalledUnitId)
27import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)
26import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)
28−import Development.IDE.GHC.Compat
29
27
30import Development.IDE.Spans.Type
28import Development.IDE.Spans.Type
29+import Development.IDE.Import.FindImports (ArtifactsLocation)
31
30
32
31
33-- NOTATION
32-- NOTATION
@@ -58,6 +57,22 @@ instance Show TcModuleResult where
58instance NFData TcModuleResult where
57instance NFData TcModuleResult where
59 rnf = rwhnf
58 rnf = rwhnf
60
59
60+tmrModSummary :: TcModuleResult -> ModSummary
61+tmrModSummary = pm_mod_summary . tm_parsed_module . tmrModule
62+
63+data HiFileResult = HiFileResult
64+ { hirModSummary :: !ModSummary
65+ -- Bang patterns here are important to stop the result retaining
66+ -- a reference to a typechecked module
67+ , hirModIface :: !ModIface
68+ }
69+
70+instance NFData HiFileResult where
71+ rnf = rwhnf
72+
73+instance Show HiFileResult where
74+ show = show . hirModSummary
75+
61-- | The type checked version of this file, requires TypeCheck+
76-- | The type checked version of this file, requires TypeCheck+
62type instance RuleResult TypeCheck = TcModuleResult
77type instance RuleResult TypeCheck = TcModuleResult
63
78
@@ -75,16 +90,24 @@ type instance RuleResult GhcSession = HscEnvEq
75
90
76-- | Resolve the imports in a module to the file path of a module
91-- | Resolve the imports in a module to the file path of a module
77-- in the same package or the package id of another package.
92-- in the same package or the package id of another package.
78−type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe NormalizedFilePath)], S.Set InstalledUnitId)
93+type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId)
79
94
80-- | This rule is used to report import cycles. It depends on GetDependencyInformation.
95-- | This rule is used to report import cycles. It depends on GetDependencyInformation.
81-- We cannot report the cycles directly from GetDependencyInformation since
96-- We cannot report the cycles directly from GetDependencyInformation since
82-- we can only report diagnostics for the current file.
97-- we can only report diagnostics for the current file.
83type instance RuleResult ReportImportCycles = ()
98type instance RuleResult ReportImportCycles = ()
84
99
85−-- | Read the given HIE file.
100+-- | Read the module interface file
86−type instance RuleResult GetHieFile = HieFile
101+type instance RuleResult GetHiFile = HiFileResult
102+
103+-- | Get a module interface, either from an interface file or a typechecked module
104+type instance RuleResult GetModIface = HiFileResult
87
105
106+type instance RuleResult IsFileOfInterest = Bool
107+
108+-- | Generate a ModSummary that has enough information to be used to get .hi and .hie files.
109+-- without needing to parse the entire source
110+type instance RuleResult GetModSummary = ModSummary
88
111
89data GetParsedModule = GetParsedModule
112data GetParsedModule = GetParsedModule
90 deriving (Eq, Show, Typeable, Generic)
113 deriving (Eq, Show, Typeable, Generic)
@@ -146,10 +169,26 @@ instance Hashable GhcSession
146instance NFData GhcSession
169instance NFData GhcSession
147instance Binary GhcSession
170instance Binary GhcSession
148
171
149−-- Note that we embed the filepath here instead of using the filepath associated with Shake keys.
172+data GetHiFile = GetHiFile
150−-- Otherwise we will garbage collect the result since files in package dependencies will not be declared reachable.
173+ deriving (Eq, Show, Typeable, Generic)
151−data GetHieFile = GetHieFile FilePath
174+instance Hashable GetHiFile
175+instance NFData GetHiFile
176+instance Binary GetHiFile
177+
178+data GetModIface = GetModIface
179+ deriving (Eq, Show, Typeable, Generic)
180+instance Hashable GetModIface
181+instance NFData GetModIface
182+instance Binary GetModIface
183+
184+data IsFileOfInterest = IsFileOfInterest
185+ deriving (Eq, Show, Typeable, Generic)
186+instance Hashable IsFileOfInterest
187+instance NFData IsFileOfInterest
188+instance Binary IsFileOfInterest
189+
190+data GetModSummary = GetModSummary
152 deriving (Eq, Show, Typeable, Generic)
191 deriving (Eq, Show, Typeable, Generic)
153−instance Hashable GetHieFile
192+instance Hashable GetModSummary
154−instance NFData GetHieFile
193+instance NFData GetModSummary
155−instance Binary GetHieFile
194+instance Binary GetModSummary
src/Development/IDE/Core/Rules.hs+420−118
@@ -1,16 +1,18 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4+{-# LANGUAGE CPP #-}
4−{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeFamilies #-}
5−{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE DuplicateRecordFields #-}
7{-# LANGUAGE DuplicateRecordFields #-}
8+#include "ghc-api-version.h"
7
9
8-- | A Shake implementation of the compiler service, built
10-- | A Shake implementation of the compiler service, built
9-- using the "Shaker" abstraction layer for in-memory use.
11-- using the "Shaker" abstraction layer for in-memory use.
10--
12--
11module Development.IDE.Core.Rules(
13module Development.IDE.Core.Rules(
12 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
14 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
13− Priority(..),
15+ Priority(..), GhcSessionIO(..), GhcSessionFun(..),
14 priorityTypeCheck,
16 priorityTypeCheck,
15 priorityGenerateCore,
17 priorityGenerateCore,
16 priorityFilesOfInterest,
18 priorityFilesOfInterest,
@@ -26,11 +28,13 @@ module Development.IDE.Core.Rules(
26
28
27import Fingerprint
29import Fingerprint
28
30
29−import Data.Binary
31+import Data.Binary hiding (get, put)
32+import Data.Bifunctor (first, second)
30−import Control.Monad
33+import Control.Monad.Extra
31import Control.Monad.Trans.Class
34import Control.Monad.Trans.Class
32import Control.Monad.Trans.Maybe
35import Control.Monad.Trans.Maybe
33import Development.IDE.Core.Compile
36import Development.IDE.Core.Compile
37+import Development.IDE.Core.OfInterest
34import Development.IDE.Types.Options
38import Development.IDE.Types.Options
35import Development.IDE.Spans.Calculate
39import Development.IDE.Spans.Calculate
36import Development.IDE.Import.DependencyInformation
40import Development.IDE.Import.DependencyInformation
@@ -39,34 +43,39 @@ import Development.IDE.Core.FileExists
39import Development.IDE.Core.FileStore (getFileContents)
43import Development.IDE.Core.FileStore (getFileContents)
40import Development.IDE.Types.Diagnostics
44import Development.IDE.Types.Diagnostics
41import Development.IDE.Types.Location
45import Development.IDE.Types.Location
46+import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)
42import Development.IDE.GHC.Util
47import Development.IDE.GHC.Util
43−import Data.Coerce
48+import Development.IDE.GHC.WithDynFlags
44import Data.Either.Extra
49import Data.Either.Extra
45import Data.Maybe
50import Data.Maybe
46import Data.Foldable
51import Data.Foldable
47import qualified Data.IntMap.Strict as IntMap
52import qualified Data.IntMap.Strict as IntMap
48−import qualified Data.IntSet as IntSet
53+import Data.IntMap.Strict (IntMap)
49import Data.List
54import Data.List
55+import Data.Ord
50import qualified Data.Set as Set
56import qualified Data.Set as Set
51import qualified Data.Text as T
57import qualified Data.Text as T
52import Development.IDE.GHC.Error
58import Development.IDE.GHC.Error
53import Development.Shake hiding (Diagnostic)
59import Development.Shake hiding (Diagnostic)
54import Development.IDE.Core.RuleTypes
60import Development.IDE.Core.RuleTypes
55import Development.IDE.Spans.Type
61import Development.IDE.Spans.Type
62+import qualified Data.ByteString.Char8 as BS
56
63
57−import GHC hiding (parseModule, typecheckModule)
58import qualified GHC.LanguageExtensions as LangExt
64import qualified GHC.LanguageExtensions as LangExt
59−import Development.IDE.GHC.Compat (hie_file_result, readHieFile)
60−import UniqSupply
61−import NameCache
62import HscTypes
65import HscTypes
66+import PackageConfig
63−import DynFlags (xopt)
67+import DynFlags (gopt_set, xopt)
64import GHC.Generics(Generic)
68import GHC.Generics(Generic)
65
69
66import qualified Development.IDE.Spans.AtPoint as AtPoint
70import qualified Development.IDE.Spans.AtPoint as AtPoint
67import Development.IDE.Core.Service
71import Development.IDE.Core.Service
68import Development.IDE.Core.Shake
72import Development.IDE.Core.Shake
69−import Development.Shake.Classes
73+import Development.Shake.Classes hiding (get, put)
74+import Control.Monad.Trans.Except (runExceptT)
75+import Data.ByteString (ByteString)
76+import Control.Concurrent.Async (concurrently)
77+
78+import Control.Monad.State
70
79
71-- | This is useful for rules to convert rules that can only produce errors or
80-- | This is useful for rules to convert rules that can only produce errors or
72-- a result into the more general IdeResult type that supports producing
81-- a result into the more general IdeResult type that supports producing
@@ -80,14 +89,14 @@ useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v
80useE k = MaybeT . use k
89useE k = MaybeT . use k
81
90
82useNoFileE :: IdeRule k v => k -> MaybeT Action v
91useNoFileE :: IdeRule k v => k -> MaybeT Action v
83−useNoFileE k = useE k ""
92+useNoFileE k = useE k emptyFilePath
84
93
85usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
94usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
86usesE k = MaybeT . fmap sequence . uses k
95usesE k = MaybeT . fmap sequence . uses k
87
96
88defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
97defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
89defineNoFile f = define $ \k file -> do
98defineNoFile f = define $ \k file -> do
90− if file == "" then do res <- f k; return ([], Just res) else
99+ if file == emptyFilePath then do res <- f k; return ([], Just res) else
91 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
100 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
92
101
93
102
@@ -111,9 +120,58 @@ getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
111getDefinition file pos = fmap join $ runMaybeT $ do
120getDefinition file pos = fmap join $ runMaybeT $ do
112 opts <- lift getIdeOptions
121 opts <- lift getIdeOptions
113 spans <- useE GetSpanInfo file
122 spans <- useE GetSpanInfo file
114− pkgState <- hscEnv <$> useE GhcSession file
115− let getHieFile x = useNoFile (GetHieFile x)
116− lift $ AtPoint.gotoDefinition getHieFile opts pkgState (spansExprs spans) pos
123+ lift $ AtPoint.gotoDefinition (getHieFile file) opts (spansExprs spans) pos
124+
125+getHieFile
126+ :: NormalizedFilePath -- ^ file we're editing
127+ -> Module -- ^ module dep we want info for
128+ -> Action (Maybe (HieFile, FilePath)) -- ^ hie stuff for the module
129+getHieFile file mod = do
130+ TransitiveDependencies {transitiveNamedModuleDeps} <- use_ GetDependencies file
131+ case find (\x -> nmdModuleName x == moduleName mod) transitiveNamedModuleDeps of
132+ Just NamedModuleDep{nmdFilePath=nfp} -> do
133+ let modPath = fromNormalizedFilePath nfp
134+ (_diags, hieFile) <- getHomeHieFile nfp
135+ return $ (, modPath) <$> hieFile
136+ _ -> getPackageHieFile mod file
137+
138+
139+getHomeHieFile :: NormalizedFilePath -> Action ([a], Maybe HieFile)
140+getHomeHieFile f = do
141+ ms <- use_ GetModSummary f
142+ let normal_hie_f = toNormalizedFilePath' hie_f
143+ hie_f = ml_hie_file $ ms_location ms
144+ mbHieTimestamp <- use GetModificationTime normal_hie_f
145+ srcTimestamp <- use_ GetModificationTime f
146+ let isUpToDate
147+ | Just d <- mbHieTimestamp = comparing modificationTime d srcTimestamp == GT
148+ | otherwise = False
149+
150+ unless isUpToDate $
151+ void $ use_ TypeCheck f
152+
153+ hf <- liftIO $ whenMaybe isUpToDate (loadHieFile hie_f)
154+ return ([], hf)
155+
156+getPackageHieFile :: Module -- ^ Package Module to load .hie file for
157+ -> NormalizedFilePath -- ^ Path of home module importing the package module
158+ -> Action (Maybe (HieFile, FilePath))
159+getPackageHieFile mod file = do
160+ pkgState <- hscEnv <$> use_ GhcSession file
161+ IdeOptions {..} <- getIdeOptions
162+ let unitId = moduleUnitId mod
163+ case lookupPackageConfig unitId pkgState of
164+ Just pkgConfig -> do
165+ -- 'optLocateHieFile' returns Nothing if the file does not exist
166+ hieFile <- liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod
167+ path <- liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod
168+ case (hieFile, path) of
169+ (Just hiePath, Just modPath) ->
170+ -- deliberately loaded outside the Shake graph
171+ -- to avoid dependencies on non-workspace files
172+ liftIO $ Just . (, modPath) <$> loadHieFile hiePath
173+ _ -> return Nothing
174+ _ -> return Nothing
117
175
118-- | Parse the contents of a daml file.
176-- | Parse the contents of a daml file.
119getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
177getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
@@ -133,31 +191,60 @@ priorityFilesOfInterest :: Priority
133priorityFilesOfInterest = Priority (-2)
191priorityFilesOfInterest = Priority (-2)
134
192
135getParsedModuleRule :: Rules ()
193getParsedModuleRule :: Rules ()
136−getParsedModuleRule =
137− defineEarlyCutoff $ \GetParsedModule file -> do
194+getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
138− (_, contents) <- getFileContents file
139− packageState <- hscEnv <$> use_ GhcSession file
195+ sess <- use_ GhcSession file
196+ let hsc = hscEnv sess
197+ -- These packages are used when removing PackageImports from a
198+ -- parsed module
199+ comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)
140− opt <- getIdeOptions
200+ opt <- getIdeOptions
201+ (_, contents) <- getFileContents file
202+
203+ let dflags = hsc_dflags hsc
204+ mainParse = getParsedModuleDefinition hsc opt comp_pkgs file contents
205+
206+ -- Parse again (if necessary) to capture Haddock parse errors
207+ if gopt Opt_Haddock dflags
208+ then
209+ liftIO mainParse
210+ else do
211+ let hscHaddock = hsc{hsc_dflags = gopt_set dflags Opt_Haddock}
212+ haddockParse = do
213+ (_, (!diagsHaddock, _)) <-
214+ getParsedModuleDefinition hscHaddock opt comp_pkgs file contents
215+ return diagsHaddock
216+
217+ ((fingerPrint, (diags, res)), diagsHaddock) <-
218+ -- parse twice, with and without Haddocks, concurrently
219+ -- we cannot ignore Haddock parse errors because files of
220+ -- non-interest are always parsed with Haddocks
221+ liftIO $ concurrently mainParse haddockParse
222+
223+ return (fingerPrint, (mergeDiagnostics diags diagsHaddock, res))
224+
225+getParsedModuleDefinition :: HscEnv -> IdeOptions -> [PackageName] -> NormalizedFilePath -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))
226+getParsedModuleDefinition packageState opt comp_pkgs file contents = do
141− (diag, res) <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents
227+ (diag, res) <- parseModule opt packageState comp_pkgs (fromNormalizedFilePath file) (fmap textToStringBuffer contents)
142− case res of
228+ case res of
143− Nothing -> pure (Nothing, (diag, Nothing))
229+ Nothing -> pure (Nothing, (diag, Nothing))
144− Just (contents, modu) -> do
230+ Just (contents, modu) -> do
145− mbFingerprint <- if isNothing $ optShakeFiles opt
231+ mbFingerprint <- if isNothing $ optShakeFiles opt
146− then pure Nothing
232+ then pure Nothing
147− else liftIO $ Just . fingerprintToBS <$> fingerprintFromStringBuffer contents
233+ else Just . fingerprintToBS <$> fingerprintFromStringBuffer contents
148− pure (mbFingerprint, (diag, Just modu))
234+ pure (mbFingerprint, (diag, Just modu))
149
235
150getLocatedImportsRule :: Rules ()
236getLocatedImportsRule :: Rules ()
151getLocatedImportsRule =
237getLocatedImportsRule =
152 define $ \GetLocatedImports file -> do
238 define $ \GetLocatedImports file -> do
153− pm <- use_ GetParsedModule file
239+ ms <- use_ GetModSummary file
154− let ms = pm_mod_summary pm
155 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
240 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
156− env <- hscEnv <$> use_ GhcSession file
241+ env_eq <- use_ GhcSession file
242+ let env = hscEnv env_eq
243+ let import_dirs = deps env_eq
157− let dflags = addRelativeImport file pm $ hsc_dflags env
244+ let dflags = addRelativeImport file (moduleName $ ms_mod ms) $ hsc_dflags env
158 opt <- getIdeOptions
245 opt <- getIdeOptions
159 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
246 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
160− diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource
247+ diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getFileExists modName mbPkgName isSource
161 case diagOrImp of
248 case diagOrImp of
162 Left diags -> pure (diags, Left (modName, Nothing))
249 Left diags -> pure (diags, Left (modName, Nothing))
163 Right (FileImport path) -> pure ([], Left (modName, Just path))
250 Right (FileImport path) -> pure ([], Left (modName, Just path))
@@ -171,48 +258,109 @@ getLocatedImportsRule =
171 Nothing -> pure (concat diags, Nothing)
258 Nothing -> pure (concat diags, Nothing)
172 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))
259 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))
173
260
261+type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a
262+
263+execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1)
264+execRawDepM act =
265+ execStateT act
266+ ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty
267+ , IntMap.empty
268+ )
174
269
175-- | Given a target file path, construct the raw dependency results by following
270-- | Given a target file path, construct the raw dependency results by following
176-- imports recursively.
271-- imports recursively.
177−rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation
272+rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation
178−rawDependencyInformation f = do
273+rawDependencyInformation fs = do
179− let (initialId, initialMap) = getPathId f emptyPathIdMap
274+ (rdi, ss) <- execRawDepM (mapM_ go fs)
180− go (IntSet.singleton $ getFilePathId initialId)
275+ let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss
181− (RawDependencyInformation IntMap.empty initialMap)
276+ return (rdi { rawBootMap = bm })
182 where
277 where
183− go fs rawDepInfo =
278+ go :: NormalizedFilePath -- ^ Current module being processed
184− case IntSet.minView fs of
279+ -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId
185− -- Queue is empty
280+ go f = do
186− Nothing -> pure rawDepInfo
281+ -- First check to see if we have already processed the FilePath
187− -- Pop f from the queue and process it
282+ -- If we have, just return its Id but don't update any of the state.
188− Just (f, fs) -> do
283+ -- Otherwise, we need to process its imports.
189− let fId = FilePathId f
284+ checkAlreadyProcessed f $ do
285+ al <- lift $ modSummaryToArtifactsLocation f <$> use_ GetModSummary f
286+ -- Get a fresh FilePathId for the new file
287+ fId <- getFreshFid al
288+ -- Adding an edge to the bootmap so we can make sure to
289+ -- insert boot nodes before the real files.
290+ addBootMap al fId
291+ -- Try to parse the imports of the file
190− importsOrErr <- use GetLocatedImports $ idToPath (rawPathIdMap rawDepInfo) fId
292+ importsOrErr <- lift $ use GetLocatedImports f
191− case importsOrErr of
293+ case importsOrErr of
192− Nothing ->
294+ Nothing -> do
193− -- File doesn’t parse
295+ -- File doesn't parse so add the module as a failure into the
296+ -- dependency information, continue processing the other
297+ -- elements in the queue
194− let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo
298+ modifyRawDepInfo (insertImport fId (Left ModuleParseError))
195− in go fs rawDepInfo'
299+ return fId
196− Just (modImports, pkgImports) -> do
300+ Just (modImports, pkgImports) -> do
197− let f :: PathIdMap -> (a, Maybe NormalizedFilePath) -> (PathIdMap, (a, Maybe FilePathId))
301+ -- Get NFPs of the imports which have corresponding files
198− f pathMap (imp, mbPath) = case mbPath of
302+ -- Imports either come locally from a file or from a package.
199− Nothing -> (pathMap, (imp, Nothing))
303+ let (no_file, with_file) = splitImports modImports
200− Just path ->
304+ (mns, ls) = unzip with_file
201− let (pathId, pathMap') = getPathId path pathMap
305+ -- Recursively process all the imports we just learnt about
202− in (pathMap', (imp, Just pathId))
306+ -- and get back a list of their FilePathIds
203− -- Convert paths in imports to ids and update the path map
307+ fids <- mapM (go . artifactFilePath) ls
204− let (pathIdMap, modImports') = mapAccumL f (rawPathIdMap rawDepInfo) modImports
308+ -- Associate together the ModuleName with the FilePathId
205− -- Files that we haven’t seen before are added to the queue.
309+ let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids)
206− let newFiles =
310+ -- Insert into the map the information about this modules
207− IntSet.fromList (coerce $ mapMaybe snd modImports')
311+ -- imports.
208− IntSet.\\ IntMap.keysSet (rawImports rawDepInfo)
209− let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo
312+ modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports' pkgImports)
210− go (newFiles `IntSet.union` fs) (rawDepInfo' { rawPathIdMap = pathIdMap })
313+ return fId
314+
315+
316+ checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId
317+ checkAlreadyProcessed nfp k = do
318+ (rawDepInfo, _) <- get
319+ maybe k return (lookupPathToId (rawPathIdMap rawDepInfo) nfp)
320+
321+ modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation) -> RawDepM ()
322+ modifyRawDepInfo f = modify (first f)
323+
324+ addBootMap :: ArtifactsLocation -> FilePathId -> RawDepM ()
325+ addBootMap al fId =
326+ modify (\(rd, ss) -> (rd, if isBootLocation al
327+ then IntMap.insert (getFilePathId fId) al ss
328+ else ss))
329+
330+ getFreshFid :: ArtifactsLocation -> RawDepM FilePathId
331+ getFreshFid al = do
332+ (rawDepInfo, ss) <- get
333+ let (fId, path_map) = getPathId al (rawPathIdMap rawDepInfo)
334+ -- Insert the File into the bootmap if it's a boot module
335+ let rawDepInfo' = rawDepInfo { rawPathIdMap = path_map }
336+ put (rawDepInfo', ss)
337+ return fId
338+
339+ -- Split in (package imports, local imports)
340+ splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)]
341+ -> ([Located ModuleName], [(Located ModuleName, ArtifactsLocation)])
342+ splitImports = foldr splitImportsLoop ([],[])
343+
344+ splitImportsLoop (imp, Nothing) (ns, ls) = (imp:ns, ls)
345+ splitImportsLoop (imp, Just artifact) (ns, ls) = (ns, (imp,artifact) : ls)
346+
347+ updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =
348+ if not artifactIsSource
349+ then
350+ let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix artifactModLocation)
351+ in case msource_mod_id of
352+ Just source_mod_id -> insertBootId source_mod_id (FilePathId boot_mod_id) bm
353+ Nothing -> bm
354+ else bm
355+
356+ dropBootSuffix :: ModLocation -> FilePath
357+ dropBootSuffix (ModLocation (Just hs_src) _ _) = reverse . drop (length @[] "-boot") . reverse $ hs_src
358+ dropBootSuffix _ = error "dropBootSuffix"
211
359
212getDependencyInformationRule :: Rules ()
360getDependencyInformationRule :: Rules ()
213getDependencyInformationRule =
361getDependencyInformationRule =
214 define $ \GetDependencyInformation file -> do
362 define $ \GetDependencyInformation file -> do
215− rawDepInfo <- rawDependencyInformation file
363+ rawDepInfo <- rawDependencyInformation [file]
216 pure ([], Just $ processDependencyInformation rawDepInfo)
364 pure ([], Just $ processDependencyInformation rawDepInfo)
217
365
218reportImportCyclesRule :: Rules ()
366reportImportCyclesRule :: Rules ()
@@ -240,12 +388,13 @@ reportImportCyclesRule =
240 , _message = "Cyclic module dependency between " <> showCycle mods
388 , _message = "Cyclic module dependency between " <> showCycle mods
241 , _code = Nothing
389 , _code = Nothing
242 , _relatedInformation = Nothing
390 , _relatedInformation = Nothing
391+ , _tags = Nothing
243 }
392 }
244 where loc = srcSpanToLocation (getLoc imp)
393 where loc = srcSpanToLocation (getLoc imp)
245− fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)
394+ fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp)
246 getModuleName file = do
395 getModuleName file = do
247− pm <- use_ GetParsedModule file
396+ ms <- use_ GetModSummary file
248− pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)
397+ pure (moduleNameString . moduleName . ms_mod $ ms)
249 showCycle mods = T.intercalate ", " (map T.pack mods)
398 showCycle mods = T.intercalate ", " (map T.pack mods)
250
399
251-- returns all transitive dependencies in topological order.
400-- returns all transitive dependencies in topological order.
@@ -253,7 +402,7 @@ reportImportCyclesRule =
253getDependenciesRule :: Rules ()
402getDependenciesRule :: Rules ()
254getDependenciesRule =
403getDependenciesRule =
255 defineEarlyCutoff $ \GetDependencies file -> do
404 defineEarlyCutoff $ \GetDependencies file -> do
256− depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file
405+ depInfo <- use_ GetDependencyInformation file
257 let allFiles = reachableModules depInfo
406 let allFiles = reachableModules depInfo
258 _ <- uses_ ReportImportCycles allFiles
407 _ <- uses_ ReportImportCycles allFiles
259 opts <- getIdeOptions
408 opts <- getIdeOptions
@@ -265,50 +414,101 @@ getSpanInfoRule :: Rules ()
265getSpanInfoRule =
414getSpanInfoRule =
266 define $ \GetSpanInfo file -> do
415 define $ \GetSpanInfo file -> do
267 tc <- use_ TypeCheck file
416 tc <- use_ TypeCheck file
268− deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file
269− tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)
270− (fileImports, _) <- use_ GetLocatedImports file
271 packageState <- hscEnv <$> use_ GhcSession file
417 packageState <- hscEnv <$> use_ GhcSession file
418+ deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
419+ let tdeps = transitiveModuleDeps deps
420+
421+-- When possible, rely on the haddocks embedded in our interface files
422+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'
423+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
424+ let parsedDeps = []
425+#else
426+ parsedDeps <- uses_ GetParsedModule tdeps
427+#endif
428+
429+ ifaces <- uses_ GetModIface tdeps
430+ (fileImports, _) <- use_ GetLocatedImports file
431+ let imports = second (fmap artifactFilePath) <$> fileImports
272− x <- liftIO $ getSrcSpanInfos packageState fileImports tc tms
432+ x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps (map hirModIface ifaces)
273 return ([], Just x)
433 return ([], Just x)
274
434
275-- Typechecks a module.
435-- Typechecks a module.
276typeCheckRule :: Rules ()
436typeCheckRule :: Rules ()
277−typeCheckRule =
278− define $ \TypeCheck file -> do
437+typeCheckRule = define $ \TypeCheck file -> do
279− pm <- use_ GetParsedModule file
438+ pm <- use_ GetParsedModule file
439+ -- do not generate interface files as this rule is called
440+ -- for files of interest on every keystroke
441+ typeCheckRuleDefinition file pm SkipGenerationOfInterfaceFiles
442+
443+data GenerateInterfaceFiles
444+ = DoGenerateInterfaceFiles
445+ | SkipGenerationOfInterfaceFiles
446+ deriving (Show)
447+
448+-- This is factored out so it can be directly called from the GetModIface
449+-- rule. Directly calling this rule means that on the initial load we can
450+-- garbage collect all the intermediate typechecked modules rather than
451+-- retain the information forever in the shake graph.
452+typeCheckRuleDefinition
453+ :: NormalizedFilePath -- ^ Path to source file
454+ -> ParsedModule
455+ -> GenerateInterfaceFiles -- ^ Should generate .hi and .hie files ?
456+ -> Action (IdeResult TcModuleResult)
457+typeCheckRuleDefinition file pm generateArtifacts = do
280− deps <- use_ GetDependencies file
458+ deps <- use_ GetDependencies file
281− packageState <- hscEnv <$> use_ GhcSession file
459+ hsc <- hscEnv <$> use_ GhcSession file
282− -- Figure out whether we need TemplateHaskell or QuasiQuotes support
460+ -- Figure out whether we need TemplateHaskell or QuasiQuotes support
283− let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph packageState
461+ let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc
284− file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)
462+ file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)
285− any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq
463+ any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq
464+ mirs <- uses_ GetModIface (transitiveModuleDeps deps)
286− tms <- if any_uses_th_qq
465+ bytecodes <- if any_uses_th_qq
287− -- If we use TH or QQ, we must obtain the bytecode
466+ then -- If we use TH or QQ, we must obtain the bytecode
288− then do
289− bytecodes <- uses_ GenerateByteCode (transitiveModuleDeps deps)
467+ fmap Just <$> uses_ GenerateByteCode (transitiveModuleDeps deps)
290− tmrs <- uses_ TypeCheck (transitiveModuleDeps deps)
468+ else
291− pure (zipWith addByteCode bytecodes tmrs)
469+ pure $ repeat Nothing
292− else uses_ TypeCheck (transitiveModuleDeps deps)
470+
293− setPriority priorityTypeCheck
471+ setPriority priorityTypeCheck
294− IdeOptions{ optDefer = defer} <- getIdeOptions
472+ IdeOptions { optDefer = defer } <- getIdeOptions
473+
474+ addUsageDependencies $ liftIO $ do
295− liftIO $ typecheckModule defer packageState tms pm
475+ res <- typecheckModule defer hsc (zipWith unpack mirs bytecodes) pm
476+ case res of
477+ (diags, Just (hsc,tcm)) | DoGenerateInterfaceFiles <- generateArtifacts -> do
478+ diagsHie <- generateAndWriteHieFile hsc (tmrModule tcm)
479+ diagsHi <- generateAndWriteHiFile hsc tcm
480+ return (diags <> diagsHi <> diagsHie, Just tcm)
481+ (diags, res) ->
482+ return (diags, snd <$> res)
296− where
483+ where
484+ unpack HiFileResult{..} bc = (hirModSummary, (hirModIface, bc))
485+ uses_th_qq dflags =
297− uses_th_qq dflags = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
486+ xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
487+
298− addByteCode :: Linkable -> TcModuleResult -> TcModuleResult
488+ addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)
299− addByteCode lm tmr = tmr { tmrModInfo = (tmrModInfo tmr) { hm_linkable = Just lm } }
489+ addUsageDependencies a = do
300−
490+ r@(_, mtc) <- a
491+ forM_ mtc $ \tc -> do
492+ let used_files = mapMaybe udep (mi_usages (hm_iface (tmrModInfo tc)))
493+ udep (UsageFile fp _h) = Just fp
494+ udep _ = Nothing
495+ -- Add a dependency on these files which are added by things like
496+ -- qAddDependentFile
497+ void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files)
498+ return r
499+
500+
301−generateCore :: NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
501+generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
302−generateCore file = do
502+generateCore runSimplifier file = do
303 deps <- use_ GetDependencies file
503 deps <- use_ GetDependencies file
304 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
504 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
305 setPriority priorityGenerateCore
505 setPriority priorityGenerateCore
306 packageState <- hscEnv <$> use_ GhcSession file
506 packageState <- hscEnv <$> use_ GhcSession file
307− liftIO $ compileModule packageState tms tm
507+ liftIO $ compileModule runSimplifier packageState [(tmrModSummary x, tmrModInfo x) | x <- tms] tm
308
508
309generateCoreRule :: Rules ()
509generateCoreRule :: Rules ()
310generateCoreRule =
510generateCoreRule =
311− define $ \GenerateCore -> generateCore
511+ define $ \GenerateCore -> generateCore (RunSimplifier True)
312
512
313generateByteCodeRule :: Rules ()
513generateByteCodeRule :: Rules ()
314generateByteCodeRule =
514generateByteCodeRule =
@@ -317,7 +517,7 @@ generateByteCodeRule =
317 (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)
517 (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)
318 session <- hscEnv <$> use_ GhcSession file
518 session <- hscEnv <$> use_ GhcSession file
319 (_, guts, _) <- use_ GenerateCore file
519 (_, guts, _) <- use_ GenerateCore file
320− liftIO $ generateByteCode session tms tm guts
520+ liftIO $ generateByteCode session [(tmrModSummary x, tmrModInfo x) | x <- tms] tm guts
321
521
322-- A local rule type to get caching. We want to use newCache, but it has
522-- A local rule type to get caching. We want to use newCache, but it has
323-- thread killed exception issues, so we lift it to a full rule.
523-- thread killed exception issues, so we lift it to a full rule.
@@ -329,7 +529,7 @@ instance Hashable GhcSessionIO
329instance NFData GhcSessionIO
529instance NFData GhcSessionIO
330instance Binary GhcSessionIO
530instance Binary GhcSessionIO
331
531
332−newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq)
532+newtype GhcSessionFun = GhcSessionFun (FilePath -> Action (IdeResult HscEnvEq))
333instance Show GhcSessionFun where show _ = "GhcSessionFun"
533instance Show GhcSessionFun where show _ = "GhcSessionFun"
334instance NFData GhcSessionFun where rnf !_ = ()
534instance NFData GhcSessionFun where rnf !_ = ()
335
535
@@ -338,20 +538,119 @@ loadGhcSession :: Rules ()
338loadGhcSession = do
538loadGhcSession = do
339 defineNoFile $ \GhcSessionIO -> do
539 defineNoFile $ \GhcSessionIO -> do
340 opts <- getIdeOptions
540 opts <- getIdeOptions
341− liftIO $ GhcSessionFun <$> optGhcSession opts
541+ GhcSessionFun <$> optGhcSession opts
542+ -- This function should always be rerun because it consults a cache to
543+ -- see what HscEnv needs to be used for the file, which can change.
544+ -- However, it should also cut-off early if it's the same HscEnv as
545+ -- last time
342 defineEarlyCutoff $ \GhcSession file -> do
546 defineEarlyCutoff $ \GhcSession file -> do
343 GhcSessionFun fun <- useNoFile_ GhcSessionIO
547 GhcSessionFun fun <- useNoFile_ GhcSessionIO
548+ alwaysRerun
344 val <- fun $ fromNormalizedFilePath file
549 val <- fun $ fromNormalizedFilePath file
345− opts <- getIdeOptions
346− return ("" <$ optShakeFiles opts, ([], Just val))
347
550
551+ -- TODO: What was this doing before?
552+ opts <- getIdeOptions
553+ let cutoffHash =
554+ case optShakeFiles opts of
555+ -- optShakeFiles is only set in the DAML case.
556+ -- https://github.com/digital-asset/ghcide/pull/522#discussion_r428622915
557+ Just {} -> ""
558+ -- Hash the HscEnvEq returned so cutoff if it didn't change
559+ -- from last time
560+ Nothing -> BS.pack (show (hash (snd val)))
561+ return (Just cutoffHash, val)
562+
563+getHiFileRule :: Rules ()
564+getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do
565+ -- get all dependencies interface files, to check for freshness
566+ (deps,_) <- use_ GetLocatedImports f
567+ depHis <- traverse (use GetHiFile) (mapMaybe (fmap artifactFilePath . snd) deps)
568+
569+ ms <- use_ GetModSummary f
570+ let hiFile = toNormalizedFilePath'
571+ $ case ms_hsc_src ms of
572+ HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)
573+ _ -> ml_hi_file $ ms_location ms
574+
575+ case sequence depHis of
576+ Nothing -> pure (Nothing, ([], Nothing))
577+ Just deps -> do
578+ gotHiFile <- getFileExists hiFile
579+ if not gotHiFile
580+ then pure (Nothing, ([], Nothing))
581+ else do
582+ hiVersion <- use_ GetModificationTime hiFile
583+ modVersion <- use_ GetModificationTime f
584+ let sourceModified = modificationTime hiVersion < modificationTime modVersion
585+ if sourceModified
586+ then do
587+ pure (Nothing, ([], Nothing))
588+ else do
589+ session <- hscEnv <$> use_ GhcSession f
590+ r <- liftIO $ loadInterface session ms deps
591+ case r of
592+ Right iface -> do
593+ let result = HiFileResult ms iface
594+ return (Just (fingerprintToBS (getModuleHash iface)), ([], Just result))
595+ Left err -> do
596+ let diag = ideErrorWithSource (Just "interface file loading") (Just DsError) f . T.pack $ err
597+ return (Nothing, (pure diag, Nothing))
598+
599+getModSummaryRule :: Rules ()
600+getModSummaryRule = define $ \GetModSummary f -> do
601+ dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f
602+ (_, mFileContent) <- getFileContents f
603+ modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $
604+ getModSummaryFromImports (fromNormalizedFilePath f) (textToStringBuffer <$> mFileContent)
605+ return $ either (,Nothing) (([], ) . Just) modS
606+
607+getModIfaceRule :: Rules ()
608+getModIfaceRule = define $ \GetModIface f -> do
609+ fileOfInterest <- use_ IsFileOfInterest f
610+ let useHiFile =
611+ -- Never load interface files for files of interest
612+ not fileOfInterest
613+ mbHiFile <- if useHiFile then use GetHiFile f else return Nothing
614+ case mbHiFile of
615+ Just x ->
616+ return ([], Just x)
617+ Nothing
618+ | fileOfInterest -> do
619+ -- For files of interest only, create a Shake dependency on typecheck
620+ tmr <- use TypeCheck f
621+ return ([], extract tmr)
622+ | otherwise -> do
623+ -- the interface file does not exist or is out of date.
624+ -- Invoke typechecking directly to update it without incurring a dependency
625+ -- on the parsed module and the typecheck rules
626+ sess <- use_ GhcSession f
627+ let hsc = hscEnv sess
628+ -- After parsing the module remove all package imports referring to
629+ -- these packages as we have already dealt with what they map to.
630+ comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)
631+ opt <- getIdeOptions
632+ (_, contents) <- getFileContents f
633+ -- Embed --haddocks in the interface file
634+ hsc <- pure hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock}
635+ (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f contents
636+ case mb_pm of
637+ Nothing -> return (diags, Nothing)
638+ Just pm -> do
639+ (diags', tmr) <- typeCheckRuleDefinition f pm DoGenerateInterfaceFiles
640+ -- Bang pattern is important to avoid leaking 'tmr'
641+ let !res = extract tmr
642+ return (diags <> diags', res)
643+ where
644+ extract Nothing = Nothing
645+ extract (Just tmr) =
646+ -- Bang patterns are important to force the inner fields
647+ Just $! HiFileResult (tmrModSummary tmr) (hm_iface $ tmrModInfo tmr)
348
648
349−getHieFileRule :: Rules ()
649+isFileOfInterestRule :: Rules ()
350−getHieFileRule =
650+isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do
351− defineNoFile $ \(GetHieFile f) -> do
651+ filesOfInterest <- getFilesOfInterest
352− u <- liftIO $ mkSplitUniqSupply 'a'
652+ let res = f `elem` filesOfInterest
353− let nameCache = initNameCache u []
653+ return (Just (if res then "1" else ""), ([], Just res))
354− liftIO $ fmap (hie_file_result . fst) $ readHieFile nameCache f
355
654
356-- | A rule that wires per-file rules together
655-- | A rule that wires per-file rules together
357mainRule :: Rules ()
656mainRule :: Rules ()
@@ -366,4 +665,7 @@ mainRule = do
366 generateCoreRule
665 generateCoreRule
367 generateByteCodeRule
666 generateByteCodeRule
368 loadGhcSession
667 loadGhcSession
369− getHieFileRule
668+ getHiFileRule
669+ getModIfaceRule
670+ isFileOfInterestRule
671+ getModSummaryRule
src/Development/IDE/Core/Service.hs+4−1
@@ -23,6 +23,7 @@ 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
26import Development.IDE.Core.FileStore (VFSHandle, fileStoreRules)
27import Development.IDE.Core.FileStore (VFSHandle, fileStoreRules)
27import Development.IDE.Core.FileExists (fileExistsRules)
28import Development.IDE.Core.FileExists (fileExistsRules)
28import Development.IDE.Core.OfInterest
29import Development.IDE.Core.OfInterest
@@ -49,14 +50,16 @@ initialise :: LSP.ClientCapabilities
49 -> IO LSP.LspId
50 -> IO LSP.LspId
50 -> (LSP.FromServerMessage -> IO ())
51 -> (LSP.FromServerMessage -> IO ())
51 -> Logger
52 -> Logger
53+ -> Debouncer LSP.NormalizedUri
52 -> IdeOptions
54 -> IdeOptions
53 -> VFSHandle
55 -> VFSHandle
54 -> IO IdeState
56 -> IO IdeState
55−initialise caps mainRule getLspId toDiags logger options vfs =
57+initialise caps mainRule getLspId toDiags logger debouncer options vfs =
56 shakeOpen
58 shakeOpen
57 getLspId
59 getLspId
58 toDiags
60 toDiags
59 logger
61 logger
62+ debouncer
60 (optShakeProfiling options)
63 (optShakeProfiling options)
61 (optReportProgress options)
64 (optReportProgress options)
62 shakeOptions
65 shakeOptions
src/Development/IDE/Core/Shake.hs+143−114
@@ -19,8 +19,8 @@
19-- always stored as real Haskell values, whereas Shake serialises all 'A' values
19-- always stored as real Haskell values, whereas Shake serialises all 'A' values
20-- between runs. To deserialise a Shake value, we just consult Values.
20-- between runs. To deserialise a Shake value, we just consult Values.
21module Development.IDE.Core.Shake(
21module Development.IDE.Core.Shake(
22− IdeState,
22+ IdeState, shakeExtras,
23− ShakeExtras(..), getShakeExtras,
23+ ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
24 IdeRule, IdeResult, GetModificationTime(..),
24 IdeRule, IdeResult, GetModificationTime(..),
25 shakeOpen, shakeShut,
25 shakeOpen, shakeShut,
26 shakeRun,
26 shakeRun,
@@ -30,13 +30,13 @@ module Development.IDE.Core.Shake(
30 define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,
30 define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,
31 getDiagnostics, unsafeClearDiagnostics,
31 getDiagnostics, unsafeClearDiagnostics,
32 getHiddenDiagnostics,
32 getHiddenDiagnostics,
33− IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
33+ IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,
34 garbageCollect,
34 garbageCollect,
35 setPriority,
35 setPriority,
36 sendEvent,
36 sendEvent,
37 ideLogger,
37 ideLogger,
38 actionLogger,
38 actionLogger,
39− FileVersion(..),
39+ FileVersion(..), modificationTime,
40 Priority(..),
40 Priority(..),
41 updatePositionMapping,
41 updatePositionMapping,
42 deleteValue,
42 deleteValue,
@@ -49,12 +49,11 @@ import Development.Shake.Classes
49import Development.Shake.Rule
49import Development.Shake.Rule
50import qualified Data.HashMap.Strict as HMap
50import qualified Data.HashMap.Strict as HMap
51import qualified Data.Map.Strict as Map
51import qualified Data.Map.Strict as Map
52−import qualified Data.Map.Merge.Strict as Map
53import qualified Data.ByteString.Char8 as BS
52import qualified Data.ByteString.Char8 as BS
54import Data.Dynamic
53import Data.Dynamic
55import Data.Maybe
54import Data.Maybe
56import Data.Map.Strict (Map)
55import Data.Map.Strict (Map)
57−import Data.List.Extra (foldl', partition, takeEnd)
56+import Data.List.Extra (partition, takeEnd)
58import qualified Data.Set as Set
57import qualified Data.Set as Set
59import qualified Data.Text as T
58import qualified Data.Text as T
60import Data.Traversable (for)
59import Data.Traversable (for)
@@ -70,7 +69,7 @@ import Development.IDE.Types.Location
70import Development.IDE.Types.Options
69import Development.IDE.Types.Options
71import Control.Concurrent.Async
70import Control.Concurrent.Async
72import Control.Concurrent.Extra
71import Control.Concurrent.Extra
73−import Control.Exception
72+import Control.Exception.Extra
74import Control.DeepSeq
73import Control.DeepSeq
75import System.Time.Extra
74import System.Time.Extra
76import Data.Typeable
75import Data.Typeable
@@ -95,12 +94,16 @@ data ShakeExtras = ShakeExtras
95 ,state :: Var Values
94 ,state :: Var Values
96 ,diagnostics :: Var DiagnosticStore
95 ,diagnostics :: Var DiagnosticStore
97 ,hiddenDiagnostics :: Var DiagnosticStore
96 ,hiddenDiagnostics :: Var DiagnosticStore
98− ,publishedDiagnostics :: Var (Map NormalizedUri [Diagnostic])
97+ ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])
99 -- ^ This represents the set of diagnostics that we have published.
98 -- ^ This represents the set of diagnostics that we have published.
100 -- Due to debouncing not every change might get published.
99 -- Due to debouncing not every change might get published.
101− ,positionMapping :: Var (Map NormalizedUri (Map TextDocumentVersion PositionMapping))
100+ ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))
102 -- ^ Map from a text document version to a PositionMapping that describes how to map
101 -- ^ Map from a text document version to a PositionMapping that describes how to map
103 -- positions in a version of that document to positions in the latest version
102 -- positions in a version of that document to positions in the latest version
103+ -- First mapping is delta from previous version and second one is an
104+ -- accumlation of all previous mappings.
105+ ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int)
106+ -- ^ How many rules are running for each file
104 }
107 }
105
108
106getShakeExtras :: Action ShakeExtras
109getShakeExtras :: Action ShakeExtras
@@ -113,22 +116,29 @@ getShakeExtrasRules = do
113 Just x <- getShakeExtraRules @ShakeExtras
116 Just x <- getShakeExtraRules @ShakeExtras
114 return x
117 return x
115
118
116−
117−
118class Typeable a => IsIdeGlobal a where
119class Typeable a => IsIdeGlobal a where
119
120
120addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
121addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
121−addIdeGlobal x@(typeOf -> ty) = do
122+addIdeGlobal x = do
123+ extras <- getShakeExtrasRules
124+ liftIO $ addIdeGlobalExtras extras x
125+
126+addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()
122− ShakeExtras{globals} <- getShakeExtrasRules
127+addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =
123 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
128 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
124− Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty
129+ Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty
125 Nothing -> return $! HMap.insert ty (toDyn x) mp
130 Nothing -> return $! HMap.insert ty (toDyn x) mp
126
131
127
132
128getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
133getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
129getIdeGlobalExtras ShakeExtras{globals} = do
134getIdeGlobalExtras ShakeExtras{globals} = do
135+ let typ = typeRep (Proxy :: Proxy a)
130− Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
136+ x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
131− return $ fromDyn x $ error "Serious error, corrupt globals"
137+ case x of
138+ Just x
139+ | Just x <- fromDynamic x -> pure x
140+ | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")"
141+ Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ
132
142
133getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
143getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
134getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
144getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
@@ -151,7 +161,7 @@ instance Eq Key where
151 | otherwise = False
161 | otherwise = False
152
162
153instance Hashable Key where
163instance Hashable Key where
154− hashWithSalt salt (Key key) = hashWithSalt salt key
164+ hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)
155
165
156-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,
166-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,
157-- and a value is in the Maybe. For operations that throw an error you
167-- and a value is in the Maybe. For operations that throw an error you
@@ -161,9 +171,6 @@ instance Hashable Key where
161-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh
171-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh
162-- errors but still failed.
172-- errors but still failed.
163--
173--
164−-- A rule on a file should only return diagnostics for that given file. It should
165−-- not propagate diagnostic errors through multiple phases.
166−type IdeResult v = ([FileDiagnostic], Maybe v)
167
174
168data Value v
175data Value v
169 = Succeeded TextDocumentVersion v
176 = Succeeded TextDocumentVersion v
@@ -198,14 +205,14 @@ valueVersion = \case
198 Failed -> Nothing
205 Failed -> Nothing
199
206
200mappingForVersion
207mappingForVersion
201− :: Map NormalizedUri (Map TextDocumentVersion PositionMapping)
208+ :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
202 -> NormalizedFilePath
209 -> NormalizedFilePath
203 -> TextDocumentVersion
210 -> TextDocumentVersion
204 -> PositionMapping
211 -> PositionMapping
205mappingForVersion allMappings file ver =
212mappingForVersion allMappings file ver =
206− fromMaybe idMapping $
213+ maybe zeroMapping snd $
207 Map.lookup ver =<<
214 Map.lookup ver =<<
208− Map.lookup (filePathToUri' file) allMappings
215+ HMap.lookup (filePathToUri' file) allMappings
209
216
210type IdeRule k v =
217type IdeRule k v =
211 ( Shake.RuleResult k ~ v
218 ( Shake.RuleResult k ~ v
@@ -236,7 +243,6 @@ shakeRunDatabaseProfile mbProfileDir shakeDb acts = do
236 shakeProfileDatabase shakeDb $ dir </> file
243 shakeProfileDatabase shakeDb $ dir </> file
237 return (dir </> file)
244 return (dir </> file)
238 return (res, proFile)
245 return (res, proFile)
239− where
240
246
241{-# NOINLINE profileStartTime #-}
247{-# NOINLINE profileStartTime #-}
242profileStartTime :: String
248profileStartTime :: String
@@ -292,34 +298,40 @@ seqValue v b = case v of
292shakeOpen :: IO LSP.LspId
298shakeOpen :: IO LSP.LspId
293 -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
299 -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
294 -> Logger
300 -> Logger
301+ -> Debouncer NormalizedUri
295 -> Maybe FilePath
302 -> Maybe FilePath
296 -> IdeReportProgress
303 -> IdeReportProgress
297 -> ShakeOptions
304 -> ShakeOptions
298 -> Rules ()
305 -> Rules ()
299 -> IO IdeState
306 -> IO IdeState
300−shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do
307+shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) opts rules = do
308+ inProgress <- newVar HMap.empty
301 shakeExtras <- do
309 shakeExtras <- do
302 globals <- newVar HMap.empty
310 globals <- newVar HMap.empty
303 state <- newVar HMap.empty
311 state <- newVar HMap.empty
304 diagnostics <- newVar mempty
312 diagnostics <- newVar mempty
305 hiddenDiagnostics <- newVar mempty
313 hiddenDiagnostics <- newVar mempty
306 publishedDiagnostics <- newVar mempty
314 publishedDiagnostics <- newVar mempty
307− debouncer <- newDebouncer
308− positionMapping <- newVar Map.empty
315+ positionMapping <- newVar HMap.empty
309 pure ShakeExtras{..}
316 pure ShakeExtras{..}
310 (shakeDb, shakeClose) <-
317 (shakeDb, shakeClose) <-
311 shakeOpenDatabase
318 shakeOpenDatabase
312 opts
319 opts
313 { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts
320 { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts
321+ -- we don't actually use the progress value, but Shake conveniently spawns/kills this thread whenever
322+ -- we call into Shake, so abuse it for that purpose
314− , shakeProgress = if reportProgress then lspShakeProgress getLspId eventer else const (pure ())
323+ , shakeProgress = const $ if reportProgress then lspShakeProgress getLspId eventer inProgress else pure ()
315 }
324 }
316 rules
325 rules
317 shakeAbort <- newMVar $ return ()
326 shakeAbort <- newMVar $ return ()
318 shakeDb <- shakeDb
327 shakeDb <- shakeDb
319 return IdeState{..}
328 return IdeState{..}
320
329
321−lspShakeProgress :: IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> IO Progress -> IO ()
330+lspShakeProgress :: Hashable a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (HMap.HashMap a Int) -> IO ()
322−lspShakeProgress getLspId sendMsg prog = do
331+lspShakeProgress getLspId sendMsg inProgress = do
332+ -- first sleep a bit, so we only show progress messages if it's going to take
333+ -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
334+ sleep 0.1
323 lspId <- getLspId
335 lspId <- getLspId
324 u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique
336 u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique
325 sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest
337 sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest
@@ -347,9 +359,9 @@ lspShakeProgress getLspId sendMsg prog = do
347 sample = 0.1
359 sample = 0.1
348 loop id prev = do
360 loop id prev = do
349 sleep sample
361 sleep sample
350− p <- prog
362+ current <- readVar inProgress
351− let done = countSkipped p + countBuilt p
363+ let done = length $ filter (== 0) $ HMap.elems current
352− let todo = done + countUnknown p + countTodo p
364+ let todo = HMap.size current
353 let next = Just $ T.pack $ show done <> "/" <> show todo
365 let next = Just $ T.pack $ show done <> "/" <> show todo
354 when (next /= prev) $
366 when (next /= prev) $
355 sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification
367 sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification
@@ -405,8 +417,8 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =
405 Right _ -> "completed"
417 Right _ -> "completed"
406 profile = case res of
418 profile = case res of
407 Right (_, Just fp) ->
419 Right (_, Just fp) ->
408− let link = case filePathToUri' $ toNormalizedFilePath fp of
420+ let link = case filePathToUri' $ toNormalizedFilePath' fp of
409− NormalizedUri x -> x
421+ NormalizedUri _ x -> x
410 in ", profile saved at " <> T.unpack link
422 in ", profile saved at " <> T.unpack link
411 _ -> ""
423 _ -> ""
412 let logMsg = logDebug logger $ T.pack $
424 let logMsg = logDebug logger $ T.pack $
@@ -444,9 +456,9 @@ garbageCollect keep = do
444 return $! dupe values
456 return $! dupe values
445 modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags
457 modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags
446 modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags
458 modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags
447− modifyVar_ publishedDiagnostics $ \diags -> return $! Map.filterWithKey (\uri _ -> keep (fromUri uri)) diags
459+ modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags
448 let versionsForFile =
460 let versionsForFile =
449− Map.fromListWith Set.union $
461+ HMap.fromListWith Set.union $
450 mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
462 mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
451 HMap.toList newState
463 HMap.toList newState
452 modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings
464 modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings
@@ -464,25 +476,25 @@ useWithStale :: IdeRule k v
464useWithStale key file = head <$> usesWithStale key [file]
476useWithStale key file = head <$> usesWithStale key [file]
465
477
466useNoFile :: IdeRule k v => k -> Action (Maybe v)
478useNoFile :: IdeRule k v => k -> Action (Maybe v)
467−useNoFile key = use key ""
479+useNoFile key = use key emptyFilePath
468
480
469use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
481use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
470use_ key file = head <$> uses_ key [file]
482use_ key file = head <$> uses_ key [file]
471
483
472useNoFile_ :: IdeRule k v => k -> Action v
484useNoFile_ :: IdeRule k v => k -> Action v
473−useNoFile_ key = use_ key ""
485+useNoFile_ key = use_ key emptyFilePath
474
486
475uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
487uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
476uses_ key files = do
488uses_ key files = do
477 res <- uses key files
489 res <- uses key files
478 case sequence res of
490 case sequence res of
479− Nothing -> liftIO $ throwIO BadDependency
491+ Nothing -> liftIO $ throwIO $ BadDependency (show key)
480 Just v -> return v
492 Just v -> return v
481
493
482
494
483-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
495-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
484-- which short-circuits the rest of the action
496-- which short-circuits the rest of the action
485−data BadDependency = BadDependency deriving Show
497+data BadDependency = BadDependency String deriving Show
486instance Exception BadDependency
498instance Exception BadDependency
487
499
488isBadDependency :: SomeException -> Bool
500isBadDependency :: SomeException -> Bool
@@ -501,12 +513,10 @@ instance Show k => Show (Q k) where
501
513
502-- | Invariant: the 'v' must be in normal form (fully evaluated).
514-- | Invariant: the 'v' must be in normal form (fully evaluated).
503-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database
515-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database
504−-- Note (MK) I am not sure why we need the ShakeValue here, maybe we
505−-- can just remove it?
506−data A v = A (Value v) ShakeValue
516+newtype A v = A (Value v)
507 deriving Show
517 deriving Show
508
518
509−instance NFData (A v) where rnf (A v x) = v `seq` rnf x
519+instance NFData (A v) where rnf (A v) = v `seq` ()
510
520
511-- In the Shake database we only store one type of key/result pairs,
521-- In the Shake database we only store one type of key/result pairs,
512-- namely Q (question) / A (answer).
522-- namely Q (question) / A (answer).
@@ -516,59 +526,70 @@ type instance RuleResult (Q k) = A (RuleResult k)
516-- | Return up2date results. Stale results will be ignored.
526-- | Return up2date results. Stale results will be ignored.
517uses :: IdeRule k v
527uses :: IdeRule k v
518 => k -> [NormalizedFilePath] -> Action [Maybe v]
528 => k -> [NormalizedFilePath] -> Action [Maybe v]
519−uses key files = map (\(A value _) -> currentValue value) <$> apply (map (Q . (key,)) files)
529+uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files)
520
530
521-- | Return the last computed result which might be stale.
531-- | Return the last computed result which might be stale.
522usesWithStale :: IdeRule k v
532usesWithStale :: IdeRule k v
523 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
533 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
524usesWithStale key files = do
534usesWithStale key files = do
525− values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
535+ values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files)
526− mapM (uncurry lastValue) (zip files values)
536+ zipWithM lastValue files values
537+
538+
539+withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b
540+withProgress var file = actionBracket (f succ) (const $ f pred) . const
541+ -- This functions are deliberately eta-expanded to avoid space leaks.
542+ -- Do not remove the eta-expansion without profiling a session with at
543+ -- least 1000 modifications.
544+ where f shift = modifyVar_ var $ \x -> evaluate $ HMap.alter (\x -> Just $! shift (fromMaybe 0 x)) file x
545+
527
546
528defineEarlyCutoff
547defineEarlyCutoff
529 :: IdeRule k v
548 :: IdeRule k v
530 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
549 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
531 -> Rules ()
550 -> Rules ()
532defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do
551defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do
533− extras@ShakeExtras{state} <- getShakeExtras
552+ extras@ShakeExtras{state, inProgress} <- getShakeExtras
553+ -- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key
554+ (if show key == "GetFileExists" then id else withProgress inProgress file) $ do
534− val <- case old of
555+ val <- case old of
535− Just old | mode == RunDependenciesSame -> do
556+ Just old | mode == RunDependenciesSame -> do
536− v <- liftIO $ getValues state key file
557+ v <- liftIO $ getValues state key file
537− case v of
558+ case v of
538− -- No changes in the dependencies and we have
559+ -- No changes in the dependencies and we have
539− -- an existing result.
560+ -- an existing result.
540− Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)
561+ Just v -> return $ Just $ RunResult ChangedNothing old $ A v
541− _ -> return Nothing
562+ _ -> return Nothing
542− _ -> return Nothing
563+ _ -> return Nothing
543− case val of
564+ case val of
544− Just res -> return res
565+ Just res -> return res
545− Nothing -> do
566+ Nothing -> do
546− (bs, (diags, res)) <- actionCatch
567+ (bs, (diags, res)) <- actionCatch
547− (do v <- op key file; liftIO $ evaluate $ force $ v) $
568+ (do v <- op key file; liftIO $ evaluate $ force v) $
548− \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
569+ \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
549− modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file
570+ modTime <- liftIO $ (currentValue =<<) <$> getValues state GetModificationTime file
550− (bs, res) <- case res of
571+ (bs, res) <- case res of
551− Nothing -> do
572+ Nothing -> do
552− staleV <- liftIO $ getValues state key file
573+ staleV <- liftIO $ getValues state key file
553− pure $ case staleV of
574+ pure $ case staleV of
554− Nothing -> (toShakeValue ShakeResult bs, Failed)
575+ Nothing -> (toShakeValue ShakeResult bs, Failed)
555− Just v -> case v of
576+ Just v -> case v of
556− Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
577+ Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
557− Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
578+ Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
558− Failed -> (toShakeValue ShakeResult bs, Failed)
579+ Failed -> (toShakeValue ShakeResult bs, Failed)
559− Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
580+ Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
560− liftIO $ setValues state key file res
581+ liftIO $ setValues state key file res
561− updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
582+ updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
562− let eq = case (bs, fmap decodeShakeValue old) of
583+ let eq = case (bs, fmap decodeShakeValue old) of
563− (ShakeResult a, Just (ShakeResult b)) -> a == b
584+ (ShakeResult a, Just (ShakeResult b)) -> a == b
564− (ShakeStale a, Just (ShakeStale b)) -> a == b
585+ (ShakeStale a, Just (ShakeStale b)) -> a == b
565− -- If we do not have a previous result
586+ -- If we do not have a previous result
566− -- or we got ShakeNoCutoff we always return False.
587+ -- or we got ShakeNoCutoff we always return False.
567− _ -> False
588+ _ -> False
568− return $ RunResult
589+ return $ RunResult
569− (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
590+ (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
570− (encodeShakeValue bs) $
591+ (encodeShakeValue bs) $
571− A res bs
592+ A res
572
593
573
594
574-- | Rule type, input file
595-- | Rule type, input file
@@ -639,12 +660,12 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $
639needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()
660needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()
640needOnDisk k file = do
661needOnDisk k file = do
641 successfull <- apply1 (QDisk k file)
662 successfull <- apply1 (QDisk k file)
642− liftIO $ unless successfull $ throwIO BadDependency
663+ liftIO $ unless successfull $ throwIO $ BadDependency (show k)
643
664
644needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()
665needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()
645needOnDisks k files = do
666needOnDisks k files = do
646 successfulls <- apply $ map (QDisk k) files
667 successfulls <- apply $ map (QDisk k) files
647− liftIO $ unless (and successfulls) $ throwIO BadDependency
668+ liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k)
648
669
649toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue
670toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue
650toShakeValue = maybe ShakeNoCutoff
671toShakeValue = maybe ShakeNoCutoff
@@ -683,7 +704,7 @@ updateFileDiagnostics ::
683 -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
704 -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
684 -> Action ()
705 -> Action ()
685updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
706updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
686− modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp
707+ modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp
687 let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
708 let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
688 mask_ $ do
709 mask_ $ do
689 -- Mask async exceptions to ensure that updated diagnostics are always
710 -- Mask async exceptions to ensure that updated diagnostics are always
@@ -696,7 +717,7 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, published
696 let newDiags = getFileDiagnostics fp newDiagsStore
717 let newDiags = getFileDiagnostics fp newDiagsStore
697 _ <- evaluate newDiagsStore
718 _ <- evaluate newDiagsStore
698 _ <- evaluate newDiags
719 _ <- evaluate newDiags
699− pure $! (newDiagsStore, newDiags)
720+ pure (newDiagsStore, newDiags)
700 modifyVar_ hiddenDiagnostics $ \old -> do
721 modifyVar_ hiddenDiagnostics $ \old -> do
701 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
722 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
702 (T.pack $ show k) (map snd currentHidden) old
723 (T.pack $ show k) (map snd currentHidden) old
@@ -708,10 +729,10 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, published
708 let delay = if null newDiags then 0.1 else 0
729 let delay = if null newDiags then 0.1 else 0
709 registerEvent debouncer delay uri $ do
730 registerEvent debouncer delay uri $ do
710 mask_ $ modifyVar_ publishedDiagnostics $ \published -> do
731 mask_ $ modifyVar_ publishedDiagnostics $ \published -> do
711− let lastPublish = Map.findWithDefault [] uri published
732+ let lastPublish = HMap.lookupDefault [] uri published
712 when (lastPublish /= newDiags) $
733 when (lastPublish /= newDiags) $
713 eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags
734 eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags
714− pure $! Map.insert uri newDiags published
735+ pure $! HMap.insert uri newDiags published
715
736
716publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage
737publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage
717publishDiagnosticsNotification uri diags =
738publishDiagnosticsNotification uri diags =
@@ -722,7 +743,7 @@ publishDiagnosticsNotification uri diags =
722newtype Priority = Priority Double
743newtype Priority = Priority Double
723
744
724setPriority :: Priority -> Action ()
745setPriority :: Priority -> Action ()
725−setPriority (Priority p) = deprioritize p
746+setPriority (Priority p) = reschedule p
726
747
727sendEvent :: LSP.FromServerMessage -> Action ()
748sendEvent :: LSP.FromServerMessage -> Action ()
728sendEvent e = do
749sendEvent e = do
@@ -747,19 +768,22 @@ instance Binary GetModificationTime
747-- | Get the modification time of a file.
768-- | Get the modification time of a file.
748type instance RuleResult GetModificationTime = FileVersion
769type instance RuleResult GetModificationTime = FileVersion
749
770
750−-- | We store the modification time as a ByteString since we need
771+data FileVersion
751−-- a ByteString anyway for Shake and we do not care about how times
772+ = VFSVersion !Int
752−-- are represented.
753−data FileVersion = VFSVersion Int | ModificationTime BS.ByteString
773+ | ModificationTime
774+ !Int -- ^ Large unit (platform dependent, do not make assumptions)
775+ !Int -- ^ Small unit (platform dependent, do not make assumptions)
754 deriving (Show, Generic)
776 deriving (Show, Generic)
755
777
756instance NFData FileVersion
778instance NFData FileVersion
757
779
758vfsVersion :: FileVersion -> Maybe Int
780vfsVersion :: FileVersion -> Maybe Int
759vfsVersion (VFSVersion i) = Just i
781vfsVersion (VFSVersion i) = Just i
760−vfsVersion (ModificationTime _) = Nothing
782+vfsVersion ModificationTime{} = Nothing
761−
762
783
784+modificationTime :: FileVersion -> Maybe (Int, Int)
785+modificationTime VFSVersion{} = Nothing
786+modificationTime (ModificationTime large small) = Just (large, small)
763
787
764getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
788getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
765getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
789getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
@@ -784,7 +808,7 @@ getAllDiagnostics ::
784 DiagnosticStore ->
808 DiagnosticStore ->
785 [FileDiagnostic]
809 [FileDiagnostic]
786getAllDiagnostics =
810getAllDiagnostics =
787− concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . Map.toList
811+ concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList
788
812
789getFileDiagnostics ::
813getFileDiagnostics ::
790 NormalizedFilePath ->
814 NormalizedFilePath ->
@@ -792,29 +816,34 @@ getFileDiagnostics ::
792 [LSP.Diagnostic]
816 [LSP.Diagnostic]
793getFileDiagnostics fp ds =
817getFileDiagnostics fp ds =
794 maybe [] getDiagnosticsFromStore $
818 maybe [] getDiagnosticsFromStore $
795− Map.lookup (filePathToUri' fp) ds
819+ HMap.lookup (filePathToUri' fp) ds
796
820
797filterDiagnostics ::
821filterDiagnostics ::
798 (NormalizedFilePath -> Bool) ->
822 (NormalizedFilePath -> Bool) ->
799 DiagnosticStore ->
823 DiagnosticStore ->
800 DiagnosticStore
824 DiagnosticStore
801filterDiagnostics keep =
825filterDiagnostics keep =
802− Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)
826+ HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri)
803
827
804filterVersionMap
828filterVersionMap
805− :: Map NormalizedUri (Set.Set TextDocumentVersion)
829+ :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)
806− -> Map NormalizedUri (Map TextDocumentVersion a)
830+ -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
807− -> Map NormalizedUri (Map TextDocumentVersion a)
831+ -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
808filterVersionMap =
832filterVersionMap =
809− Map.merge Map.dropMissing Map.dropMissing $
810− Map.zipWithMatched $ \_ versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
833+ HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
811
834
812updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
835updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
813−updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do
836+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do
814 modifyVar_ positionMapping $ \allMappings -> do
837 modifyVar_ positionMapping $ \allMappings -> do
815 let uri = toNormalizedUri _uri
838 let uri = toNormalizedUri _uri
816− let mappingForUri = Map.findWithDefault Map.empty uri allMappings
839+ let mappingForUri = HMap.lookupDefault Map.empty uri allMappings
817− let updatedMapping =
840+ let (_, updatedMapping) =
818− Map.insert _version idMapping $
841+ -- Very important to use mapAccum here so that the tails of
819− Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri
842+ -- each mapping can be shared, otherwise quadratic space is
843+ -- used which is evident in long running sessions.
844+ Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))
845+ zeroMapping
846+ (Map.insert _version (shared_change, zeroMapping) mappingForUri)
820− pure $! Map.insert uri updatedMapping allMappings
847+ pure $! HMap.insert uri updatedMapping allMappings
848+ where
849+ shared_change = mkDelta changes
src/Development/IDE/GHC/CPP.hs+27−2
@@ -19,7 +19,8 @@
19--
19--
20-----------------------------------------------------------------------------
20-----------------------------------------------------------------------------
21
21
22−module Development.IDE.GHC.CPP(doCpp) where
22+module Development.IDE.GHC.CPP(doCpp, addOptP)
23+where
23
24
24import Development.IDE.GHC.Compat
25import Development.IDE.GHC.Compat
25import Packages
26import Packages
@@ -29,10 +30,14 @@ import DynFlags
29import Panic
30import Panic
30import FileCleanup
31import FileCleanup
31#if MIN_GHC_API_VERSION(8,8,2)
32#if MIN_GHC_API_VERSION(8,8,2)
32−import LlvmCodeGen (LlvmVersion, llvmVersionList)
33+import LlvmCodeGen (llvmVersionList)
33#elif MIN_GHC_API_VERSION(8,8,0)
34#elif MIN_GHC_API_VERSION(8,8,0)
34import LlvmCodeGen (LlvmVersion (..))
35import LlvmCodeGen (LlvmVersion (..))
35#endif
36#endif
37+#if MIN_GHC_API_VERSION (8,10,0)
38+import Fingerprint
39+import ToolSettings
40+#endif
36
41
37import System.Directory
42import System.Directory
38import System.FilePath
43import System.FilePath
@@ -59,7 +64,11 @@ doCpp dflags raw input_fn output_fn = do
59 let verbFlags = getVerbFlags dflags
64 let verbFlags = getVerbFlags dflags
60
65
61 let cpp_prog args | raw = SysTools.runCpp dflags args
66 let cpp_prog args | raw = SysTools.runCpp dflags args
67+#if MIN_GHC_API_VERSION(8,10,0)
68+ | otherwise = SysTools.runCc Nothing
69+#else
62 | otherwise = SysTools.runCc
70 | otherwise = SysTools.runCc
71+#endif
63 dflags (SysTools.Option "-E" : args)
72 dflags (SysTools.Option "-E" : args)
64
73
65 let target_defs =
74 let target_defs =
@@ -158,6 +167,22 @@ getBackendDefs dflags | hscTarget dflags == HscLlvm = do
158getBackendDefs _ =
167getBackendDefs _ =
159 return []
168 return []
160
169
170+addOptP :: String -> DynFlags -> DynFlags
171+#if MIN_GHC_API_VERSION (8,10,0)
172+addOptP f = alterToolSettings $ \s -> s
173+ { toolSettings_opt_P = f : toolSettings_opt_P s
174+ , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)
175+ }
176+ where
177+ fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss
178+ alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }
179+#else
180+addOptP opt = onSettings (onOptP (opt:))
181+ where
182+ onSettings f x = x{settings = f $ settings x}
183+ onOptP f x = x{sOpt_P = f $ sOpt_P x}
184+#endif
185+
161-- ---------------------------------------------------------------------------
186-- ---------------------------------------------------------------------------
162-- Macros (cribbed from Cabal)
187-- Macros (cribbed from Cabal)
163
188
src/Development/IDE/GHC/Compat.hs+189−19
@@ -7,22 +7,38 @@
7
7
8-- | Attempt at hiding the GHC version differences we can.
8-- | Attempt at hiding the GHC version differences we can.
9module Development.IDE.GHC.Compat(
9module Development.IDE.GHC.Compat(
10+ getHeaderImports,
10 HieFileResult(..),
11 HieFileResult(..),
11− HieFile(..),
12+ HieFile,
13+ hieExportNames,
14+ hie_module,
12 mkHieFile,
15 mkHieFile,
13 writeHieFile,
16 writeHieFile,
14 readHieFile,
17 readHieFile,
18+ supportsHieFiles,
19+ setDefaultHieDir,
20+ dontWriteHieFiles,
21+#if !MIN_GHC_API_VERSION(8,8,0)
22+ ml_hie_file,
23+#endif
15 hPutStringBuffer,
24 hPutStringBuffer,
16 includePathsGlobal,
25 includePathsGlobal,
17 includePathsQuote,
26 includePathsQuote,
18 addIncludePathsQuote,
27 addIncludePathsQuote,
28+ getModuleHash,
29+ getPackageName,
19 pattern DerivD,
30 pattern DerivD,
20 pattern ForD,
31 pattern ForD,
21 pattern InstD,
32 pattern InstD,
22 pattern TyClD,
33 pattern TyClD,
23 pattern ValD,
34 pattern ValD,
24 pattern ClassOpSig,
35 pattern ClassOpSig,
36+ pattern IEThingAll,
25 pattern IEThingWith,
37 pattern IEThingWith,
38+ GHC.ModLocation,
39+ Module.addBootSuffix,
40+ pattern ModLocation,
41+ getConArgs,
26
42
27 module GHC
43 module GHC
28 ) where
44 ) where
@@ -30,41 +46,62 @@ module Development.IDE.GHC.Compat(
30import StringBuffer
46import StringBuffer
31import DynFlags
47import DynFlags
32import FieldLabel
48import FieldLabel
49+import Fingerprint (Fingerprint)
50+import qualified Module
51+import Packages
33
52
34import qualified GHC
53import qualified GHC
54+import GHC hiding (
35−import GHC hiding (ClassOpSig, DerivD, ForD, IEThingWith, InstD, TyClD, ValD)
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+
65+#if MIN_GHC_API_VERSION(8,10,0)
66+import HscTypes (mi_mod_hash)
67+#endif
36
68
37#if MIN_GHC_API_VERSION(8,8,0)
69#if MIN_GHC_API_VERSION(8,8,0)
38−import HieAst
70+import Control.Applicative ((<|>))
71+import Development.IDE.GHC.HieAst (mkHieFile)
39import HieBin
72import HieBin
40import HieTypes
73import HieTypes
74+
75+supportsHieFiles :: Bool
76+supportsHieFiles = True
77+
78+hieExportNames :: HieFile -> [(SrcSpan, Name)]
79+hieExportNames = nameListFromAvails . hie_exports
80+
41#else
81#else
82+
83+#if MIN_GHC_API_VERSION(8,6,0)
84+import BinIface
85+import Data.IORef
86+import IfaceEnv
87+#endif
88+
89+import Binary
90+import Control.Exception (catch)
91+import Data.ByteString (ByteString)
42−import GhcPlugins
92+import GhcPlugins hiding (ModLocation)
43import NameCache
93import NameCache
44−import Avail
45import TcRnTypes
94import TcRnTypes
46import System.IO
95import System.IO
47import Foreign.ForeignPtr
96import Foreign.ForeignPtr
97+import MkIface
48
98
49
99
50−#if !MIN_GHC_API_VERSION(8,8,0)
51hPutStringBuffer :: Handle -> StringBuffer -> IO ()
100hPutStringBuffer :: Handle -> StringBuffer -> IO ()
52hPutStringBuffer hdl (StringBuffer buf len cur)
101hPutStringBuffer hdl (StringBuffer buf len cur)
53 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->
102 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->
54 hPutBuf hdl ptr len
103 hPutBuf hdl ptr len
55−#endif
56−
57−mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile
58−mkHieFile _ _ _ = return (HieFile () [])
59−
60−writeHieFile :: FilePath -> HieFile -> IO ()
61−writeHieFile _ _ = return ()
62
104
63−readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())
64−readHieFile _ _ = return (HieFileResult (HieFile () []), ())
65−
66−data HieFile = HieFile {hie_module :: (), hie_exports :: [AvailInfo]}
67−data HieFileResult = HieFileResult { hie_file_result :: HieFile }
68#endif
105#endif
69
106
70#if !MIN_GHC_API_VERSION(8,6,0)
107#if !MIN_GHC_API_VERSION(8,6,0)
@@ -136,4 +173,137 @@ pattern IEThingWith a b c d <-
136 GHC.IEThingWith _ a b c d
173 GHC.IEThingWith _ a b c d
137#else
174#else
138 GHC.IEThingWith a b c d
175 GHC.IEThingWith a b c d
139−#endif
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)
181+ GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c ""
182+#else
183+ GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c
184+#endif
185+
186+pattern IEThingAll :: LIEWrappedName (IdP pass) -> IE pass
187+pattern IEThingAll a <-
188+#if MIN_GHC_API_VERSION(8,6,0)
189+ GHC.IEThingAll _ a
190+#else
191+ GHC.IEThingAll a
192+#endif
193+
194+setDefaultHieDir :: FilePath -> DynFlags -> DynFlags
195+setDefaultHieDir _f d =
196+#if MIN_GHC_API_VERSION(8,8,0)
197+ d { hieDir = hieDir d <|> Just _f}
198+#else
199+ d
200+#endif
201+
202+dontWriteHieFiles :: DynFlags -> DynFlags
203+dontWriteHieFiles d =
204+#if MIN_GHC_API_VERSION(8,8,0)
205+ gopt_unset d Opt_WriteHie
206+#else
207+ d
208+#endif
209+
210+nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)]
211+nameListFromAvails as =
212+ map (\n -> (nameSrcSpan n, n)) (concatMap availNames as)
213+
214+#if !MIN_GHC_API_VERSION(8,8,0)
215+-- Reimplementations of functions for HIE files for GHC 8.6
216+
217+mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> ByteString -> Hsc HieFile
218+mkHieFile ms ts _ _ = return (HieFile (ms_mod ms) es)
219+ where
220+ es = nameListFromAvails (mkIfaceExports (tcg_exports ts))
221+
222+ml_hie_file :: GHC.ModLocation -> FilePath
223+ml_hie_file ml = ml_hi_file ml ++ ".hie"
224+
225+data HieFile = HieFile {hie_module :: Module, hie_exports :: [(SrcSpan, Name)]}
226+
227+hieExportNames :: HieFile -> [(SrcSpan, Name)]
228+hieExportNames = hie_exports
229+
230+instance Binary HieFile where
231+ put_ bh (HieFile m es) = do
232+ put_ bh m
233+ put_ bh es
234+
235+ get bh = do
236+ mod <- get bh
237+ es <- get bh
238+ return (HieFile mod es)
239+
240+data HieFileResult = HieFileResult { hie_file_result :: HieFile }
241+
242+writeHieFile :: FilePath -> HieFile -> IO ()
243+readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())
244+supportsHieFiles :: Bool
245+
246+#if MIN_GHC_API_VERSION(8,6,0)
247+
248+writeHieFile fp hie = do
249+ bh <- openBinMem (1024 * 1024)
250+ putWithUserData (const $ return ()) bh hie
251+ writeBinMem bh fp
252+
253+readHieFile nc fp = do
254+ bh <- readBinMem fp
255+ nc' <- newIORef nc
256+ hie_file <- getWithUserData (NCU (atomicModifyIORef' nc')) bh
257+ return (HieFileResult hie_file, ())
258+
259+supportsHieFiles = True
260+
261+#else
262+
263+supportsHieFiles = False
264+
265+writeHieFile _ _ = return ()
266+
267+readHieFile _ _ = return undefined
268+
269+#endif
270+
271+#endif
272+
273+getHeaderImports
274+ :: DynFlags
275+ -> StringBuffer
276+ -> FilePath
277+ -> FilePath
278+ -> IO
279+ ( Either
280+ ErrorMessages
281+ ( [(Maybe FastString, Located ModuleName)]
282+ , [(Maybe FastString, Located ModuleName)]
283+ , Located ModuleName
284+ )
285+ )
286+#if MIN_GHC_API_VERSION(8,8,0)
287+getHeaderImports = Hdr.getImports
288+#else
289+getHeaderImports a b c d =
290+ catch (Right <$> Hdr.getImports a b c d)
291+ (return . Left . srcErrorMessages)
292+#endif
293+
294+getModuleHash :: ModIface -> Fingerprint
295+#if MIN_GHC_API_VERSION(8,10,0)
296+getModuleHash = mi_mod_hash . mi_final_exts
297+#else
298+getModuleHash = mi_mod_hash
299+#endif
300+
301+getConArgs :: ConDecl pass -> HsConDeclDetails pass
302+#if MIN_GHC_API_VERSION(8,6,0)
303+getConArgs = GHC.getConArgs
304+#else
305+getConArgs = GHC.getConDetails
306+#endif
307+
308+getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName
309+getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i))
src/Development/IDE/GHC/Error.hs+27−4
@@ -9,6 +9,7 @@ module Development.IDE.GHC.Error
9 , diagFromStrings
9 , diagFromStrings
10 , diagFromGhcException
10 , diagFromGhcException
11 , catchSrcErrors
11 , catchSrcErrors
12+ , mergeDiagnostics
12
13
13 -- * utilities working with spans
14 -- * utilities working with spans
14 , srcSpanToLocation
15 , srcSpanToLocation
@@ -36,11 +37,12 @@ import Panic
36import ErrUtils
37import ErrUtils
37import SrcLoc
38import SrcLoc
38import qualified Outputable as Out
39import qualified Outputable as Out
40+import Exception (ExceptionMonad)
39
41
40
42
41
43
42diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
44diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
43−diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,ShowDiag,)
45+diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename loc,ShowDiag,)
44 Diagnostic
46 Diagnostic
45 { _range = srcSpanToRange loc
47 { _range = srcSpanToRange loc
46 , _severity = Just sev
48 , _severity = Just sev
@@ -48,18 +50,39 @@ diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename
48 , _message = msg
50 , _message = msg
49 , _code = Nothing
51 , _code = Nothing
50 , _relatedInformation = Nothing
52 , _relatedInformation = Nothing
53+ , _tags = Nothing
51 }
54 }
52
55
53-- | Produce a GHC-style error from a source span and a message.
56-- | Produce a GHC-style error from a source span and a message.
54diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]
57diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]
55diagFromErrMsg diagSource dflags e =
58diagFromErrMsg diagSource dflags e =
56− [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $ ErrUtils.pprLocErrMsg e
59+ [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $
60+ ErrUtils.formatErrDoc dflags $ ErrUtils.errMsgDoc e
57 | Just sev <- [toDSeverity $ errMsgSeverity e]]
61 | Just sev <- [toDSeverity $ errMsgSeverity e]]
58
62
59
63
60diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
64diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
61diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList
65diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList
62
66
67+-- | Merges two sorted lists of diagnostics, removing duplicates.
68+-- Assumes all the diagnostics are for the same file.
69+mergeDiagnostics :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
70+mergeDiagnostics aa [] = aa
71+mergeDiagnostics [] bb = bb
72+mergeDiagnostics (a@(_,_,ad@Diagnostic{_range = ar}):aa) (b@(_,_,bd@Diagnostic{_range=br}):bb)
73+ | ar < br
74+ = a : mergeDiagnostics aa (b:bb)
75+ | br < ar
76+ = b : mergeDiagnostics (a:aa) bb
77+ | _severity ad == _severity bd
78+ && _source ad == _source bd
79+ && _message ad == _message bd
80+ && _code ad == _code bd
81+ && _relatedInformation ad == _relatedInformation bd
82+ && _tags ad == _tags bd
83+ = a : mergeDiagnostics aa bb
84+ | otherwise
85+ = a : b : mergeDiagnostics aa bb
63
86
64-- | Convert a GHC SrcSpan to a DAML compiler Range
87-- | Convert a GHC SrcSpan to a DAML compiler Range
65srcSpanToRange :: SrcSpan -> Range
88srcSpanToRange :: SrcSpan -> Range
@@ -80,7 +103,7 @@ srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real
80srcSpanToLocation :: SrcSpan -> Location
103srcSpanToLocation :: SrcSpan -> Location
81srcSpanToLocation src =
104srcSpanToLocation src =
82 -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code
105 -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code
83− Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath $ srcSpanToFilename src) (srcSpanToRange src)
106+ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ srcSpanToFilename src) (srcSpanToRange src)
84
107
85isInsideSrcSpan :: Position -> SrcSpan -> Bool
108isInsideSrcSpan :: Position -> SrcSpan -> Bool
86p `isInsideSrcSpan` r = sp <= p && p <= ep
109p `isInsideSrcSpan` r = sp <= p && p <= ep
@@ -127,7 +150,7 @@ realSpan = \case
127
150
128-- | Run something in a Ghc monad and catch the errors (SourceErrors and
151-- | Run something in a Ghc monad and catch the errors (SourceErrors and
129-- compiler-internal exceptions like Panic or InstallationError).
152-- compiler-internal exceptions like Panic or InstallationError).
130−catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)
153+catchSrcErrors :: (HasDynFlags m, ExceptionMonad m) => T.Text -> m a -> m (Either [FileDiagnostic] a)
131catchSrcErrors fromWhere ghcM = do
154catchSrcErrors fromWhere ghcM = do
132 dflags <- getDynFlags
155 dflags <- getDynFlags
133 handleGhcException (ghcExceptionToDiagnostics dflags) $
156 handleGhcException (ghcExceptionToDiagnostics dflags) $
src/Development/IDE/GHC/Orphans.hs+10−3
@@ -1,8 +1,10 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4+{-# LANGUAGE CPP #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
5{-# OPTIONS_GHC -Wno-orphans #-}
6{-# OPTIONS_GHC -Wno-orphans #-}
7+#include "ghc-api-version.h"
6
8
7-- | Orphan instances for GHC.
9-- | Orphan instances for GHC.
8-- Note that the 'NFData' instances may not be law abiding.
10-- Note that the 'NFData' instances may not be law abiding.
@@ -31,7 +33,7 @@ instance NFData Linkable where rnf = rwhnf
31instance Show InstalledUnitId where
33instance Show InstalledUnitId where
32 show = installedUnitIdString
34 show = installedUnitIdString
33
35
34−instance NFData InstalledUnitId where rnf = rwhnf
36+instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS
35
37
36instance NFData SB.StringBuffer where rnf = rwhnf
38instance NFData SB.StringBuffer where rnf = rwhnf
37
39
@@ -40,8 +42,8 @@ instance Show Module where
40
42
41instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint
43instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint
42
44
43−instance NFData (GenLocated SrcSpan ModuleName) where
45+instance (NFData l, NFData e) => NFData (GenLocated l e) where
44− rnf = rwhnf
46+ rnf (L l e) = rnf l `seq` rnf e
45
47
46instance Show ModSummary where
48instance Show ModSummary where
47 show = show . ms_mod
49 show = show . ms_mod
@@ -52,6 +54,11 @@ instance Show ParsedModule where
52instance NFData ModSummary where
54instance NFData ModSummary where
53 rnf = rwhnf
55 rnf = rwhnf
54
56
57+#if !MIN_GHC_API_VERSION(8,10,0)
58+instance NFData FastString where
59+ rnf = rwhnf
60+#endif
61+
55instance NFData ParsedModule where
62instance NFData ParsedModule where
56 rnf = rwhnf
63 rnf = rwhnf
57
64
src/Development/IDE/GHC/Util.hs+102−53
@@ -1,42 +1,44 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4−{-# OPTIONS_GHC -Wno-missing-fields #-} -- to enable prettyPrint
5−{-# LANGUAGE CPP #-}
6−#include "ghc-api-version.h"
7−
8-- | General utility functions, mostly focused around GHC operations.
4-- | General utility functions, mostly focused around GHC operations.
9module Development.IDE.GHC.Util(
5module Development.IDE.GHC.Util(
10 -- * HcsEnv and environment
6 -- * HcsEnv and environment
11− HscEnvEq, hscEnv, newHscEnvEq,
7+ HscEnvEq(GhcVersionMismatch, compileTime, runTime), hscEnv, newHscEnvEq,
12 modifyDynFlags,
8 modifyDynFlags,
13− fakeDynFlags,
9+ evalGhcEnv,
14 runGhcEnv,
10 runGhcEnv,
11+ deps,
15 -- * GHC wrappers
12 -- * GHC wrappers
16 prettyPrint,
13 prettyPrint,
14+ printRdrName,
15+ printName,
16+ ParseResult(..), runParser,
17 lookupPackageConfig,
17 lookupPackageConfig,
18+ textToStringBuffer,
19+ stringBufferToByteString,
18 moduleImportPath,
20 moduleImportPath,
19 cgGutsToCoreModule,
21 cgGutsToCoreModule,
20 fingerprintToBS,
22 fingerprintToBS,
21 fingerprintFromStringBuffer,
23 fingerprintFromStringBuffer,
22 -- * General utilities
24 -- * General utilities
23− textToStringBuffer,
24 readFileUtf8,
25 readFileUtf8,
25 hDuplicateTo',
26 hDuplicateTo',
27+ setDefaultHieDir,
28+ dontWriteHieFiles
26 ) where
29 ) where
27
30
28−import Config
29import Control.Concurrent
31import Control.Concurrent
30import Data.List.Extra
32import Data.List.Extra
33+import Data.ByteString.Internal (ByteString(..))
31import Data.Maybe
34import Data.Maybe
32import Data.Typeable
35import Data.Typeable
33import qualified Data.ByteString.Internal as BS
36import qualified Data.ByteString.Internal as BS
34import Fingerprint
37import Fingerprint
35−import GHC
36import GhcMonad
38import GhcMonad
37−import GhcPlugins hiding (Unique)
38−import Data.IORef
39import Control.Exception
39import Control.Exception
40+import Data.IORef
41+import Data.Version (showVersion, Version)
40import FileCleanup
42import FileCleanup
41import Foreign.Ptr
43import Foreign.Ptr
42import Foreign.ForeignPtr
44import Foreign.ForeignPtr
@@ -47,16 +49,27 @@ import GHC.IO.Encoding
47import GHC.IO.Exception
49import GHC.IO.Exception
48import GHC.IO.Handle.Types
50import GHC.IO.Handle.Types
49import GHC.IO.Handle.Internals
51import GHC.IO.Handle.Internals
50−import Platform
51import Data.Unique
52import Data.Unique
52import Development.Shake.Classes
53import Development.Shake.Classes
53import qualified Data.Text as T
54import qualified Data.Text as T
54import qualified Data.Text.Encoding as T
55import qualified Data.Text.Encoding as T
55import qualified Data.Text.Encoding.Error as T
56import qualified Data.Text.Encoding.Error as T
56import qualified Data.ByteString as BS
57import qualified Data.ByteString as BS
58+import Lexer
57import StringBuffer
59import StringBuffer
58import System.FilePath
60import System.FilePath
61+import HscTypes (cg_binds, md_types, cg_module, ModDetails, CgGuts, ic_dflags, hsc_IC, HscEnv(hsc_dflags))
62+import PackageConfig (PackageConfig)
63+import Outputable (showSDocUnsafe, ppr, showSDoc, Outputable)
64+import Packages (getPackageConfigMap, lookupPackage')
65+import SrcLoc (mkRealSrcLoc)
66+import FastString (mkFastString)
67+import DynFlags (emptyFilesToClean, unsafeGlobalDynFlags)
68+import Module (moduleNameSlashes, InstalledUnitId)
69+import OccName (parenSymOcc)
70+import RdrName (nameRdrName, rdrNameOcc)
59
71
72+import Development.IDE.GHC.Compat as GHC
60import Development.IDE.Types.Location
73import Development.IDE.Types.Location
61
74
62
75
@@ -89,87 +102,123 @@ lookupPackageConfig unitId env =
89textToStringBuffer :: T.Text -> StringBuffer
102textToStringBuffer :: T.Text -> StringBuffer
90textToStringBuffer = stringToStringBuffer . T.unpack
103textToStringBuffer = stringToStringBuffer . T.unpack
91
104
105+runParser :: DynFlags -> String -> P a -> ParseResult a
106+runParser flags str parser = unP parser parseState
107+ where
108+ filename = "<interactive>"
109+ location = mkRealSrcLoc (mkFastString filename) 1 1
110+ buffer = stringToStringBuffer str
111+ parseState = mkPState flags buffer location
112+
113+stringBufferToByteString :: StringBuffer -> ByteString
114+stringBufferToByteString StringBuffer{..} = PS buf cur len
92
115
93−-- | Pretty print a GHC value using 'fakeDynFlags'.
116+-- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.
94prettyPrint :: Outputable a => a -> String
117prettyPrint :: Outputable a => a -> String
95−prettyPrint = showSDoc fakeDynFlags . ppr
118+prettyPrint = showSDoc unsafeGlobalDynFlags . ppr
119+
120+-- | Pretty print a 'RdrName' wrapping operators in parens
121+printRdrName :: RdrName -> String
122+printRdrName name = showSDocUnsafe $ parenSymOcc rn (ppr rn)
123+ where
124+ rn = rdrNameOcc name
125+
126+-- | Pretty print a 'Name' wrapping operators in parens
127+printName :: Name -> String
128+printName = printRdrName . nameRdrName
96
129
97-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required
130-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required
98-- pieces, but designed to be more efficient than a standard 'runGhc'.
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'.
99−runGhcEnv :: HscEnv -> Ghc a -> IO a
137+runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a)
100runGhcEnv env act = do
138runGhcEnv env act = do
101 filesToClean <- newIORef emptyFilesToClean
139 filesToClean <- newIORef emptyFilesToClean
102 dirsToClean <- newIORef mempty
140 dirsToClean <- newIORef mempty
103 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}
141 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}
104 ref <- newIORef env{hsc_dflags=dflags}
142 ref <- newIORef env{hsc_dflags=dflags}
105− unGhc act (Session ref) `finally` do
143+ res <- unGhc act (Session ref) `finally` do
106 cleanTempFiles dflags
144 cleanTempFiles dflags
107 cleanTempDirs dflags
145 cleanTempDirs dflags
108−
146+ (,res) <$> readIORef ref
109−-- | A 'DynFlags' value where most things are undefined. It's sufficient to call pretty printing,
110−-- but not much else.
111−fakeDynFlags :: DynFlags
112−fakeDynFlags = defaultDynFlags settings mempty
113− where
114− settings = Settings
115− { sTargetPlatform = platform
116− , sPlatformConstants = platformConstants
117− , sProgramName = "ghc"
118− , sProjectVersion = cProjectVersion
119−#if MIN_GHC_API_VERSION(8,6,0)
120− , sOpt_P_fingerprint = fingerprint0
121−#endif
122− }
123− platform = Platform
124− { platformWordSize=8
125− , platformOS=OSUnknown
126− , platformUnregisterised=True
127− }
128− platformConstants = PlatformConstants
129− { pc_DYNAMIC_BY_DEFAULT=False
130− , pc_WORD_SIZE=8
131− }
132
147
133-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.
148-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.
134-- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory
149-- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory
135-- @\/usr\/Test@ should be on the include path to find sibling modules.
150-- @\/usr\/Test@ should be on the include path to find sibling modules.
136−moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath
151+moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath
137-- The call to takeDirectory is required since DAML does not require that
152-- The call to takeDirectory is required since DAML does not require that
138-- the file name matches the module name in the last component.
153-- the file name matches the module name in the last component.
139-- Once that has changed we can get rid of this.
154-- Once that has changed we can get rid of this.
140−moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm
155+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn
141 -- This happens for single-component modules since takeDirectory "A" == "."
156 -- This happens for single-component modules since takeDirectory "A" == "."
142 | modDir == "." = Just pathDir
157 | modDir == "." = Just pathDir
143 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir
158 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir
144 where
159 where
145− ms = GHC.pm_mod_summary pm
146− mod' = GHC.ms_mod ms
147 -- A for module A.B
160 -- A for module A.B
148 modDir =
161 modDir =
149 takeDirectory $
162 takeDirectory $
150− fromNormalizedFilePath $ toNormalizedFilePath $
163+ fromNormalizedFilePath $ toNormalizedFilePath' $
151− moduleNameSlashes $ GHC.moduleName mod'
164+ moduleNameSlashes mn
152
165
153-- | An 'HscEnv' with equality. Two values are considered equal
166-- | An 'HscEnv' with equality. Two values are considered equal
154-- if they are created with the same call to 'newHscEnvEq'.
167-- if they are created with the same call to 'newHscEnvEq'.
168+data HscEnvEq
155−data HscEnvEq = HscEnvEq Unique HscEnv
169+ = HscEnvEq !Unique !HscEnv
170+ [(InstalledUnitId, DynFlags)] -- In memory components for this HscEnv
171+ -- This is only used at the moment for the import dirs in
172+ -- the DynFlags
173+ | GhcVersionMismatch { compileTime :: !Version
174+ , runTime :: !Version
175+ }
156
176
157-- | Unwrap an 'HsEnvEq'.
177-- | Unwrap an 'HsEnvEq'.
158hscEnv :: HscEnvEq -> HscEnv
178hscEnv :: HscEnvEq -> HscEnv
179+hscEnv = either error id . hscEnv'
180+
181+hscEnv' :: HscEnvEq -> Either String HscEnv
159−hscEnv (HscEnvEq _ x) = x
182+hscEnv' (HscEnvEq _ x _) = Right x
183+hscEnv' GhcVersionMismatch{..} = Left $
184+ unwords
185+ ["ghcide compiled against GHC"
186+ ,showVersion compileTime
187+ ,"but currently using"
188+ ,showVersion runTime
189+ ,". This is unsupported, ghcide must be compiled with the same GHC version as the project."
190+ ]
191+
192+deps :: HscEnvEq -> [(InstalledUnitId, DynFlags)]
193+deps (HscEnvEq _ _ u) = u
194+deps GhcVersionMismatch{} = []
160
195
161-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
196-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
162−newHscEnvEq :: HscEnv -> IO HscEnvEq
197+newHscEnvEq :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
163−newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e
198+newHscEnvEq e uids = do u <- newUnique; return $ HscEnvEq u e uids
164
199
165instance Show HscEnvEq where
200instance Show HscEnvEq where
166− show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)
201+ show (HscEnvEq a _ _) = "HscEnvEq " ++ show (hashUnique a)
202+ show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)
167
203
168instance Eq HscEnvEq where
204instance Eq HscEnvEq where
169− HscEnvEq a _ == HscEnvEq b _ = a == b
205+ HscEnvEq a _ _ == HscEnvEq b _ _ = a == b
206+ GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d
207+ _ == _ = False
170
208
171instance NFData HscEnvEq where
209instance NFData HscEnvEq where
172− rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()
210+ rnf (HscEnvEq a b c) = rnf (hashUnique a) `seq` b `seq` c `seq` ()
211+ rnf GhcVersionMismatch{} = rnf runTime
212+
213+instance Hashable HscEnvEq where
214+ hashWithSalt s (HscEnvEq a _b _c) = hashWithSalt s a
215+ hashWithSalt salt GhcVersionMismatch{..} = hashWithSalt salt (compileTime, runTime)
216+
217+-- Fake instance needed to persuade Shake to accept this type as a key.
218+-- No harm done as ghcide never persists these keys currently
219+instance Binary HscEnvEq where
220+ put _ = error "not really"
221+ get = error "not really"
173
222
174-- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error.
223-- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error.
175readFileUtf8 :: FilePath -> IO T.Text
224readFileUtf8 :: FilePath -> IO T.Text
src/Development/IDE/GHC/WithDynFlags.hsnew file+30
@@ -0,0 +1,30 @@
1+module Development.IDE.GHC.WithDynFlags
2+( WithDynFlags
3+, evalWithDynFlags
4+) where
5+
6+import Control.Monad.Trans.Reader (ask, ReaderT(..))
7+import GHC (DynFlags)
8+import Control.Monad.IO.Class (MonadIO)
9+import Exception (ExceptionMonad(..))
10+import Control.Monad.Trans.Class (MonadTrans(..))
11+import GhcPlugins (HasDynFlags(..))
12+
13+-- | A monad transformer implementing the 'HasDynFlags' effect
14+newtype WithDynFlags m a = WithDynFlags {withDynFlags :: ReaderT DynFlags m a}
15+ deriving (Applicative, Functor, Monad, MonadIO, MonadTrans)
16+
17+evalWithDynFlags :: DynFlags -> WithDynFlags m a -> m a
18+evalWithDynFlags dflags = flip runReaderT dflags . withDynFlags
19+
20+instance Monad m => HasDynFlags (WithDynFlags m) where
21+ getDynFlags = WithDynFlags ask
22+
23+instance ExceptionMonad m => ExceptionMonad (WithDynFlags m) where
24+ gmask f = WithDynFlags $ ReaderT $ \env ->
25+ gmask $ \restore ->
26+ let restore' = lift . restore . flip runReaderT env . withDynFlags
27+ in runReaderT (withDynFlags $ f restore') env
28+
29+ gcatch (WithDynFlags act) handle = WithDynFlags $ ReaderT $ \env ->
30+ gcatch (runReaderT act env) (flip runReaderT env . withDynFlags . handle)
src/Development/IDE/Import/DependencyInformation.hs+121−34
@@ -9,26 +9,33 @@ module Development.IDE.Import.DependencyInformation
9 , ModuleParseError(..)
9 , ModuleParseError(..)
10 , TransitiveDependencies(..)
10 , TransitiveDependencies(..)
11 , FilePathId(..)
11 , FilePathId(..)
12+ , NamedModuleDep(..)
12
13
13 , PathIdMap
14 , PathIdMap
14 , emptyPathIdMap
15 , emptyPathIdMap
15 , getPathId
16 , getPathId
17+ , lookupPathToId
16 , insertImport
18 , insertImport
17 , pathToId
19 , pathToId
18 , idToPath
20 , idToPath
19 , reachableModules
21 , reachableModules
20−
21 , processDependencyInformation
22 , processDependencyInformation
22 , transitiveDeps
23 , transitiveDeps
24+
25+ , BootIdMap
26+ , insertBootId
23 ) where
27 ) where
24
28
25import Control.DeepSeq
29import Control.DeepSeq
26import Data.Bifunctor
30import Data.Bifunctor
27import Data.Coerce
31import Data.Coerce
28import Data.List
32import Data.List
33+import Data.Tuple.Extra hiding (first, second)
29import Development.IDE.GHC.Orphans()
34import Development.IDE.GHC.Orphans()
30import Data.Either
35import Data.Either
31import Data.Graph
36import Data.Graph
37+import Data.HashMap.Strict (HashMap)
38+import qualified Data.HashMap.Strict as HMS
32import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
39import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
33import qualified Data.List.NonEmpty as NonEmpty
40import qualified Data.List.NonEmpty as NonEmpty
34import Data.IntMap (IntMap)
41import Data.IntMap (IntMap)
@@ -36,16 +43,14 @@ import qualified Data.IntMap.Strict as IntMap
36import qualified Data.IntMap.Lazy as IntMapLazy
43import qualified Data.IntMap.Lazy as IntMapLazy
37import Data.IntSet (IntSet)
44import Data.IntSet (IntSet)
38import qualified Data.IntSet as IntSet
45import qualified Data.IntSet as IntSet
39−import Data.Map (Map)
40−import qualified Data.Map.Strict as MS
41import Data.Maybe
46import Data.Maybe
42import Data.Set (Set)
47import Data.Set (Set)
43import qualified Data.Set as Set
48import qualified Data.Set as Set
44−import Data.Tuple.Extra (fst3)
45import GHC.Generics (Generic)
49import GHC.Generics (Generic)
46
50
47import Development.IDE.Types.Diagnostics
51import Development.IDE.Types.Diagnostics
48import Development.IDE.Types.Location
52import Development.IDE.Types.Location
53+import Development.IDE.Import.FindImports (ArtifactsLocation(..))
49
54
50import GHC
55import GHC
51import Module
56import Module
@@ -57,69 +62,100 @@ data ModuleImports = ModuleImports
57 -- that module on disk (if we found it)
62 -- that module on disk (if we found it)
58 , packageImports :: !(Set InstalledUnitId)
63 , packageImports :: !(Set InstalledUnitId)
59 -- ^ Transitive package dependencies unioned for all imports.
64 -- ^ Transitive package dependencies unioned for all imports.
60− }
65+ } deriving Show
61
66
62−-- | For processing dependency information, we need lots of maps and sets
67+-- | For processing dependency information, we need lots of maps and sets of
63−-- of filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet
68+-- filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet
64−-- instead and only convert at the edges
69+-- instead and only convert at the edges.
65−-- and
66newtype FilePathId = FilePathId { getFilePathId :: Int }
70newtype FilePathId = FilePathId { getFilePathId :: Int }
67 deriving (Show, NFData, Eq, Ord)
71 deriving (Show, NFData, Eq, Ord)
68
72
73+-- | Map from 'FilePathId'
74+type FilePathIdMap = IntMap
75+
76+-- | Set of 'FilePathId's
77+type FilePathIdSet = IntSet
78+
69data PathIdMap = PathIdMap
79data PathIdMap = PathIdMap
70− { idToPathMap :: !(IntMap NormalizedFilePath)
80+ { idToPathMap :: !(FilePathIdMap ArtifactsLocation)
71− , pathToIdMap :: !(Map NormalizedFilePath FilePathId)
81+ , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)
72 }
82 }
73 deriving (Show, Generic)
83 deriving (Show, Generic)
74
84
75instance NFData PathIdMap
85instance NFData PathIdMap
76
86
77emptyPathIdMap :: PathIdMap
87emptyPathIdMap :: PathIdMap
78−emptyPathIdMap = PathIdMap IntMap.empty MS.empty
88+emptyPathIdMap = PathIdMap IntMap.empty HMS.empty
79
89
80−getPathId :: NormalizedFilePath -> PathIdMap -> (FilePathId, PathIdMap)
90+getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap)
81getPathId path m@PathIdMap{..} =
91getPathId path m@PathIdMap{..} =
82− case MS.lookup path pathToIdMap of
92+ case HMS.lookup (artifactFilePath path) pathToIdMap of
83 Nothing ->
93 Nothing ->
84− let !newId = FilePathId $ MS.size pathToIdMap
94+ let !newId = FilePathId $ HMS.size pathToIdMap
85 in (newId, insertPathId path newId m)
95 in (newId, insertPathId path newId m)
86 Just id -> (id, m)
96 Just id -> (id, m)
87
97
88−insertPathId :: NormalizedFilePath -> FilePathId -> PathIdMap -> PathIdMap
98+insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap
89insertPathId path id PathIdMap{..} =
99insertPathId path id PathIdMap{..} =
90− PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (MS.insert path id pathToIdMap)
100+ PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert (artifactFilePath path) id pathToIdMap)
91
101
92insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation
102insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation
93insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }
103insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }
94
104
95pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId
105pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId
96−pathToId PathIdMap{pathToIdMap} path = pathToIdMap MS.! path
106+pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path
107+
108+lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId
109+lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap
97
110
98idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath
111idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath
112+idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId
113+
114+idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation
99−idToPath PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id
115+idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id
116+
117+type BootIdMap = FilePathIdMap FilePathId
118+
119+insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap
120+insertBootId k = IntMap.insert (getFilePathId k)
100
121
101-- | Unprocessed results that we find by following imports recursively.
122-- | Unprocessed results that we find by following imports recursively.
102data RawDependencyInformation = RawDependencyInformation
123data RawDependencyInformation = RawDependencyInformation
103− { rawImports :: !(IntMap (Either ModuleParseError ModuleImports))
124+ { rawImports :: !(FilePathIdMap (Either ModuleParseError ModuleImports))
104 , rawPathIdMap :: !PathIdMap
125 , rawPathIdMap :: !PathIdMap
105− }
126+ -- The rawBootMap maps the FilePathId of a hs-boot file to its
106−
127+ -- corresponding hs file. It is used when topologically sorting as we
128+ -- need to add edges between .hs-boot and .hs so that the .hs files
129+ -- appear later in the sort.
130+ , rawBootMap :: !BootIdMap
131+ } deriving Show
132+
107−pkgDependencies :: RawDependencyInformation -> IntMap (Set InstalledUnitId)
133+pkgDependencies :: RawDependencyInformation -> FilePathIdMap (Set InstalledUnitId)
108pkgDependencies RawDependencyInformation{..} =
134pkgDependencies RawDependencyInformation{..} =
109 IntMap.map (either (const Set.empty) packageImports) rawImports
135 IntMap.map (either (const Set.empty) packageImports) rawImports
110
136
111data DependencyInformation =
137data DependencyInformation =
112 DependencyInformation
138 DependencyInformation
113− { depErrorNodes :: !(IntMap (NonEmpty NodeError))
139+ { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError))
114 -- ^ Nodes that cannot be processed correctly.
140 -- ^ Nodes that cannot be processed correctly.
141+ , depModuleNames :: !(FilePathIdMap ShowableModuleName)
115− , depModuleDeps :: !(IntMap IntSet)
142+ , depModuleDeps :: !(FilePathIdMap FilePathIdSet)
116 -- ^ For a non-error node, this contains the set of module immediate dependencies
143 -- ^ For a non-error node, this contains the set of module immediate dependencies
117 -- in the same package.
144 -- in the same package.
118− , depPkgDeps :: !(IntMap (Set InstalledUnitId))
145+ , depPkgDeps :: !(FilePathIdMap (Set InstalledUnitId))
119 -- ^ For a non-error node, this contains the set of immediate pkg deps.
146 -- ^ For a non-error node, this contains the set of immediate pkg deps.
120 , depPathIdMap :: !PathIdMap
147 , depPathIdMap :: !PathIdMap
148+ -- ^ Map from FilePath to FilePathId
149+ , depBootMap :: !BootIdMap
150+ -- ^ Map from hs-boot file to the corresponding hs file
121 } deriving (Show, Generic)
151 } deriving (Show, Generic)
122
152
153+newtype ShowableModuleName =
154+ ShowableModuleName {showableModuleName :: ModuleName}
155+ deriving NFData
156+
157+instance Show ShowableModuleName where show = moduleNameString . showableModuleName
158+
123reachableModules :: DependencyInformation -> [NormalizedFilePath]
159reachableModules :: DependencyInformation -> [NormalizedFilePath]
124reachableModules DependencyInformation{..} =
160reachableModules DependencyInformation{..} =
125 map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps
161 map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps
@@ -186,23 +222,32 @@ processDependencyInformation rawDepInfo@RawDependencyInformation{..} =
186 DependencyInformation
222 DependencyInformation
187 { depErrorNodes = IntMap.fromList errorNodes
223 { depErrorNodes = IntMap.fromList errorNodes
188 , depModuleDeps = moduleDeps
224 , depModuleDeps = moduleDeps
225+ , depModuleNames = IntMap.fromList $ coerce moduleNames
189 , depPkgDeps = pkgDependencies rawDepInfo
226 , depPkgDeps = pkgDependencies rawDepInfo
190 , depPathIdMap = rawPathIdMap
227 , depPathIdMap = rawPathIdMap
228+ , depBootMap = rawBootMap
191 }
229 }
192 where resultGraph = buildResultGraph rawImports
230 where resultGraph = buildResultGraph rawImports
193 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph
231 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph
232+ moduleNames :: [(FilePathId, ModuleName)]
233+ moduleNames =
234+ [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports]
194 successEdges :: [(FilePathId, FilePathId, [FilePathId])]
235 successEdges :: [(FilePathId, FilePathId, [FilePathId])]
195 successEdges =
236 successEdges =
237+ map
196− map (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports)) successNodes
238+ (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports))
239+ successNodes
197 moduleDeps =
240 moduleDeps =
241+ IntMap.fromList $
198− IntMap.fromList $ map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs)) successEdges
242+ map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs))
243+ successEdges
199
244
200-- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:
245-- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:
201-- 1. Mark each node that is part of an import cycle as an error node.
246-- 1. Mark each node that is part of an import cycle as an error node.
202-- 2. Mark each node that has a parse error as an error node.
247-- 2. Mark each node that has a parse error as an error node.
203-- 3. Mark each node whose immediate children could not be located as an error.
248-- 3. Mark each node whose immediate children could not be located as an error.
204-- 4. Recursively propagate errors to parents if they are not already error nodes.
249-- 4. Recursively propagate errors to parents if they are not already error nodes.
205−buildResultGraph :: IntMap (Either ModuleParseError ModuleImports) -> IntMap NodeResult
250+buildResultGraph :: FilePathIdMap (Either ModuleParseError ModuleImports) -> FilePathIdMap NodeResult
206buildResultGraph g = propagatedErrors
251buildResultGraph g = propagatedErrors
207 where
252 where
208 sccs = stronglyConnComp (graphEdges g)
253 sccs = stronglyConnComp (graphEdges g)
@@ -249,7 +294,7 @@ buildResultGraph g = propagatedErrors
249 Right ModuleImports{moduleImports} ->
294 Right ModuleImports{moduleImports} ->
250 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports
295 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports
251
296
252−graphEdges :: IntMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]
297+graphEdges :: FilePathIdMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]
253graphEdges g =
298graphEdges g =
254 map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g
299 map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g
255 where deps :: Either e ModuleImports -> [FilePathId]
300 where deps :: Either e ModuleImports -> [FilePathId]
@@ -261,29 +306,71 @@ partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest
261partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest
306partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest
262partitionSCC [] = ([], [])
307partitionSCC [] = ([], [])
263
308
309+
264transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
310transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
265transitiveDeps DependencyInformation{..} file = do
311transitiveDeps DependencyInformation{..} file = do
266 let !fileId = pathToId depPathIdMap file
312 let !fileId = pathToId depPathIdMap file
267 reachableVs <-
313 reachableVs <-
314+ -- Delete the starting node
268 IntSet.delete (getFilePathId fileId) .
315 IntSet.delete (getFilePathId fileId) .
269 IntSet.fromList . map (fst3 . fromVertex) .
316 IntSet.fromList . map (fst3 . fromVertex) .
270 reachable g <$> toVertex (getFilePathId fileId)
317 reachable g <$> toVertex (getFilePathId fileId)
318+ let transitiveModuleDepIds =
271− let transitiveModuleDepIds = filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs
319+ filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs
272 let transitivePkgDeps =
320 let transitivePkgDeps =
273 Set.toList $ Set.unions $
321 Set.toList $ Set.unions $
274 map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $
322 map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $
275 getFilePathId fileId : transitiveModuleDepIds
323 getFilePathId fileId : transitiveModuleDepIds
324+ let transitiveModuleDeps =
276− let transitiveModuleDeps = map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds
325+ map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds
326+ let transitiveNamedModuleDeps =
327+ [ NamedModuleDep (idToPath depPathIdMap (FilePathId fid)) mn artifactModLocation
328+ | (fid, ShowableModuleName mn) <- IntMap.toList depModuleNames
329+ , let ArtifactsLocation{artifactModLocation} = idToPathMap depPathIdMap IntMap.! fid
330+ ]
277 pure TransitiveDependencies {..}
331 pure TransitiveDependencies {..}
332+ where
333+ (g, fromVertex, toVertex) = graphFromEdges edges
278− where (g, fromVertex, toVertex) = graphFromEdges (map (\(f, fs) -> (f, f, IntSet.toList fs)) $ IntMap.toList depModuleDeps)
334+ edges = map (\(f, fs) -> (f, f, IntSet.toList fs ++ boot_edge f)) $ IntMap.toList depModuleDeps
335+
336+ -- Need to add an edge between the .hs and .hs-boot file if it exists
337+ -- so the .hs file gets loaded after the .hs-boot file and the right
338+ -- stuff ends up in the HPT. If you don't have this check then GHC will
339+ -- fail to work with ghcide.
340+ boot_edge f = [getFilePathId f' | Just f' <- [IntMap.lookup f depBootMap]]
341+
279− vs = topSort g
342+ vs = topSort g
280
343
281data TransitiveDependencies = TransitiveDependencies
344data TransitiveDependencies = TransitiveDependencies
282 { transitiveModuleDeps :: [NormalizedFilePath]
345 { transitiveModuleDeps :: [NormalizedFilePath]
283 -- ^ Transitive module dependencies in topological order.
346 -- ^ Transitive module dependencies in topological order.
284 -- The module itself is not included.
347 -- The module itself is not included.
348+ , transitiveNamedModuleDeps :: [NamedModuleDep]
349+ -- ^ Transitive module dependencies in topological order.
350+ -- The module itself is not included.
285 , transitivePkgDeps :: [InstalledUnitId]
351 , transitivePkgDeps :: [InstalledUnitId]
286 -- ^ Transitive pkg dependencies in unspecified order.
352 -- ^ Transitive pkg dependencies in unspecified order.
287 } deriving (Eq, Show, Generic)
353 } deriving (Eq, Show, Generic)
288
354
289instance NFData TransitiveDependencies
355instance NFData TransitiveDependencies
356+
357+data NamedModuleDep = NamedModuleDep {
358+ nmdFilePath :: !NormalizedFilePath,
359+ nmdModuleName :: !ModuleName,
360+ nmdModLocation :: !ModLocation
361+ }
362+ deriving Generic
363+
364+instance Eq NamedModuleDep where
365+ a == b = nmdFilePath a == nmdFilePath b
366+
367+instance NFData NamedModuleDep where
368+ rnf NamedModuleDep{..} =
369+ rnf nmdFilePath `seq`
370+ rnf nmdModuleName `seq`
371+ -- 'ModLocation' lacks an 'NFData' instance
372+ rwhnf nmdModLocation
373+
374+instance Show NamedModuleDep where
375+ show NamedModuleDep{..} = show nmdFilePath
376+
src/Development/IDE/Import/FindImports.hs+63−17
@@ -7,16 +7,19 @@
7module Development.IDE.Import.FindImports
7module Development.IDE.Import.FindImports
8 ( locateModule
8 ( locateModule
9 , Import(..)
9 , Import(..)
10+ , ArtifactsLocation(..)
11+ , modSummaryToArtifactsLocation
12+ , isBootLocation
13+ , mkImportDirs
10 ) where
14 ) where
11
15
12import Development.IDE.GHC.Error as ErrUtils
16import Development.IDE.GHC.Error as ErrUtils
13import Development.IDE.GHC.Orphans()
17import Development.IDE.GHC.Orphans()
14import Development.IDE.Types.Diagnostics
18import Development.IDE.Types.Diagnostics
15import Development.IDE.Types.Location
19import Development.IDE.Types.Location
20+import Development.IDE.GHC.Compat
16-- GHC imports
21-- GHC imports
17−import DynFlags
18import FastString
22import FastString
19−import GHC
20import qualified Module as M
23import qualified Module as M
21import Packages
24import Packages
22import Outputable (showSDoc, ppr, pprPanic)
25import Outputable (showSDoc, ppr, pprPanic)
@@ -27,64 +30,107 @@ import Control.DeepSeq
27import Control.Monad.Extra
30import Control.Monad.Extra
28import Control.Monad.IO.Class
31import Control.Monad.IO.Class
29import System.FilePath
32import System.FilePath
33+import DriverPhases
34+import Data.Maybe
30
35
31data Import
36data Import
32− = FileImport !NormalizedFilePath
37+ = FileImport !ArtifactsLocation
33 | PackageImport !M.InstalledUnitId
38 | PackageImport !M.InstalledUnitId
34 deriving (Show)
39 deriving (Show)
35
40
41+data ArtifactsLocation = ArtifactsLocation
42+ { artifactFilePath :: !NormalizedFilePath
43+ , artifactModLocation :: !ModLocation
44+ , artifactIsSource :: !Bool -- ^ True if a module is a source input
45+ }
46+ deriving (Show)
47+
48+instance NFData ArtifactsLocation where
49+ rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource
50+
51+isBootLocation :: ArtifactsLocation -> Bool
52+isBootLocation = not . artifactIsSource
53+
36instance NFData Import where
54instance NFData Import where
37 rnf (FileImport x) = rnf x
55 rnf (FileImport x) = rnf x
38 rnf (PackageImport x) = rnf x
56 rnf (PackageImport x) = rnf x
39
57
58+modSummaryToArtifactsLocation :: NormalizedFilePath -> ModSummary -> ArtifactsLocation
59+modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location ms) (isSource (ms_hsc_src ms))
60+ where
61+ isSource HsSrcFile = True
62+ isSource _ = False
63+
40
64
41-- | locate a module in the file system. Where we go from *daml to Haskell
65-- | locate a module in the file system. Where we go from *daml to Haskell
42locateModuleFile :: MonadIO m
66locateModuleFile :: MonadIO m
43− => DynFlags
67+ => [[FilePath]]
44 -> [String]
68 -> [String]
45 -> (NormalizedFilePath -> m Bool)
69 -> (NormalizedFilePath -> m Bool)
46 -> Bool
70 -> Bool
47 -> ModuleName
71 -> ModuleName
48 -> m (Maybe NormalizedFilePath)
72 -> m (Maybe NormalizedFilePath)
49−locateModuleFile dflags exts doesExist isSource modName = do
73+locateModuleFile import_dirss exts doesExist isSource modName = do
50− let candidates =
74+ let candidates import_dirs =
51− [ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)
75+ [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)
52− | prefix <- importPaths dflags, ext <- exts]
76+ | prefix <- import_dirs , ext <- exts]
53− findM doesExist candidates
77+ findM doesExist (concatMap candidates import_dirss)
54 where
78 where
55 maybeBoot ext
79 maybeBoot ext
56 | isSource = ext ++ "-boot"
80 | isSource = ext ++ "-boot"
57 | otherwise = ext
81 | otherwise = ext
58
82
83+-- | This function is used to map a package name to a set of import paths.
84+-- It only returns Just for unit-ids which are possible to import into the
85+-- current module. In particular, it will return Nothing for 'main' components
86+-- as they can never be imported into another package.
87+mkImportDirs :: DynFlags -> (M.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath])
88+mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i
89+
59-- | locate a module in either the file system or the package database. Where we go from *daml to
90-- | locate a module in either the file system or the package database. Where we go from *daml to
60-- Haskell
91-- Haskell
61locateModule
92locateModule
62 :: MonadIO m
93 :: MonadIO m
63 => DynFlags
94 => DynFlags
95+ -> [(M.InstalledUnitId, DynFlags)] -- Sets import directories to look in
64 -> [String]
96 -> [String]
65 -> (NormalizedFilePath -> m Bool)
97 -> (NormalizedFilePath -> m Bool)
66 -> Located ModuleName
98 -> Located ModuleName
67 -> Maybe FastString
99 -> Maybe FastString
68 -> Bool
100 -> Bool
69 -> m (Either [FileDiagnostic] Import)
101 -> m (Either [FileDiagnostic] Import)
70−locateModule dflags exts doesExist modName mbPkgName isSource = do
102+locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do
71 case mbPkgName of
103 case mbPkgName of
72 -- "this" means that we should only look in the current package
104 -- "this" means that we should only look in the current package
73 Just "this" -> do
105 Just "this" -> do
74− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName
106+ lookupLocal [importPaths dflags]
75− case mbFile of
76− Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []
77− Just file -> return $ Right $ FileImport file
78 -- if a package name is given we only go look for a package
107 -- if a package name is given we only go look for a package
108+ Just pkgName
109+ | Just dirs <- lookup (PackageName pkgName) import_paths
110+ -> lookupLocal [dirs]
79− Just _pkgName -> lookupInPackageDB dflags
111+ | otherwise -> lookupInPackageDB dflags
80 Nothing -> do
112 Nothing -> do
81 -- first try to find the module as a file. If we can't find it try to find it in the package
113 -- first try to find the module as a file. If we can't find it try to find it in the package
82 -- database.
114 -- database.
115+ -- Here the importPaths for the current modules are added to the front of the import paths from the other components.
116+ -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in
117+ -- each component will end up being found in the wrong place and cause a multi-cradle match failure.
83− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName
118+ mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts doesExist isSource $ unLoc modName
84 case mbFile of
119 case mbFile of
85 Nothing -> lookupInPackageDB dflags
120 Nothing -> lookupInPackageDB dflags
86− Just file -> return $ Right $ FileImport file
121+ Just file -> toModLocation file
87 where
122 where
123+ import_paths = mapMaybe (mkImportDirs dflags) comp_info
124+ toModLocation file = liftIO $ do
125+ loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)
126+ return $ Right $ FileImport $ ArtifactsLocation file loc (not isSource)
127+
128+ lookupLocal dirs = do
129+ mbFile <- locateModuleFile dirs exts doesExist isSource $ unLoc modName
130+ case mbFile of
131+ Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []
132+ Just file -> toModLocation file
133+
88 lookupInPackageDB dfs =
134 lookupInPackageDB dfs =
89 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of
135 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of
90 LookupFound _m pkgConfig -> return $ Right $ PackageImport $ unitId pkgConfig
136 LookupFound _m pkgConfig -> return $ Right $ PackageImport $ unitId pkgConfig
src/Development/IDE/LSP/HoverDefinition.hs+9−6
@@ -6,6 +6,9 @@
6module Development.IDE.LSP.HoverDefinition
6module Development.IDE.LSP.HoverDefinition
7 ( setHandlersHover
7 ( setHandlersHover
8 , setHandlersDefinition
8 , setHandlersDefinition
9+ -- * For haskell-language-server
10+ , hover
11+ , gotoDefinition
9 ) where
12 ) where
10
13
11import Development.IDE.Core.Rules
14import Development.IDE.Core.Rules
@@ -20,8 +23,8 @@ import Language.Haskell.LSP.Types
20
23
21import qualified Data.Text as T
24import qualified Data.Text as T
22
25
23−gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO LocationResponseParams
26+gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)
24−hover :: IdeState -> TextDocumentPositionParams -> IO (Maybe Hover)
27+hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))
25gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc
28gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc
26hover = request "Hover" getAtPoint Nothing foundHover
29hover = request "Hover" getAtPoint Nothing foundHover
27
30
@@ -29,7 +32,7 @@ foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover
29foundHover (mbRange, contents) =
32foundHover (mbRange, contents) =
30 Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange
33 Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange
31
34
32−setHandlersDefinition, setHandlersHover :: PartialHandlers
35+setHandlersDefinition, setHandlersHover :: PartialHandlers c
33setHandlersDefinition = PartialHandlers $ \WithMessage{..} x ->
36setHandlersDefinition = PartialHandlers $ \WithMessage{..} x ->
34 return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition}
37 return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition}
35setHandlersHover = PartialHandlers $ \WithMessage{..} x ->
38setHandlersHover = PartialHandlers $ \WithMessage{..} x ->
@@ -43,16 +46,16 @@ request
43 -> (a -> b)
46 -> (a -> b)
44 -> IdeState
47 -> IdeState
45 -> TextDocumentPositionParams
48 -> TextDocumentPositionParams
46− -> IO b
49+ -> IO (Either ResponseError b)
47request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do
50request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do
48 mbResult <- case uriToFilePath' uri of
51 mbResult <- case uriToFilePath' uri of
49 Just path -> logAndRunRequest label getResults ide pos path
52 Just path -> logAndRunRequest label getResults ide pos path
50 Nothing -> pure Nothing
53 Nothing -> pure Nothing
51− pure $ maybe notFound found mbResult
54+ pure $ Right $ maybe notFound found mbResult
52
55
53logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b
56logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b
54logAndRunRequest label getResults ide pos path = do
57logAndRunRequest label getResults ide pos path = do
55− let filePath = toNormalizedFilePath path
58+ let filePath = toNormalizedFilePath' path
56 logInfo (ideLogger ide) $
59 logInfo (ideLogger ide) $
57 label <> " request at position " <> T.pack (showPosition pos) <>
60 label <> " request at position " <> T.pack (showPosition pos) <>
58 " in file: " <> T.pack path
61 " in file: " <> T.pack path
src/Development/IDE/LSP/LanguageServer.hs+54−28
@@ -28,21 +28,25 @@ 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
32+import Development.IDE.Core.Shake
31import Development.IDE.LSP.HoverDefinition
33import Development.IDE.LSP.HoverDefinition
32import Development.IDE.LSP.Notifications
34import Development.IDE.LSP.Notifications
33import Development.IDE.LSP.Outline
35import Development.IDE.LSP.Outline
34−import Development.IDE.Core.Service
35import Development.IDE.Types.Logger
36import Development.IDE.Types.Logger
36import Development.IDE.Core.FileStore
37import Development.IDE.Core.FileStore
37import Language.Haskell.LSP.Core (LspFuncs(..))
38import Language.Haskell.LSP.Core (LspFuncs(..))
38import Language.Haskell.LSP.Messages
39import Language.Haskell.LSP.Messages
39
40
40runLanguageServer
41runLanguageServer
42+ :: forall config. (Show config)
41− :: LSP.Options
43+ => LSP.Options
42− -> PartialHandlers
44+ -> PartialHandlers config
45+ -> (InitializeRequest -> Either T.Text config)
46+ -> (DidChangeConfigurationNotification -> Either T.Text config)
43 -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)
47 -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)
44 -> IO ()
48 -> IO ()
45−runLanguageServer options userHandlers getIdeState = do
49+runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do
46 -- Move stdout to another file descriptor and duplicate stderr
50 -- Move stdout to another file descriptor and duplicate stderr
47 -- to stdout. This guards against stray prints from corrupting the JSON-RPC
51 -- to stdout. This guards against stray prints from corrupting the JSON-RPC
48 -- message stream.
52 -- message stream.
@@ -59,7 +63,7 @@ runLanguageServer options userHandlers getIdeState = do
59
63
60 -- Send everything over a channel, since you need to wait until after initialise before
64 -- Send everything over a channel, since you need to wait until after initialise before
61 -- LspFuncs is available
65 -- LspFuncs is available
62− clientMsgChan :: Chan Message <- newChan
66+ clientMsgChan :: Chan (Message config) <- newChan
63
67
64 -- These barriers are signaled when the threads reading from these chans exit.
68 -- These barriers are signaled when the threads reading from these chans exit.
65 -- This should not happen but if it does, we will make sure that the whole server
69 -- This should not happen but if it does, we will make sure that the whole server
@@ -78,6 +82,7 @@ runLanguageServer options userHandlers getIdeState = do
78 let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do
82 let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do
79 atomically $ modifyTVar pendingRequests (Set.insert _id)
83 atomically $ modifyTVar pendingRequests (Set.insert _id)
80 writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f
84 writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f
85+ let withInitialize f = Just $ \r -> writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x)
81 let cancelRequest reqId = atomically $ do
86 let cancelRequest reqId = atomically $ do
82 queued <- readTVar pendingRequests
87 queued <- readTVar pendingRequests
83 -- We want to avoid that the list of cancelled requests
88 -- We want to avoid that the list of cancelled requests
@@ -94,6 +99,7 @@ runLanguageServer options userHandlers getIdeState = do
94 cancelled <- readTVar cancelledRequests
99 cancelled <- readTVar cancelledRequests
95 unless (reqId `Set.member` cancelled) retry
100 unless (reqId `Set.member` cancelled) retry
96 let PartialHandlers parts =
101 let PartialHandlers parts =
102+ initializeRequestHandler <>
97 setHandlersIgnore <> -- least important
103 setHandlersIgnore <> -- least important
98 setHandlersDefinition <> setHandlersHover <>
104 setHandlersDefinition <> setHandlersHover <>
99 setHandlersOutline <>
105 setHandlersOutline <>
@@ -102,11 +108,11 @@ runLanguageServer options userHandlers getIdeState = do
102 cancelHandler cancelRequest
108 cancelHandler cancelRequest
103 -- Cancel requests are special since they need to be handled
109 -- Cancel requests are special since they need to be handled
104 -- out of order to be useful. Existing handlers are run afterwards.
110 -- out of order to be useful. Existing handlers are run afterwards.
105− handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def
111+ handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def
106
112
107 let initializeCallbacks = LSP.InitializeCallbacks
113 let initializeCallbacks = LSP.InitializeCallbacks
108− { LSP.onInitialConfiguration = const $ Right ()
114+ { LSP.onInitialConfiguration = onInitialConfig
109− , LSP.onConfigurationChange = const $ Right ()
115+ , LSP.onConfigurationChange = onConfigChange
110 , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan
116 , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan
111 }
117 }
112
118
@@ -121,9 +127,11 @@ runLanguageServer options userHandlers getIdeState = do
121 , void $ waitBarrier clientMsgBarrier
127 , void $ waitBarrier clientMsgBarrier
122 ]
128 ]
123 where
129 where
124− handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs () -> IO (Maybe err)
130+ handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan (Message config) -> LSP.LspFuncs config -> IO (Maybe err)
125 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
131 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
132+
126 ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities
133 ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities
134+
127 _ <- flip forkFinally (const exitClientMsg) $ forever $ do
135 _ <- flip forkFinally (const exitClientMsg) $ forever $ do
128 msg <- readChan clientMsgChan
136 msg <- readChan clientMsgChan
129 case msg of
137 case msg of
@@ -134,17 +142,25 @@ runLanguageServer options userHandlers getIdeState = do
134 "Message: " ++ show x ++ "\n" ++
142 "Message: " ++ show x ++ "\n" ++
135 "Exception: " ++ show e
143 "Exception: " ++ show e
136 Response x@RequestMessage{_id, _params} wrap act ->
144 Response x@RequestMessage{_id, _params} wrap act ->
137− checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
145+ checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
146+ \case
138− \res -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
147+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)
148+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)
139 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->
149 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->
140 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
150 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
141 \(res, newReq) -> do
151 \(res, newReq) -> do
142− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
152+ case res of
143− case newReq of
153+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)
144− Nothing -> return ()
154+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)
145− Just (rm, newReqParams) -> do
155+ whenJust newReq $ \(rm, newReqParams) -> do
146 reqId <- getNextReqId
156 reqId <- getNextReqId
147 sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams
157 sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams
158+ InitialParams x@RequestMessage{_id, _params} act -> do
159+ catch (act lspFuncs ide _params) $ \(e :: SomeException) ->
160+ logError (ideLogger ide) $ T.pack $
161+ "Unexpected exception on InitializeRequest handler, please report!\n" ++
162+ "Message: " ++ show x ++ "\n" ++
163+ "Exception: " ++ show e
148 pure Nothing
164 pure Nothing
149
165
150 checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =
166 checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =
@@ -159,28 +175,39 @@ runLanguageServer options userHandlers getIdeState = do
159 Left () -> do
175 Left () -> do
160 logDebug (ideLogger ide) $ T.pack $
176 logDebug (ideLogger ide) $ T.pack $
161 "Cancelled request " <> show _id
177 "Cancelled request " <> show _id
162− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
178+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left
163− Just $ ResponseError RequestCancelled "" Nothing
179+ $ ResponseError RequestCancelled "" Nothing
164 Right res -> k res
180 Right res -> k res
165 ) $ \(e :: SomeException) -> do
181 ) $ \(e :: SomeException) -> do
166 logError (ideLogger ide) $ T.pack $
182 logError (ideLogger ide) $ T.pack $
167 "Unexpected exception on request, please report!\n" ++
183 "Unexpected exception on request, please report!\n" ++
168 "Message: " ++ show msg ++ "\n" ++
184 "Message: " ++ show msg ++ "\n" ++
169 "Exception: " ++ show e
185 "Exception: " ++ show e
170− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
186+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left
171− Just $ ResponseError InternalError (T.pack $ show e) Nothing
187+ $ ResponseError InternalError (T.pack $ show e) Nothing
172
188
189+initializeRequestHandler :: PartialHandlers config
190+initializeRequestHandler = PartialHandlers $ \WithMessage{..} x -> return x{
191+ LSP.initializeRequestHandler = withInitialize initHandler
192+ }
193+
194+initHandler
195+ :: LSP.LspFuncs c
196+ -> IdeState
197+ -> InitializeParams
198+ -> IO ()
199+initHandler _ ide params = registerIdeConfiguration (shakeExtras ide) (parseConfiguration params)
173
200
174-- | Things that get sent to us, but we don't deal with.
201-- | Things that get sent to us, but we don't deal with.
175-- Set them to avoid a warning in VS Code output.
202-- Set them to avoid a warning in VS Code output.
176−setHandlersIgnore :: PartialHandlers
203+setHandlersIgnore :: PartialHandlers config
177setHandlersIgnore = PartialHandlers $ \_ x -> return x
204setHandlersIgnore = PartialHandlers $ \_ x -> return x
178 {LSP.initializedHandler = none
205 {LSP.initializedHandler = none
179 ,LSP.responseHandler = none
206 ,LSP.responseHandler = none
180 }
207 }
181 where none = Just $ const $ return ()
208 where none = Just $ const $ return ()
182
209
183−cancelHandler :: (LspId -> IO ()) -> PartialHandlers
210+cancelHandler :: (LspId -> IO ()) -> PartialHandlers config
184cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
211cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
185 {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do
212 {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do
186 cancelRequest _id
213 cancelRequest _id
@@ -190,19 +217,18 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
190
217
191-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
218-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety
192-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
219-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)
193−data Message
220+data Message c
194− = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO resp)
221+ = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp))
195 -- | Used for cases in which we need to send not only a response,
222 -- | Used for cases in which we need to send not only a response,
196 -- but also an additional request to the client.
223 -- but also an additional request to the client.
197 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
224 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
198− | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams)))
225+ | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
199− | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ())
226+ | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())
200−
227+ -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler.
228+ | InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
201
229
202modifyOptions :: LSP.Options -> LSP.Options
230modifyOptions :: LSP.Options -> LSP.Options
203modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS
231modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS
204− , LSP.executeCommandCommands = Just ["typesignature.add"]
205− , LSP.completionTriggerCharacters = Just "."
206 }
232 }
207 where
233 where
208 tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}
234 tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}
src/Development/IDE/LSP/Notifications.hs+14−5
@@ -13,6 +13,7 @@ import qualified Language.Haskell.LSP.Core as LSP
13import Language.Haskell.LSP.Types
13import Language.Haskell.LSP.Types
14import qualified Language.Haskell.LSP.Types as LSP
14import qualified Language.Haskell.LSP.Types as LSP
15
15
16+import Development.IDE.Core.IdeConfiguration
16import Development.IDE.Core.Service
17import Development.IDE.Core.Service
17import Development.IDE.Types.Location
18import Development.IDE.Types.Location
18import Development.IDE.Types.Logger
19import Development.IDE.Types.Logger
@@ -20,7 +21,7 @@ import Development.IDE.Types.Logger
20import Control.Monad.Extra
21import Control.Monad.Extra
21import Data.Foldable as F
22import Data.Foldable as F
22import Data.Maybe
23import Data.Maybe
23−import qualified Data.Set as S
24+import qualified Data.HashSet as S
24import qualified Data.Text as Text
25import qualified Data.Text as Text
25
26
26import Development.IDE.Core.FileStore (setSomethingModified)
27import Development.IDE.Core.FileStore (setSomethingModified)
@@ -29,9 +30,9 @@ import Development.IDE.Core.OfInterest
29
30
30
31
31whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
32whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
32−whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath
33+whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'
33
34
34−setHandlersNotifications :: PartialHandlers
35+setHandlersNotifications :: PartialHandlers c
35setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
36setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
36 {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $
37 {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $
37 \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do
38 \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do
@@ -61,7 +62,7 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
61 let events =
62 let events =
62 mapMaybe
63 mapMaybe
63 (\(FileEvent uri ev) ->
64 (\(FileEvent uri ev) ->
64− (, ev /= FcDeleted) . toNormalizedFilePath
65+ (, ev /= FcDeleted) . toNormalizedFilePath'
65 <$> LSP.uriToFilePath uri
66 <$> LSP.uriToFilePath uri
66 )
67 )
67 ( F.toList fileEvents )
68 ( F.toList fileEvents )
@@ -69,4 +70,12 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
69 logInfo (ideLogger ide) $ "Files created or deleted: " <> msg
70 logInfo (ideLogger ide) $ "Files created or deleted: " <> msg
70 modifyFileExists ide events
71 modifyFileExists ide events
71 setSomethingModified ide
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))
72− }
81+ }
src/Development/IDE/LSP/Outline.hs+49−10
@@ -4,6 +4,8 @@
4
4
5module Development.IDE.LSP.Outline
5module Development.IDE.LSP.Outline
6 ( setHandlersOutline
6 ( setHandlersOutline
7+ -- * For haskell-language-server
8+ , moduleOutline
7 )
9 )
8where
10where
9
11
@@ -28,20 +30,20 @@ import Outputable ( Outputable
28 , showSDocUnsafe
30 , showSDocUnsafe
29 )
31 )
30
32
31−setHandlersOutline :: PartialHandlers
33+setHandlersOutline :: PartialHandlers c
32setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x
34setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x
33 { LSP.documentSymbolHandler = withResponse RspDocumentSymbols moduleOutline
35 { LSP.documentSymbolHandler = withResponse RspDocumentSymbols moduleOutline
34 }
36 }
35
37
36moduleOutline
38moduleOutline
37− :: LSP.LspFuncs () -> IdeState -> DocumentSymbolParams -> IO DSResult
39+ :: LSP.LspFuncs c -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)
38moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }
40moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }
39 = case uriToFilePath uri of
41 = case uriToFilePath uri of
40− Just (toNormalizedFilePath -> fp) -> do
42+ Just (toNormalizedFilePath' -> fp) -> do
41 mb_decls <- runAction ideState $ use GetParsedModule fp
43 mb_decls <- runAction ideState $ use GetParsedModule fp
42− pure $ case mb_decls of
44+ pure $ Right $ case mb_decls of
43 Nothing -> DSDocumentSymbols (List [])
45 Nothing -> DSDocumentSymbols (List [])
44− Just (ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } })
46+ Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } }
45 -> let
47 -> let
46 declSymbols = mapMaybe documentSymbolForDecl hsmodDecls
48 declSymbols = mapMaybe documentSymbolForDecl hsmodDecls
47 moduleSymbol = hsmodName <&> \(L l m) ->
49 moduleSymbol = hsmodName <&> \(L l m) ->
@@ -50,7 +52,9 @@ moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentI
50 , _kind = SkFile
52 , _kind = SkFile
51 , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0
53 , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0
52 }
54 }
55+ importSymbols = maybe [] pure $
56+ documentSymbolForImportSummary
53− importSymbols = mapMaybe documentSymbolForImport hsmodImports
57+ (mapMaybe documentSymbolForImport hsmodImports)
54 allSymbols = case moduleSymbol of
58 allSymbols = case moduleSymbol of
55 Nothing -> importSymbols <> declSymbols
59 Nothing -> importSymbols <> declSymbols
56 Just x ->
60 Just x ->
@@ -61,7 +65,7 @@ moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentI
61 DSDocumentSymbols (List allSymbols)
65 DSDocumentSymbols (List allSymbols)
62
66
63
67
64− Nothing -> pure $ DSDocumentSymbols (List [])
68+ Nothing -> pure $ Right $ DSDocumentSymbols (List [])
65
69
66documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol
70documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol
67documentSymbolForDecl (L l (TyClD FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))
71documentSymbolForDecl (L l (TyClD FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))
@@ -104,27 +108,39 @@ documentSymbolForDecl (L l (TyClD DataDecl { tcdLName = L _ name, tcdDataDefn =
104 { _name = showRdrName n
108 { _name = showRdrName n
105 , _kind = SkConstructor
109 , _kind = SkConstructor
106 , _selectionRange = srcSpanToRange l'
110 , _selectionRange = srcSpanToRange l'
111+ , _children = conArgRecordFields (getConArgs x)
107 }
112 }
108 | L l x <- dd_cons
113 | L l x <- dd_cons
109 , L l' n <- getConNames x
114 , L l' n <- getConNames x
110 ]
115 ]
111 }
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
112documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just
128documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just
113 (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n
129 (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n
114 , _kind = SkTypeParameter
130 , _kind = SkTypeParameter
115 , _selectionRange = srcSpanToRange l'
131 , _selectionRange = srcSpanToRange l'
116 }
132 }
117−documentSymbolForDecl (L l (InstD (ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })))
133+documentSymbolForDecl (L l (InstD ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))
118 = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty
134 = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty
119 , _kind = SkInterface
135 , _kind = SkInterface
120 }
136 }
121−documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) }))
137+documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))
122 = Just (defDocumentSymbol l :: DocumentSymbol)
138 = Just (defDocumentSymbol l :: DocumentSymbol)
123 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords
139 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords
124 (map pprText feqn_pats)
140 (map pprText feqn_pats)
125 , _kind = SkInterface
141 , _kind = SkInterface
126 }
142 }
127−documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) }))
143+documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))
128 = Just (defDocumentSymbol l :: DocumentSymbol)
144 = Just (defDocumentSymbol l :: DocumentSymbol)
129 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords
145 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords
130 (map pprText feqn_pats)
146 (map pprText feqn_pats)
@@ -167,12 +183,35 @@ documentSymbolForDecl (L l (ForD x)) = Just
167
183
168documentSymbolForDecl _ = Nothing
184documentSymbolForDecl _ = Nothing
169
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+
170documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol
205documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol
171documentSymbolForImport (L l ImportDecl { ideclName, ideclQualified }) = Just
206documentSymbolForImport (L l ImportDecl { ideclName, ideclQualified }) = Just
172 (defDocumentSymbol l :: DocumentSymbol)
207 (defDocumentSymbol l :: DocumentSymbol)
173 { _name = "import " <> pprText ideclName
208 { _name = "import " <> pprText ideclName
174 , _kind = SkModule
209 , _kind = SkModule
210+#if MIN_GHC_API_VERSION(8,10,0)
211+ , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" }
212+#else
175 , _detail = if ideclQualified then Just "qualified" else Nothing
213 , _detail = if ideclQualified then Just "qualified" else Nothing
214+#endif
176 }
215 }
177#if MIN_GHC_API_VERSION(8,6,0)
216#if MIN_GHC_API_VERSION(8,6,0)
178documentSymbolForImport (L _ XImportDecl {}) = Nothing
217documentSymbolForImport (L _ XImportDecl {}) = Nothing
src/Development/IDE/LSP/Server.hs+11−10
@@ -16,31 +16,32 @@ import qualified Language.Haskell.LSP.Core as LSP
16import qualified Language.Haskell.LSP.Messages as LSP
16import qualified Language.Haskell.LSP.Messages as LSP
17import Development.IDE.Core.Service
17import Development.IDE.Core.Service
18
18
19−
20−data WithMessage = WithMessage
19+data WithMessage c = WithMessage
21 {withResponse :: forall m req resp . (Show m, Show req) =>
20 {withResponse :: forall m req resp . (Show m, Show req) =>
22 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
21 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
23− (LSP.LspFuncs () -> IdeState -> req -> IO resp) -> -- actual work
22+ (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work
24 Maybe (LSP.Handler (RequestMessage m req resp))
23 Maybe (LSP.Handler (RequestMessage m req resp))
25 ,withNotification :: forall m req . (Show m, Show req) =>
24 ,withNotification :: forall m req . (Show m, Show req) =>
26 Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler
25 Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler
27− (LSP.LspFuncs () -> IdeState -> req -> IO ()) -> -- actual work
26+ (LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work
28 Maybe (LSP.Handler (NotificationMessage m req))
27 Maybe (LSP.Handler (NotificationMessage m req))
29− ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
28+ ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody .
30 (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
29 (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
31 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
30 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
32 (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req
31 (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req
33− (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work
32+ (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work
34 Maybe (LSP.Handler (RequestMessage m req resp))
33 Maybe (LSP.Handler (RequestMessage m req resp))
34+ , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
35+ -> Maybe (LSP.Handler InitializeRequest)
35 }
36 }
36
37
37−newtype PartialHandlers = PartialHandlers (WithMessage -> LSP.Handlers -> IO LSP.Handlers)
38+newtype PartialHandlers c = PartialHandlers (WithMessage c -> LSP.Handlers -> IO LSP.Handlers)
38
39
39−instance Default PartialHandlers where
40+instance Default (PartialHandlers c) where
40 def = PartialHandlers $ \_ x -> pure x
41 def = PartialHandlers $ \_ x -> pure x
41
42
42−instance Semigroup PartialHandlers where
43+instance Semigroup (PartialHandlers c) where
43 PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w
44 PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w
44
45
45−instance Monoid PartialHandlers where
46+instance Monoid (PartialHandlers c) where
46 mempty = def
47 mempty = def
src/Development/IDE/Plugin.hs+36−9
@@ -1,33 +1,60 @@
1
1
2−module Development.IDE.Plugin(Plugin(..), codeActionPlugin) where
2+module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules,makeLspCommandId,getPid) where
3
3
4import Data.Default
4import Data.Default
5+import qualified Data.Text as T
5import Development.Shake
6import Development.Shake
6import Development.IDE.LSP.Server
7import Development.IDE.LSP.Server
7
8
8import Language.Haskell.LSP.Types
9import Language.Haskell.LSP.Types
10+import Development.IDE.Compat
9import Development.IDE.Core.Rules
11import Development.IDE.Core.Rules
10import qualified Language.Haskell.LSP.Core as LSP
12import qualified Language.Haskell.LSP.Core as LSP
11import Language.Haskell.LSP.Messages
13import Language.Haskell.LSP.Messages
12
14
13
15
14−data Plugin = Plugin
16+data Plugin c = Plugin
15 {pluginRules :: Rules ()
17 {pluginRules :: Rules ()
16− ,pluginHandler :: PartialHandlers
18+ ,pluginHandler :: PartialHandlers c
17 }
19 }
18
20
19−instance Default Plugin where
21+instance Default (Plugin c) where
20 def = Plugin mempty def
22 def = Plugin mempty def
21
23
22−instance Semigroup Plugin where
24+instance Semigroup (Plugin c) where
23 Plugin x1 y1 <> Plugin x2 y2 = Plugin (x1<>x2) (y1<>y2)
25 Plugin x1 y1 <> Plugin x2 y2 = Plugin (x1<>x2) (y1<>y2)
24
26
25−instance Monoid Plugin where
27+instance Monoid (Plugin c) where
26 mempty = def
28 mempty = def
27
29
28
30
31+codeActionPlugin :: (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c
32+codeActionPlugin = codeActionPluginWithRules mempty
33+
29−codeActionPlugin :: (LSP.LspFuncs () -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO [CAResult]) -> Plugin
34+codeActionPluginWithRules :: Rules () -> (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c
30−codeActionPlugin f = Plugin mempty $ PartialHandlers $ \WithMessage{..} x -> return x{
35+codeActionPluginWithRules rr f = Plugin rr $ PartialHandlers $ \WithMessage{..} x -> return x{
31 LSP.codeActionHandler = withResponse RspCodeAction g
36 LSP.codeActionHandler = withResponse RspCodeAction g
32 }
37 }
38+ where
33− where g lsp state (CodeActionParams a b c _) = List <$> f lsp state a b c
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.hs+164−99
@@ -6,7 +6,16 @@
6#include "ghc-api-version.h"
6#include "ghc-api-version.h"
7
7
8-- | Go to the definition of a variable.
8-- | Go to the definition of a variable.
9−module Development.IDE.Plugin.CodeAction(plugin) where
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
10
19
11import Language.Haskell.LSP.Types
20import Language.Haskell.LSP.Types
12import Control.Monad (join)
21import Control.Monad (join)
@@ -17,9 +26,14 @@ import Development.IDE.Core.RuleTypes
17import Development.IDE.Core.Service
26import Development.IDE.Core.Service
18import Development.IDE.Core.Shake
27import Development.IDE.Core.Shake
19import Development.IDE.GHC.Error
28import Development.IDE.GHC.Error
29+import Development.IDE.GHC.Util
20import Development.IDE.LSP.Server
30import 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
21import Development.IDE.Types.Location
34import Development.IDE.Types.Location
22import Development.IDE.Types.Options
35import Development.IDE.Types.Options
36+import Development.Shake (Rules)
23import qualified Data.HashMap.Strict as Map
37import qualified Data.HashMap.Strict as Map
24import qualified Language.Haskell.LSP.Core as LSP
38import qualified Language.Haskell.LSP.Core as LSP
25import Language.Haskell.LSP.VFS
39import Language.Haskell.LSP.VFS
@@ -32,76 +46,97 @@ import Data.Maybe
32import Data.List.Extra
46import Data.List.Extra
33import qualified Data.Text as T
47import qualified Data.Text as T
34import Data.Tuple.Extra ((&&&))
48import Data.Tuple.Extra ((&&&))
49+import HscTypes
50+import Parser
35import Text.Regex.TDFA ((=~), (=~~))
51import Text.Regex.TDFA ((=~), (=~~))
36import Text.Regex.TDFA.Text()
52import Text.Regex.TDFA.Text()
37import Outputable (ppr, showSDocUnsafe)
53import Outputable (ppr, showSDocUnsafe)
38import DynFlags (xFlags, FlagSpec(..))
54import DynFlags (xFlags, FlagSpec(..))
39import GHC.LanguageExtensions.Type (Extension)
55import GHC.LanguageExtensions.Type (Extension)
40
56
41−plugin :: Plugin
57+plugin :: Plugin c
42−plugin = codeActionPlugin codeAction <> Plugin mempty setHandlersCodeLens
58+plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens
59+
60+rules :: Rules ()
61+rules = rulePackageExports
43
62
44-- | Generate code actions.
63-- | Generate code actions.
45codeAction
64codeAction
46− :: LSP.LspFuncs ()
65+ :: LSP.LspFuncs c
47 -> IdeState
66 -> IdeState
48 -> TextDocumentIdentifier
67 -> TextDocumentIdentifier
49 -> Range
68 -> Range
50 -> CodeActionContext
69 -> CodeActionContext
51− -> IO [CAResult]
70+ -> IO (Either ResponseError [CAResult])
52codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do
71codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do
53 -- disable logging as its quite verbose
72 -- disable logging as its quite verbose
54 -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg
73 -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg
55 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
74 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
56 let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
75 let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
76+ mbFile = toNormalizedFilePath' <$> uriToFilePath uri
57− (ideOptions, parsedModule) <- runAction state $
77+ (ideOptions, parsedModule, join -> env) <- runAction state $
58− (,) <$> getIdeOptions
78+ (,,) <$> getIdeOptions
59− <*> (getParsedModule . toNormalizedFilePath) `traverse` uriToFilePath uri
79+ <*> getParsedModule `traverse` mbFile
80+ <*> use GhcSession `traverse` mbFile
81+ pkgExports <- runAction state $ (useNoFile_ . PackageExports) `traverse` env
82+ let dflags = hsc_dflags . hscEnv <$> env
60− pure
83+ pure $ Right
61 [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
84 [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
62− | x <- xs, (title, tedit) <- suggestAction ideOptions ( join parsedModule ) text x
85+ | x <- xs, (title, tedit) <- suggestAction dflags (fromMaybe mempty pkgExports) ideOptions ( join parsedModule ) text x
63 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
86 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
64 ]
87 ]
65
88
66-- | Generate code lenses.
89-- | Generate code lenses.
67codeLens
90codeLens
68− :: LSP.LspFuncs ()
91+ :: LSP.LspFuncs c
69 -> IdeState
92 -> IdeState
70 -> CodeLensParams
93 -> CodeLensParams
71− -> IO (List CodeLens)
94+ -> IO (Either ResponseError (List CodeLens))
72codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
95codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
96+ commandId <- makeLspCommandId "typesignature.add"
73− case uriToFilePath' uri of
97+ fmap (Right . List) $ case uriToFilePath' uri of
74− Just (toNormalizedFilePath -> filePath) -> do
98+ Just (toNormalizedFilePath' -> filePath) -> do
75 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
99 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
76 diag <- getDiagnostics ideState
100 diag <- getDiagnostics ideState
77 hDiag <- getHiddenDiagnostics ideState
101 hDiag <- getHiddenDiagnostics ideState
78− pure $ List
102+ pure
79− [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing
103+ [ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing
80− | (dFile, _, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag ++ hDiag
104+ | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag
81 , dFile == filePath
105 , dFile == filePath
82 , (title, tedit) <- suggestSignature False dDiag
106 , (title, tedit) <- suggestSignature False dDiag
83 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
107 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
84 ]
108 ]
85− Nothing -> pure $ List []
109+ Nothing -> pure []
86
110
87-- | Execute the "typesignature.add" command.
111-- | Execute the "typesignature.add" command.
88executeAddSignatureCommand
112executeAddSignatureCommand
89− :: LSP.LspFuncs ()
113+ :: LSP.LspFuncs c
90 -> IdeState
114 -> IdeState
91 -> ExecuteCommandParams
115 -> ExecuteCommandParams
92− -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
116+ -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
93executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}
117executeAddSignatureCommand _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.
94− | _command == "typesignature.add"
122+ | T.isSuffixOf "typesignature.add" _command
95 , Just (List [edit]) <- _arguments
123 , Just (List [edit]) <- _arguments
96− , Success wedit <- fromJSON edit
124+ , Success wedit <- fromJSON edit
97− = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
125+ = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
98 | otherwise
126 | otherwise
99− = return (Null, Nothing)
127+ = return (Right Null, Nothing)
100−
128+
101−suggestAction :: IdeOptions -> Maybe ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
129+suggestAction
130+ :: Maybe DynFlags
131+ -> PackageExportsMap
132+ -> IdeOptions
133+ -> Maybe ParsedModule
134+ -> Maybe T.Text
135+ -> Diagnostic
136+ -> [(T.Text, [TextEdit])]
102−suggestAction ideOptions parsedModule text diag = concat
137+suggestAction dflags packageExports ideOptions parsedModule text diag = concat
103 [ suggestAddExtension diag
138 [ suggestAddExtension diag
104− , suggestExtendImport text diag
139+ , suggestExtendImport dflags text diag
105 , suggestFillHole diag
140 , suggestFillHole diag
106 , suggestFillTypeWildcard diag
141 , suggestFillTypeWildcard diag
107 , suggestFixConstructorImport text diag
142 , suggestFixConstructorImport text diag
@@ -111,17 +146,19 @@ suggestAction ideOptions parsedModule text diag = concat
111 ] ++ concat
146 ] ++ concat
112 [ suggestNewDefinition ideOptions pm text diag
147 [ suggestNewDefinition ideOptions pm text diag
113 ++ suggestRemoveRedundantImport pm text diag
148 ++ suggestRemoveRedundantImport pm text diag
149+ ++ suggestNewImport packageExports pm diag
114 | Just pm <- [parsedModule]]
150 | Just pm <- [parsedModule]]
115
151
116
152
117suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
153suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
118−suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range@Range{..},..}
154+suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..}
119-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant
155-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant
120 | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"
156 | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"
121 , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports
157 , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports
122 , Just c <- contents
158 , Just c <- contents
123 , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)
159 , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)
124 , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)
160 , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)
161+ , not (null ranges')
125 = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]
162 = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]
126
163
127-- File.hs:16:1: warning:
164-- File.hs:16:1: warning:
@@ -133,7 +170,7 @@ suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmod
133 | otherwise = []
170 | otherwise = []
134
171
135suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
172suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
136−suggestReplaceIdentifier contents Diagnostic{_range=_range@Range{..},..}
173+suggestReplaceIdentifier contents Diagnostic{_range=_range,..}
137-- File.hs:52:41: error:
174-- File.hs:52:41: error:
138-- * Variable not in scope:
175-- * Variable not in scope:
139-- suggestAcion :: Maybe T.Text -> Range -> Range
176-- suggestAcion :: Maybe T.Text -> Range -> Range
@@ -180,7 +217,7 @@ newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ
180
217
181
218
182suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]
219suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]
183−suggestFillTypeWildcard Diagnostic{_range=_range@Range{..},..}
220+suggestFillTypeWildcard Diagnostic{_range=_range,..}
184-- Foo.hs:3:8: error:
221-- Foo.hs:3:8: error:
185-- * Found type wildcard `_' standing for `p -> p1 -> p'
222-- * Found type wildcard `_' standing for `p -> p1 -> p'
186
223
@@ -191,7 +228,7 @@ suggestFillTypeWildcard Diagnostic{_range=_range@Range{..},..}
191 | otherwise = []
228 | otherwise = []
192
229
193suggestAddExtension :: Diagnostic -> [(T.Text, [TextEdit])]
230suggestAddExtension :: Diagnostic -> [(T.Text, [TextEdit])]
194−suggestAddExtension Diagnostic{_range=_range@Range{..},..}
231+suggestAddExtension Diagnostic{_range=_range,..}
195-- File.hs:22:8: error:
232-- File.hs:22:8: error:
196-- Illegal lambda-case (use -XLambdaCase)
233-- Illegal lambda-case (use -XLambdaCase)
197-- File.hs:22:6: error:
234-- File.hs:22:6: error:
@@ -221,7 +258,7 @@ ghcExtensions :: Map.HashMap T.Text Extension
221ghcExtensions = Map.fromList . map ( ( T.pack . flagSpecName ) &&& flagSpecFlag ) $ xFlags
258ghcExtensions = Map.fromList . map ( ( T.pack . flagSpecName ) &&& flagSpecFlag ) $ xFlags
222
259
223suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]
260suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]
224−suggestModuleTypo Diagnostic{_range=_range@Range{..},..}
261+suggestModuleTypo Diagnostic{_range=_range,..}
225-- src/Development/IDE/Core/Compile.hs:58:1: error:
262-- src/Development/IDE/Core/Compile.hs:58:1: error:
226-- Could not find module ‘Data.Cha’
263-- Could not find module ‘Data.Cha’
227-- Perhaps you meant Data.Char (from base-4.12.0.0)
264-- Perhaps you meant Data.Char (from base-4.12.0.0)
@@ -233,7 +270,7 @@ suggestModuleTypo Diagnostic{_range=_range@Range{..},..}
233 | otherwise = []
270 | otherwise = []
234
271
235suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])]
272suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])]
236−suggestFillHole Diagnostic{_range=_range@Range{..},..}
273+suggestFillHole Diagnostic{_range=_range,..}
237-- ...Development/IDE/LSP/CodeAction.hs:103:9: warning:
274-- ...Development/IDE/LSP/CodeAction.hs:103:9: warning:
238-- * Found hole: _ :: Int -> String
275-- * Found hole: _ :: Int -> String
239-- * In the expression: _
276-- * In the expression: _
@@ -268,20 +305,22 @@ suggestFillHole Diagnostic{_range=_range@Range{..},..}
268
305
269 | otherwise = []
306 | otherwise = []
270
307
271−suggestExtendImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
308+suggestExtendImport :: Maybe DynFlags -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
272−suggestExtendImport contents Diagnostic{_range=_range,..}
309+suggestExtendImport (Just dflags) contents Diagnostic{_range=_range,..}
273 | Just [binding, mod, srcspan] <-
310 | Just [binding, mod, srcspan] <-
274 matchRegex _message
311 matchRegex _message
275 "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$"
312 "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\).$"
276 , Just c <- contents
313 , Just c <- contents
314+ , POk _ (L _ name) <- runParser dflags (T.unpack binding) parseIdentifier
277 = let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of
315 = let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of
278 [s] -> let x = srcSpanToRange s
316 [s] -> let x = srcSpanToRange s
279 in x{_end = (_end x){_character = succ (_character (_end x))}}
317 in x{_end = (_end x){_character = succ (_character (_end x))}}
280 _ -> error "bug in srcspan parser"
318 _ -> error "bug in srcspan parser"
281 importLine = textInRange range c
319 importLine = textInRange range c
282 in [("Add " <> binding <> " to the import list of " <> mod
320 in [("Add " <> binding <> " to the import list of " <> mod
283− , [TextEdit range (addBindingToImportList binding importLine)])]
321+ , [TextEdit range (addBindingToImportList (T.pack $ printRdrName name) importLine)])]
284 | otherwise = []
322 | otherwise = []
323+suggestExtendImport Nothing _ _ = []
285
324
286suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
325suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
287suggestFixConstructorImport _ Diagnostic{_range=_range,..}
326suggestFixConstructorImport _ Diagnostic{_range=_range,..}
@@ -299,29 +338,103 @@ suggestFixConstructorImport _ Diagnostic{_range=_range,..}
299
338
300suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
339suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
301suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
340suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
302− | "Top-level binding with no type signature" `T.isInfixOf` _message = let
341+ | _message =~
303− signature = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
304− startOfLine = Position (_line _start) 0
305− beforeLine = Range startOfLine startOfLine
306− title = if isQuickFix then "add signature: " <> signature else signature
307− action = TextEdit beforeLine $ signature <> "\n"
308− in [(title, [action])]
309−suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
310− | "Polymorphic local binding with no type signature" `T.isInfixOf` _message = let
342+ ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) = let
311 signature = removeInitialForAll
343 signature = removeInitialForAll
312 $ T.takeWhile (\x -> x/='*' && x/='•')
344 $ T.takeWhile (\x -> x/='*' && x/='•')
313 $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
345 $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
314− startOfLine = Position (_line _start) (_character _start)
346+ startOfLine = Position (_line _start) startCharacter
315 beforeLine = Range startOfLine startOfLine
347 beforeLine = Range startOfLine startOfLine
316 title = if isQuickFix then "add signature: " <> signature else signature
348 title = if isQuickFix then "add signature: " <> signature else signature
317− action = TextEdit beforeLine $ signature <> "\n" <> T.replicate (_character _start) " "
349+ action = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " "
318 in [(title, [action])]
350 in [(title, [action])]
319 where removeInitialForAll :: T.Text -> T.Text
351 where removeInitialForAll :: T.Text -> T.Text
320 removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))
352 removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))
321 | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))
353 | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))
322 | otherwise = nm <> ty
354 | otherwise = nm <> ty
355+ startCharacter
356+ | "Polymorphic local binding" `T.isPrefixOf` _message
357+ = _character _start
358+ | otherwise
359+ = 0
360+
323suggestSignature _ _ = []
361suggestSignature _ _ = []
324
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+
325topOfHoleFitsMarker :: T.Text
438topOfHoleFitsMarker :: T.Text
326topOfHoleFitsMarker =
439topOfHoleFitsMarker =
327#if MIN_GHC_API_VERSION(8,6,0)
440#if MIN_GHC_API_VERSION(8,6,0)
@@ -332,7 +445,7 @@ topOfHoleFitsMarker =
332
445
333mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit
446mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit
334mkRenameEdit contents range name =
447mkRenameEdit contents range name =
335− if fromMaybe False maybeIsInfixFunction
448+ if maybeIsInfixFunction == Just True
336 then TextEdit range ("`" <> name <> "`")
449 then TextEdit range ("`" <> name <> "`")
337 else TextEdit range name
450 else TextEdit range name
338 where
451 where
@@ -414,7 +527,7 @@ rangesForBinding _ _ = []
414rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]
527rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]
415rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]
528rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]
416rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]
529rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]
417−rangesForBinding' b (L l x@IEThingAll{}) | showSDocUnsafe (ppr x) == b = [l]
530+rangesForBinding' b (L l (IEThingAll x)) | showSDocUnsafe (ppr x) == b = [l]
418rangesForBinding' b (L l (IEThingWith thing _ inners labels))
531rangesForBinding' b (L l (IEThingWith thing _ inners labels))
419 | showSDocUnsafe (ppr thing) == b = [l]
532 | showSDocUnsafe (ppr thing) == b = [l]
420 | otherwise =
533 | otherwise =
@@ -444,7 +557,7 @@ matchRegex message regex = case unifySpaces message =~~ regex of
444 Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings
557 Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings
445 Nothing -> Nothing
558 Nothing -> Nothing
446
559
447−setHandlersCodeLens :: PartialHandlers
560+setHandlersCodeLens :: PartialHandlers c
448setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
561setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{
449 LSP.codeLensHandler = withResponse RspCodeLens codeLens,
562 LSP.codeLensHandler = withResponse RspCodeLens codeLens,
450 LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
563 LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand
@@ -455,51 +568,3 @@ filterNewlines = T.concat . T.lines
455
568
456unifySpaces :: T.Text -> T.Text
569unifySpaces :: T.Text -> T.Text
457unifySpaces = T.unwords . T.words
570unifySpaces = T.unwords . T.words
458−
459−--------------------------------------------------------------------------------
460−
461−type PositionIndexedString = [(Position, Char)]
462−
463−indexedByPosition :: String -> PositionIndexedString
464−indexedByPosition = unfoldr f . (Position 0 0,) where
465− f (_, []) = Nothing
466− f (p@(Position l _), '\n' : rest) = Just ((p,'\n'), (Position (l+1) 0, rest))
467− f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c+1), rest))
468−
469−-- | Returns a tuple (before, contents, after)
470−unconsRange :: Range -> PositionIndexedString -> (PositionIndexedString, PositionIndexedString, PositionIndexedString)
471−unconsRange Range {..} indexedString = (before, mid, after)
472− where
473− (before, rest) = span ((/= _start) . fst) indexedString
474− (mid, after) = span ((/= _end) . fst) rest
475−
476−stripRange :: Range -> PositionIndexedString -> PositionIndexedString
477−stripRange r s = case unconsRange r s of
478− (b, _, a) -> b ++ a
479−
480−extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]
481−extendAllToIncludeCommaIfPossible _ [] = []
482−extendAllToIncludeCommaIfPossible indexedString (r : rr) = r' : extendAllToIncludeCommaIfPossible indexedString' rr
483− where
484− r' = case extendToIncludeCommaIfPossible indexedString r of
485− [] -> r
486− r' : _ -> r'
487− indexedString' = stripRange r' indexedString
488−
489−-- | Returns a sorted list of ranges with extended selections includindg preceding or trailing commas
490−extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]
491−extendToIncludeCommaIfPossible indexedString range =
492− -- a, |b|, c ===> a|, b|, c
493− [ range{_start = start'}
494− | (start', ',') : _ <- [before']
495− ]
496− ++
497− -- a, |b|, c ===> a, |b, |c
498− [ range{_end = end'}
499− | (_, ',') : rest <- [after']
500− , let (end', _) : _ = dropWhile (isSpace . snd) rest
501− ]
502− where
503− (before, _, after) = unconsRange range indexedString
504− after' = dropWhile (isSpace . snd) after
505− before' = dropWhile (isSpace . snd) (reverse before)
src/Development/IDE/Plugin/CodeAction/PositionIndexed.hsnew file+112
@@ -0,0 +1,112 @@
1+-- | Position indexed streams of characters
2+module Development.IDE.Plugin.CodeAction.PositionIndexed
3+ ( PositionIndexed
4+ , PositionIndexedString
5+ , indexedByPosition
6+ , indexedByPositionStartingFrom
7+ , extendAllToIncludeCommaIfPossible
8+ , mergeRanges
9+ )
10+where
11+
12+import Data.Char
13+import Data.List
14+import Language.Haskell.LSP.Types
15+
16+type PositionIndexed a = [(Position, a)]
17+
18+type PositionIndexedString = PositionIndexed Char
19+
20+-- | Add position indexing to a String.
21+--
22+-- > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡
23+-- > [ ((0,0),'h')
24+-- > , ((0,1),'e')
25+-- > , ((0,2),'y')
26+-- > , ((0,3),'\n')
27+-- > , ((1,0),' ')
28+-- > , ((1,1),'h')
29+-- > , ((1,2),'o')
30+-- > ]
31+indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString
32+indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where
33+ f (_, []) = Nothing
34+ f (p@(Position l _), '\n' : rest) =
35+ Just ((p, '\n'), (Position (l + 1) 0, rest))
36+ f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest))
37+
38+-- | Add position indexing to a String.
39+--
40+-- > indexedByPosition = indexedByPositionStartingFrom (Position 0 0)
41+indexedByPosition :: String -> PositionIndexedString
42+indexedByPosition = indexedByPositionStartingFrom (Position 0 0)
43+
44+-- | Returns a tuple (before, contents, after) if the range is present.
45+-- The range is present only if both its start and end positions are present
46+unconsRange
47+ :: Range
48+ -> PositionIndexed a
49+ -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a)
50+unconsRange Range {..} indexedString
51+ | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString
52+ , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest
53+ = Just (before, mid, after)
54+ | otherwise
55+ = Nothing
56+
57+-- | Strips out all the positions included in the range.
58+-- Returns 'Nothing' if the start or end of the range are not included in the input.
59+stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a)
60+stripRange r s = case unconsRange r s of
61+ Just (b, _, a) -> Just (b ++ a)
62+ Nothing -> Nothing
63+
64+-- | Returns the smallest possible set of disjoint ranges that is equivalent to the input.
65+-- Assumes input ranges are sorted on the start positions.
66+mergeRanges :: [Range] -> [Range]
67+mergeRanges (r : r' : rest)
68+ |
69+ -- r' is contained in r
70+ _end r > _end r' = mergeRanges (r : rest)
71+ |
72+ -- r and r' are overlapping
73+ _end r > _start r' = mergeRanges (r { _end = _end r' } : rest)
74+
75+ | otherwise = r : mergeRanges (r' : rest)
76+mergeRanges other = other
77+
78+-- | Returns a sorted list of ranges with extended selections including preceding or trailing commas
79+--
80+-- @
81+-- a, |b|, c ===> a|, b|, c
82+-- a, b, |c| ===> a, b|, c|
83+-- a, |b|, |c| ===> a|, b||, c|
84+-- @
85+extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]
86+extendAllToIncludeCommaIfPossible indexedString =
87+ mergeRanges . go indexedString . sortOn _start
88+ where
89+ go _ [] = []
90+ go input (r : rr)
91+ | r' : _ <- extendToIncludeCommaIfPossible input r
92+ , Just input' <- stripRange r' input
93+ = r' : go input' rr
94+ | otherwise
95+ = go input rr
96+
97+extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]
98+extendToIncludeCommaIfPossible indexedString range
99+ | Just (before, _, after) <- unconsRange range indexedString
100+ , after' <- dropWhile (isSpace . snd) after
101+ , before' <- dropWhile (isSpace . snd) (reverse before)
102+ =
103+ -- a, |b|, c ===> a|, b|, c
104+ [ range { _start = start' } | (start', ',') : _ <- [before'] ]
105+ ++
106+ -- a, |b|, c ===> a, |b, |c
107+ [ range { _end = end' }
108+ | (_, ',') : rest <- [after']
109+ , let (end', _) : _ = dropWhile (isSpace . snd) rest
110+ ]
111+ | otherwise
112+ = [range]
src/Development/IDE/Plugin/CodeAction/RuleTypes.hsnew file+61
@@ -0,0 +1,61 @@
1+{-# LANGUAGE TypeFamilies #-}
2+module Development.IDE.Plugin.CodeAction.RuleTypes
3+ (PackageExports(..), PackageExportsMap
4+ ,IdentInfo(..)
5+ ,mkIdentInfos
6+ ) where
7+
8+import Avail (AvailInfo(..))
9+import Data.Hashable (Hashable)
10+import Control.DeepSeq (NFData)
11+import Data.Binary (Binary)
12+import Data.Text (pack, Text)
13+import Development.IDE.GHC.Util
14+import Development.Shake (RuleResult)
15+import Data.HashMap.Strict (HashMap)
16+import Data.Typeable (Typeable)
17+import GHC.Generics (Generic)
18+import Name
19+import FieldLabel (flSelector)
20+
21+type Identifier = Text
22+type ModuleName = Text
23+
24+data IdentInfo = IdentInfo
25+ { name :: !Identifier
26+ , rendered :: Text
27+ , parent :: !(Maybe Text)
28+ , isDatacon :: !Bool
29+ }
30+ deriving (Eq, Generic, Show)
31+
32+instance NFData IdentInfo
33+
34+mkIdentInfos :: AvailInfo -> [IdentInfo]
35+mkIdentInfos (Avail n) =
36+ [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)]
37+mkIdentInfos (AvailTC parent (n:nn) flds)
38+ -- Following the GHC convention that parent == n if parent is exported
39+ | n == parent
40+ = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) True
41+ | n <- nn ++ map flSelector flds
42+ ] ++
43+ [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing False]
44+ where
45+ parentP = pack $ prettyPrint parent
46+
47+mkIdentInfos (AvailTC _ nn flds)
48+ = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing True
49+ | n <- nn ++ map flSelector flds
50+ ]
51+
52+-- Rule type for caching Package Exports
53+type instance RuleResult PackageExports = PackageExportsMap
54+type PackageExportsMap = HashMap Identifier [(IdentInfo,ModuleName)]
55+
56+newtype PackageExports = PackageExports HscEnvEq
57+ deriving (Eq, Show, Typeable, Generic)
58+
59+instance Hashable PackageExports
60+instance NFData PackageExports
61+instance Binary PackageExports
src/Development/IDE/Plugin/CodeAction/Rules.hsnew file+61
@@ -0,0 +1,61 @@
1+module Development.IDE.Plugin.CodeAction.Rules
2+ ( rulePackageExports
3+ )
4+where
5+
6+import Data.HashMap.Strict ( fromListWith )
7+import Data.Text ( Text
8+ , pack
9+ )
10+import Data.Traversable ( forM )
11+import Development.IDE.Core.Rules
12+import Development.IDE.GHC.Util
13+import Development.IDE.Plugin.CodeAction.RuleTypes
14+import Development.Shake
15+import GHC ( DynFlags(pkgState) )
16+import HscTypes ( IfaceExport
17+ , hsc_dflags
18+ , mi_exports
19+ )
20+import LoadIface
21+import Maybes
22+import Module ( Module(..)
23+ , ModuleName
24+ , moduleNameString
25+ )
26+import Packages ( explicitPackages
27+ , exposedModules
28+ , packageConfigId
29+ )
30+import TcRnMonad ( WhereFrom(ImportByUser)
31+ , initIfaceLoad
32+ )
33+
34+rulePackageExports :: Rules ()
35+rulePackageExports = defineNoFile $ \(PackageExports session) -> do
36+ let env = hscEnv session
37+ pkgst = pkgState (hsc_dflags env)
38+ depends = explicitPackages pkgst
39+ targets =
40+ [ (pkg, mn)
41+ | d <- depends
42+ , Just pkg <- [lookupPackageConfig d env]
43+ , (mn, _) <- exposedModules pkg
44+ ]
45+
46+ results <- forM targets $ \(pkg, mn) -> do
47+ modIface <- liftIO $ initIfaceLoad env $ loadInterface
48+ ""
49+ (Module (packageConfigId pkg) mn)
50+ (ImportByUser False)
51+ case modIface of
52+ Failed _err -> return mempty
53+ Succeeded mi -> do
54+ let avails = mi_exports mi
55+ return $ concatMap (unpackAvail mn) avails
56+ return $ fromListWith (++) $ concat results
57+
58+unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])]
59+unpackAvail mod =
60+ map (\id@IdentInfo {..} -> (name, [(id, pack $ moduleNameString mod)]))
61+ . mkIdentInfos
src/Development/IDE/Plugin/Completions.hs+34−19
@@ -1,7 +1,10 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE TypeFamilies #-}
3+#include "ghc-api-version.h"
2
4
3module Development.IDE.Plugin.Completions(plugin) where
5module Development.IDE.Plugin.Completions(plugin) where
4
6
7+import Control.Applicative
5import Language.Haskell.LSP.Messages
8import Language.Haskell.LSP.Messages
6import Language.Haskell.LSP.Types
9import Language.Haskell.LSP.Types
7import qualified Language.Haskell.LSP.Core as LSP
10import qualified Language.Haskell.LSP.Core as LSP
@@ -10,8 +13,6 @@ import Language.Haskell.LSP.Types.Capabilities
10import Development.Shake.Classes
13import Development.Shake.Classes
11import Development.Shake
14import Development.Shake
12import GHC.Generics
15import GHC.Generics
13−import Data.Maybe
14−import HscTypes
15
16
16import Development.IDE.Plugin
17import Development.IDE.Plugin
17import Development.IDE.Core.Service
18import Development.IDE.Core.Service
@@ -22,29 +23,39 @@ import Development.IDE.Core.RuleTypes
22import Development.IDE.Core.Shake
23import Development.IDE.Core.Shake
23import Development.IDE.GHC.Util
24import Development.IDE.GHC.Util
24import Development.IDE.LSP.Server
25import Development.IDE.LSP.Server
25−import Development.IDE.Import.DependencyInformation
26
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
27
31
28−plugin :: Plugin
32+plugin :: Plugin c
29plugin = Plugin produceCompletions setHandlersCompletion
33plugin = Plugin produceCompletions setHandlersCompletion
30
34
31produceCompletions :: Rules ()
35produceCompletions :: Rules ()
32produceCompletions =
36produceCompletions =
33 define $ \ProduceCompletions file -> do
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
34− deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file
44+ deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
35− tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)
45+ parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)
46+#endif
36 tm <- fmap fst <$> useWithStale TypeCheck file
47 tm <- fmap fst <$> useWithStale TypeCheck file
37 packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file
48 packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file
38 case (tm, packageState) of
49 case (tm, packageState) of
39 (Just tm', Just packageState') -> do
50 (Just tm', Just packageState') -> do
40− cdata <- liftIO $ cacheDataProducer packageState' (hsc_dflags packageState')
51+ cdata <- liftIO $ cacheDataProducer packageState'
41− (tmrModule tm') (map tmrModule tms)
52+ (tmrModule tm') parsedDeps
42− return ([], Just (cdata, tm'))
53+ return ([], Just cdata)
43 _ -> return ([], Nothing)
54 _ -> return ([], Nothing)
44
55
45
56
46-- | Produce completions info for a file
57-- | Produce completions info for a file
47−type instance RuleResult ProduceCompletions = (CachedCompletions, TcModuleResult)
58+type instance RuleResult ProduceCompletions = CachedCompletions
48
59
49data ProduceCompletions = ProduceCompletions
60data ProduceCompletions = ProduceCompletions
50 deriving (Eq, Show, Typeable, Generic)
61 deriving (Eq, Show, Typeable, Generic)
@@ -55,34 +66,38 @@ instance Binary ProduceCompletions
55
66
56-- | Generate code actions.
67-- | Generate code actions.
57getCompletionsLSP
68getCompletionsLSP
58− :: LSP.LspFuncs ()
69+ :: LSP.LspFuncs c
59 -> IdeState
70 -> IdeState
60 -> CompletionParams
71 -> CompletionParams
61− -> IO CompletionResponseResult
72+ -> IO (Either ResponseError CompletionResponseResult)
62getCompletionsLSP lsp ide
73getCompletionsLSP lsp ide
63 CompletionParams{_textDocument=TextDocumentIdentifier uri
74 CompletionParams{_textDocument=TextDocumentIdentifier uri
64 ,_position=position
75 ,_position=position
65 ,_context=completionContext} = do
76 ,_context=completionContext} = do
66 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
77 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
67− case (contents, uriToFilePath' uri) of
78+ fmap Right $ case (contents, uriToFilePath' uri) of
68 (Just cnts, Just path) -> do
79 (Just cnts, Just path) -> do
69− let npath = toNormalizedFilePath path
80+ let npath = toNormalizedFilePath' path
81+ (ideOpts, compls) <- runAction ide $ do
82+ opts <- getIdeOptions
70− (ideOpts, compls) <- runAction ide ((,) <$> getIdeOptions <*> useWithStale ProduceCompletions npath)
83+ compls <- useWithStale ProduceCompletions npath
84+ pm <- useWithStale GetParsedModule npath
85+ pure (opts, liftA2 (,) compls pm)
71 case compls of
86 case compls of
72− Just ((cci', tm'), mapping) -> do
87+ Just ((cci', _), (pm, mapping)) -> do
73− let position' = fromCurrentPosition mapping position
88+ let !position' = fromCurrentPosition mapping position
74 pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'
89 pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'
75 case (pfix, completionContext) of
90 case (pfix, completionContext) of
76 (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
91 (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
77 -> return (Completions $ List [])
92 -> return (Completions $ List [])
78 (Just pfix', _) -> do
93 (Just pfix', _) -> do
79 let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing
94 let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing
80− Completions . List <$> getCompletions ideOpts cci' (tmrModule tm') pfix' fakeClientCapabilities (WithSnippets True)
95+ Completions . List <$> getCompletions ideOpts cci' pm pfix' fakeClientCapabilities (WithSnippets True)
81 _ -> return (Completions $ List [])
96 _ -> return (Completions $ List [])
82 _ -> return (Completions $ List [])
97 _ -> return (Completions $ List [])
83 _ -> return (Completions $ List [])
98 _ -> return (Completions $ List [])
84
99
85−setHandlersCompletion :: PartialHandlers
100+setHandlersCompletion :: PartialHandlers c
86setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{
101setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{
87 LSP.completionHandler = withResponse RspCompletion getCompletionsLSP
102 LSP.completionHandler = withResponse RspCompletion getCompletionsLSP
88 }
103 }
src/Development/IDE/Plugin/Completions/Logic.hs+43−47
@@ -1,4 +1,5 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+#include "ghc-api-version.h"
2-- Mostly taken from "haskell-ide-engine"
3-- Mostly taken from "haskell-ide-engine"
3module Development.IDE.Plugin.Completions.Logic (
4module Development.IDE.Plugin.Completions.Logic (
4 CachedCompletions
5 CachedCompletions
@@ -10,7 +11,7 @@ module Development.IDE.Plugin.Completions.Logic (
10import Control.Applicative
11import Control.Applicative
11import Data.Char (isSpace, isUpper)
12import Data.Char (isSpace, isUpper)
12import Data.Generics
13import Data.Generics
13−import Data.List as List hiding (stripPrefix)
14+import Data.List.Extra as List hiding (stripPrefix)
14import qualified Data.Map as Map
15import qualified Data.Map as Map
15import Data.Maybe (fromMaybe, mapMaybe)
16import Data.Maybe (fromMaybe, mapMaybe)
16import qualified Data.Text as T
17import qualified Data.Text as T
@@ -25,6 +26,12 @@ import Type
25import Var
26import Var
26import Packages
27import Packages
27import DynFlags
28import 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
28
35
29import Language.Haskell.LSP.Types
36import Language.Haskell.LSP.Types
30import Language.Haskell.LSP.Types.Capabilities
37import Language.Haskell.LSP.Types.Capabilities
@@ -125,7 +132,7 @@ occNameToComKind ty oc
125
132
126mkCompl :: IdeOptions -> CompItem -> CompletionItem
133mkCompl :: IdeOptions -> CompItem -> CompletionItem
127mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} =
134mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} =
128− CompletionItem label kind ((colon <>) <$> typeText)
135+ CompletionItem label kind (List []) ((colon <>) <$> typeText)
129 (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')
136 (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')
130 Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
137 Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
131 Nothing Nothing Nothing Nothing Nothing
138 Nothing Nothing Nothing Nothing Nothing
@@ -155,7 +162,7 @@ getArgText typ = argText
155 where
162 where
156 argTypes = getArgs typ
163 argTypes = getArgs typ
157 argText :: T.Text
164 argText :: T.Text
158− argText = mconcat $ List.intersperse " " $ zipWith snippet [1..] argTypes
165+ argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes
159 snippet :: Int -> Type -> T.Text
166 snippet :: Int -> Type -> T.Text
160 snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"
167 snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"
161 getArgs :: Type -> [Type]
168 getArgs :: Type -> [Type]
@@ -169,38 +176,44 @@ getArgText typ = argText
169 then getArgs ret
176 then getArgs ret
170 else Prelude.filter (not . isDictTy) args
177 else Prelude.filter (not . isDictTy) args
171 | isPiTy t = getArgs $ snd (splitPiTys t)
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
172 | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t)
183 | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t)
184+#endif
173 | otherwise = []
185 | otherwise = []
174
186
175mkModCompl :: T.Text -> CompletionItem
187mkModCompl :: T.Text -> CompletionItem
176mkModCompl label =
188mkModCompl label =
177− CompletionItem label (Just CiModule) Nothing
189+ CompletionItem label (Just CiModule) (List []) Nothing
178 Nothing Nothing Nothing Nothing Nothing Nothing Nothing
190 Nothing Nothing Nothing Nothing Nothing Nothing Nothing
179 Nothing Nothing Nothing Nothing Nothing
191 Nothing Nothing Nothing Nothing Nothing
180
192
181mkImportCompl :: T.Text -> T.Text -> CompletionItem
193mkImportCompl :: T.Text -> T.Text -> CompletionItem
182mkImportCompl enteredQual label =
194mkImportCompl enteredQual label =
183− CompletionItem m (Just CiModule) (Just label)
195+ CompletionItem m (Just CiModule) (List []) (Just label)
184 Nothing Nothing Nothing Nothing Nothing Nothing Nothing
196 Nothing Nothing Nothing Nothing Nothing Nothing Nothing
185 Nothing Nothing Nothing Nothing Nothing
197 Nothing Nothing Nothing Nothing Nothing
186− where
198+ where
187 m = fromMaybe "" (T.stripPrefix enteredQual label)
199 m = fromMaybe "" (T.stripPrefix enteredQual label)
188
200
189mkExtCompl :: T.Text -> CompletionItem
201mkExtCompl :: T.Text -> CompletionItem
190mkExtCompl label =
202mkExtCompl label =
191− CompletionItem label (Just CiKeyword) Nothing
203+ CompletionItem label (Just CiKeyword) (List []) Nothing
192 Nothing Nothing Nothing Nothing Nothing Nothing Nothing
204 Nothing Nothing Nothing Nothing Nothing Nothing Nothing
193 Nothing Nothing Nothing Nothing Nothing
205 Nothing Nothing Nothing Nothing Nothing
194
206
195mkPragmaCompl :: T.Text -> T.Text -> CompletionItem
207mkPragmaCompl :: T.Text -> T.Text -> CompletionItem
196mkPragmaCompl label insertText =
208mkPragmaCompl label insertText =
197− CompletionItem label (Just CiKeyword) Nothing
209+ CompletionItem label (Just CiKeyword) (List []) Nothing
198 Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
210 Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
199 Nothing Nothing Nothing Nothing Nothing
211 Nothing Nothing Nothing Nothing Nothing
200
212
201−cacheDataProducer :: HscEnv -> DynFlags -> TypecheckedModule -> [TypecheckedModule] -> IO CachedCompletions
213+cacheDataProducer :: HscEnv -> TypecheckedModule -> [ParsedModule] -> IO CachedCompletions
202−cacheDataProducer packageState dflags tm tcs = do
214+cacheDataProducer packageState tm deps = do
203 let parsedMod = tm_parsed_module tm
215 let parsedMod = tm_parsed_module tm
216+ dflags = hsc_dflags packageState
204 curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod
217 curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod
205 Just (_,limports,_,_) = tm_renamed_source tm
218 Just (_,limports,_,_) = tm_renamed_source tm
206
219
@@ -257,18 +270,18 @@ cacheDataProducer packageState dflags tm tcs = do
257 let typ = Just $ varType var
270 let typ = Just $ varType var
258 name = Var.varName var
271 name = Var.varName var
259 label = T.pack $ showGhc name
272 label = T.pack $ showGhc name
260− docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm:tcs) name
273+ docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) name
261 return $ CI name (showModName curMod) typ label Nothing docs
274 return $ CI name (showModName curMod) typ label Nothing docs
262
275
263 toCompItem :: ModuleName -> Name -> IO CompItem
276 toCompItem :: ModuleName -> Name -> IO CompItem
264 toCompItem mn n = do
277 toCompItem mn n = do
265− docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm:tcs) n
278+ docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) n
266-- lookupName uses runInteractiveHsc, i.e., GHCi stuff which does not work with GHCi
279-- lookupName uses runInteractiveHsc, i.e., GHCi stuff which does not work with GHCi
267-- and leads to fun errors like "Cannot continue after interface file error".
280-- and leads to fun errors like "Cannot continue after interface file error".
268#ifdef GHC_LIB
281#ifdef GHC_LIB
269 let ty = Right Nothing
282 let ty = Right Nothing
270#else
283#else
271− ty <- runGhcEnv packageState $ catchSrcErrors "completion" $ do
284+ ty <- evalGhcEnv packageState $ catchSrcErrors "completion" $ do
272 name' <- lookupName n
285 name' <- lookupName n
273 return $ name' >>= safeTyThingType
286 return $ name' >>= safeTyThingType
274#endif
287#endif
@@ -291,19 +304,16 @@ toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x
291 | otherwise = x { _insertTextFormat = Just PlainText
304 | otherwise = x { _insertTextFormat = Just PlainText
292 , _insertText = Nothing
305 , _insertText = Nothing
293 }
306 }
294− where supported = fromMaybe False (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)
307+ where supported = Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)
295
308
296-- | Returns the cached completions for the given module and position.
309-- | Returns the cached completions for the given module and position.
297−getCompletions :: IdeOptions -> CachedCompletions -> TypecheckedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]
310+getCompletions :: IdeOptions -> CachedCompletions -> ParsedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]
298getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }
311getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }
299− tm prefixInfo caps withSnippets = do
312+ pm prefixInfo caps withSnippets = do
300 let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo
313 let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo
301 enteredQual = if T.null prefixModule then "" else prefixModule <> "."
314 enteredQual = if T.null prefixModule then "" else prefixModule <> "."
302 fullPrefix = enteredQual <> prefixText
315 fullPrefix = enteredQual <> prefixText
303
316
304− -- default to value context if no explicit context
305− context = fromMaybe ValueContext $ getCContext pos (tm_parsed_module tm)
306−
307 {- correct the position by moving 'foo :: Int -> String -> '
317 {- correct the position by moving 'foo :: Int -> String -> '
308 ^
318 ^
309 to 'foo :: Int -> String -> '
319 to 'foo :: Int -> String -> '
@@ -332,10 +342,11 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl
332 where
342 where
333 isTypeCompl = isTcOcc . occName . origName
343 isTypeCompl = isTcOcc . occName . origName
334 -- completions specific to the current context
344 -- completions specific to the current context
335− ctxCompls' = case context of
345+ ctxCompls' = case getCContext pos pm of
346+ Nothing -> compls
336− TypeContext -> filter isTypeCompl compls
347+ Just TypeContext -> filter isTypeCompl compls
337− ValueContext -> filter (not . isTypeCompl) compls
348+ Just ValueContext -> filter (not . isTypeCompl) compls
338− _ -> filter (not . isTypeCompl) compls
349+ Just _ -> filter (not . isTypeCompl) compls
339 -- Add whether the text to insert has backticks
350 -- Add whether the text to insert has backticks
340 ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'
351 ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'
341
352
@@ -361,7 +372,9 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl
361 filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
372 filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
362 filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas
373 filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas
363 filtOptsCompls = filtListWith mkExtCompl
374 filtOptsCompls = filtListWith mkExtCompl
375+ filtKeywordCompls
364− filtKeywordCompls = if T.null prefixModule then filtListWith mkExtCompl keywords else []
376+ | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)
377+ | otherwise = []
365
378
366 stripLeading :: Char -> String -> String
379 stripLeading :: Char -> String -> String
367 stripLeading _ [] = []
380 stripLeading _ [] = []
@@ -382,13 +395,17 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl
382 = filtModNameCompls ++ map (toggleSnippets caps withSnippets
395 = filtModNameCompls ++ map (toggleSnippets caps withSnippets
383 . mkCompl ideOpts . stripAutoGenerated) filtCompls
396 . mkCompl ideOpts . stripAutoGenerated) filtCompls
384 ++ filtKeywordCompls
397 ++ filtKeywordCompls
385−
398+
386 return result
399 return result
387
400
388-- The supported languages and extensions
401-- The supported languages and extensions
389languagesAndExts :: [T.Text]
402languagesAndExts :: [T.Text]
403+#if MIN_GHC_API_VERSION(8,10,0)
404+languagesAndExts = map T.pack $ DynFlags.supportedLanguagesAndExtensions ( PlatformMini ArchUnknown OSUnknown )
405+#else
390languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions
406languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions
391−
407+#endif
408+
392-- ---------------------------------------------------------------------
409-- ---------------------------------------------------------------------
393-- helper functions for pragmas
410-- helper functions for pragmas
394-- ---------------------------------------------------------------------
411-- ---------------------------------------------------------------------
@@ -511,24 +528,3 @@ prefixes =
511 , "$c"
528 , "$c"
512 , "$m"
529 , "$m"
513 ]
530 ]
514−
515−keywords :: [T.Text]
516−keywords =
517− [
518− -- From https://wiki.haskell.org/Keywords
519− "as"
520− , "case", "of"
521− , "class", "instance", "type"
522− , "data", "family", "newtype"
523− , "default"
524− , "deriving"
525− , "do", "mdo", "proc", "rec"
526− , "forall"
527− , "foreign"
528− , "hiding"
529− , "if", "then", "else"
530− , "import", "qualified", "hiding"
531− , "infix", "infixl", "infixr"
532− , "let", "in", "where"
533− , "module"
534− ]
src/Development/IDE/Spans/AtPoint.hs+17−18
@@ -13,15 +13,12 @@ import Development.IDE.GHC.Orphans()
13import Development.IDE.Types.Location
13import Development.IDE.Types.Location
14
14
15-- DAML compiler and infrastructure
15-- DAML compiler and infrastructure
16−import Development.Shake
17−import Development.IDE.GHC.Util
18import Development.IDE.GHC.Compat
16import Development.IDE.GHC.Compat
19import Development.IDE.Types.Options
17import Development.IDE.Types.Options
20import Development.IDE.Spans.Type as SpanInfo
18import Development.IDE.Spans.Type as SpanInfo
21import Development.IDE.Spans.Common (spanDocToMarkdown)
19import Development.IDE.Spans.Common (spanDocToMarkdown)
22
20
23-- GHC API imports
21-- GHC API imports
24−import Avail
25import DynFlags
22import DynFlags
26import FastString
23import FastString
27import Name
24import Name
@@ -40,14 +37,13 @@ import qualified Data.Text as T
40-- | Locate the definition of the name at a given position.
37-- | Locate the definition of the name at a given position.
41gotoDefinition
38gotoDefinition
42 :: MonadIO m
39 :: MonadIO m
43− => (FilePath -> m (Maybe HieFile))
40+ => (Module -> m (Maybe (HieFile, FilePath)))
44 -> IdeOptions
41 -> IdeOptions
45− -> HscEnv
46 -> [SpanInfo]
42 -> [SpanInfo]
47 -> Position
43 -> Position
48 -> m (Maybe Location)
44 -> m (Maybe Location)
49−gotoDefinition getHieFile ideOpts pkgState srcSpans pos =
45+gotoDefinition getHieFile ideOpts srcSpans pos =
50− listToMaybe <$> locationsAtPoint getHieFile ideOpts pkgState pos srcSpans
46+ listToMaybe <$> locationsAtPoint getHieFile ideOpts pos srcSpans
51
47
52-- | Synopsis for the name at a given position.
48-- | Synopsis for the name at a given position.
53atPoint
49atPoint
@@ -87,7 +83,7 @@ atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do
87 constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts
83 constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts
88 constraintsT = T.intercalate ", " (map showName constraintsOverFVs)
84 constraintsT = T.intercalate ", " (map showName constraintsOverFVs)
89
85
90− typeAnnotation = case constraintsOverFVs of
86+ typeAnnotation = case constraintsOverFVs of
91 [] -> colon <> showName typ
87 [] -> colon <> showName typ
92 [_] -> colon <> constraintsT <> "\n=> " <> showName typ
88 [_] -> colon <> constraintsT <> "\n=> " <> showName typ
93 _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ
89 _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ
@@ -119,8 +115,15 @@ atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do
119 Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]
115 Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]
120 Nothing -> False
116 Nothing -> False
121
117
122−locationsAtPoint :: forall m . MonadIO m => (FilePath -> m (Maybe HieFile)) -> IdeOptions -> HscEnv -> Position -> [SpanInfo] -> m [Location]
118+locationsAtPoint
119+ :: forall m
120+ . MonadIO m
121+ => (Module -> m (Maybe (HieFile, FilePath)))
122+ -> IdeOptions
123+ -> Position
124+ -> [SpanInfo]
125+ -> m [Location]
123−locationsAtPoint getHieFile IdeOptions{..} pkgState pos =
126+locationsAtPoint getHieFile _ideOptions pos =
124 fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos
127 fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos
125 where getSpan :: SpanSource -> m (Maybe SrcSpan)
128 where getSpan :: SpanSource -> m (Maybe SrcSpan)
126 getSpan NoSource = pure Nothing
129 getSpan NoSource = pure Nothing
@@ -130,20 +133,16 @@ locationsAtPoint getHieFile IdeOptions{..} pkgState pos =
130 sp@(RealSrcSpan _) -> pure $ Just sp
133 sp@(RealSrcSpan _) -> pure $ Just sp
131 sp@(UnhelpfulSpan _) -> runMaybeT $ do
134 sp@(UnhelpfulSpan _) -> runMaybeT $ do
132 guard (sp /= wiredInSrcSpan)
135 guard (sp /= wiredInSrcSpan)
133− -- This case usually arises when the definition is in an external package.
136+ -- This case usually arises when the definition is in an external package (DAML only).
134 -- In this case the interface files contain garbage source spans
137 -- In this case the interface files contain garbage source spans
135 -- so we instead read the .hie files to get useful source spans.
138 -- so we instead read the .hie files to get useful source spans.
136 mod <- MaybeT $ return $ nameModule_maybe name
139 mod <- MaybeT $ return $ nameModule_maybe name
137− let unitId = moduleUnitId mod
138− pkgConfig <- MaybeT $ pure $ lookupPackageConfig unitId pkgState
139− hiePath <- MaybeT $ liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod
140− hieFile <- MaybeT $ getHieFile hiePath
140+ (hieFile, srcPath) <- MaybeT $ getHieFile mod
141− avail <- MaybeT $ pure $ listToMaybe (filterAvails (eqName name) $ hie_exports hieFile)
141+ avail <- MaybeT $ pure $ find (eqName name . snd) $ hieExportNames hieFile
142− srcPath <- MaybeT $ liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod
143 -- The location will point to the source file used during compilation.
142 -- The location will point to the source file used during compilation.
144 -- This file might no longer exists and even if it does the path will be relative
143 -- This file might no longer exists and even if it does the path will be relative
145 -- to the compilation directory which we don’t know.
144 -- to the compilation directory which we don’t know.
146− let span = setFileName srcPath $ nameSrcSpan $ availName avail
145+ let span = setFileName srcPath $ fst avail
147 pure span
146 pure span
148 -- We ignore uniques and source spans and only compare the name and the module.
147 -- We ignore uniques and source spans and only compare the name and the module.
149 eqName :: Name -> Name -> Bool
148 eqName :: Name -> Name -> Bool
src/Development/IDE/Spans/Calculate.hs+34−25
@@ -20,6 +20,7 @@ import DataCon
20import Desugar
20import Desugar
21import GHC
21import GHC
22import GhcMonad
22import GhcMonad
23+import HscTypes
23import FastString (mkFastString)
24import FastString (mkFastString)
24import OccName
25import OccName
25import Development.IDE.Types.Location
26import Development.IDE.Types.Location
@@ -49,28 +50,36 @@ import Development.IDE.Spans.Documentation
49-- | Get source span info, used for e.g. AtPoint and Goto Definition.
50-- | Get source span info, used for e.g. AtPoint and Goto Definition.
50getSrcSpanInfos
51getSrcSpanInfos
51 :: HscEnv
52 :: HscEnv
52− -> [(Located ModuleName, Maybe NormalizedFilePath)]
53+ -> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order
53 -> TcModuleResult
54 -> TcModuleResult
54− -> [TcModuleResult]
55+ -> [ParsedModule] -- ^ Dependencies parsed, optional
56+ -> [ModIface] -- ^ Dependencies module interfaces, required
55 -> IO SpansInfo
57 -> IO SpansInfo
56−getSrcSpanInfos env imports tc tms =
58+getSrcSpanInfos env imports tc parsedDeps deps =
57− runGhcEnv env $
59+ evalGhcEnv env $
58− getSpanInfo imports (tmrModule tc) (map tmrModule tms)
60+ getSpanInfo imports (tmrModule tc) parsedDeps deps
59
61
60-- | Get ALL source spans in the module.
62-- | Get ALL source spans in the module.
61getSpanInfo :: GhcMonad m
63getSpanInfo :: GhcMonad m
62 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports
64 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports
63 -> TypecheckedModule
65 -> TypecheckedModule
64− -> [TypecheckedModule]
66+ -> [ParsedModule]
67+ -> [ModIface]
65 -> m SpansInfo
68 -> m SpansInfo
66−getSpanInfo mods tcm tcms =
69+getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps deps =
67− do let tcs = tm_typechecked_source tcm
70+ do let tcs = tm_typechecked_source
68 bs = listifyAllSpans tcs :: [LHsBind GhcTc]
71 bs = listifyAllSpans tcs :: [LHsBind GhcTc]
69 es = listifyAllSpans tcs :: [LHsExpr GhcTc]
72 es = listifyAllSpans tcs :: [LHsExpr GhcTc]
70 ps = listifyAllSpans' tcs :: [Pat GhcTc]
73 ps = listifyAllSpans' tcs :: [Pat GhcTc]
71− ts = listifyAllSpans $ tm_renamed_source tcm :: [LHsType GhcRn]
74+ ts = listifyAllSpans tm_renamed_source :: [LHsType GhcRn]
72− allModules = tcm:tcms
75+ allModules = tm_parsed_module : parsedDeps
73− funBinds = funBindMap $ tm_parsed_module tcm
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+
74 bts <- mapM (getTypeLHsBind allModules funBinds) bs -- binds
83 bts <- mapM (getTypeLHsBind allModules funBinds) bs -- binds
75 ets <- mapM (getTypeLHsExpr allModules) es -- expressions
84 ets <- mapM (getTypeLHsExpr allModules) es -- expressions
76 pts <- mapM (getTypeLPat allModules) ps -- patterns
85 pts <- mapM (getTypeLPat allModules) ps -- patterns
@@ -117,19 +126,19 @@ ieLNames _ = []
117
126
118-- | Get the name and type of a binding.
127-- | Get the name and type of a binding.
119getTypeLHsBind :: (GhcMonad m)
128getTypeLHsBind :: (GhcMonad m)
120− => [TypecheckedModule]
129+ => [ParsedModule]
121 -> OccEnv (HsBind GhcPs)
130 -> OccEnv (HsBind GhcPs)
122 -> LHsBind GhcTc
131 -> LHsBind GhcTc
123 -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
132 -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
124−getTypeLHsBind tms funBinds (L _spn FunBind{fun_id = pid})
133+getTypeLHsBind deps funBinds (L _spn FunBind{fun_id = pid})
125 | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) = do
134 | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) = do
126 let name = getName (unLoc pid)
135 let name = getName (unLoc pid)
127− docs <- getDocumentationTryGhc tms name
136+ docs <- getDocumentationTryGhc deps name
128 return [(Named name, getLoc mc_fun, Just (varType (unLoc pid)), docs) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]
137 return [(Named name, getLoc mc_fun, Just (varType (unLoc pid)), docs) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]
129-- In theory this shouldn’t ever fail but if it does, we can at least show the first clause.
138-- In theory this shouldn’t ever fail but if it does, we can at least show the first clause.
130−getTypeLHsBind tms _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do
139+getTypeLHsBind deps _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do
131 let name = getName (unLoc pid)
140 let name = getName (unLoc pid)
132− docs <- getDocumentationTryGhc tms name
141+ docs <- getDocumentationTryGhc deps name
133 return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)]
142 return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)]
134getTypeLHsBind _ _ _ = return []
143getTypeLHsBind _ _ _ = return []
135
144
@@ -142,17 +151,17 @@ getConstraintsLHsBind _ = []
142
151
143-- | Get the name and type of an expression.
152-- | Get the name and type of an expression.
144getTypeLHsExpr :: (GhcMonad m)
153getTypeLHsExpr :: (GhcMonad m)
145− => [TypecheckedModule]
154+ => [ParsedModule]
146 -> LHsExpr GhcTc
155 -> LHsExpr GhcTc
147 -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
156 -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
148−getTypeLHsExpr tms e = do
157+getTypeLHsExpr deps e = do
149 hs_env <- getSession
158 hs_env <- getSession
150 (_, mbe) <- liftIO (deSugarExpr hs_env e)
159 (_, mbe) <- liftIO (deSugarExpr hs_env e)
151 case mbe of
160 case mbe of
152 Just expr -> do
161 Just expr -> do
153 let ss = getSpanSource (unLoc e)
162 let ss = getSpanSource (unLoc e)
154 docs <- case ss of
163 docs <- case ss of
155− Named n -> getDocumentationTryGhc tms n
164+ Named n -> getDocumentationTryGhc deps n
156 _ -> return emptySpanDoc
165 _ -> return emptySpanDoc
157 return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr), docs)
166 return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr), docs)
158 Nothing -> return Nothing
167 Nothing -> return Nothing
@@ -198,13 +207,13 @@ getTypeLHsExpr tms e = do
198
207
199-- | Get the name and type of a pattern.
208-- | Get the name and type of a pattern.
200getTypeLPat :: (GhcMonad m)
209getTypeLPat :: (GhcMonad m)
201− => [TypecheckedModule]
210+ => [ParsedModule]
202 -> Pat GhcTc
211 -> Pat GhcTc
203 -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
212 -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
204−getTypeLPat tms pat = do
213+getTypeLPat deps pat = do
205 let (src, spn) = getSpanSource pat
214 let (src, spn) = getSpanSource pat
206 docs <- case src of
215 docs <- case src of
207− Named n -> getDocumentationTryGhc tms n
216+ Named n -> getDocumentationTryGhc deps n
208 _ -> return emptySpanDoc
217 _ -> return emptySpanDoc
209 return $ Just (src, spn, Just (hsPatType pat), docs)
218 return $ Just (src, spn, Just (hsPatType pat), docs)
210 where
219 where
@@ -216,12 +225,12 @@ getTypeLPat tms pat = do
216
225
217getLHsType
226getLHsType
218 :: GhcMonad m
227 :: GhcMonad m
219− => [TypecheckedModule]
228+ => [ParsedModule]
220 -> LHsType GhcRn
229 -> LHsType GhcRn
221 -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
230 -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
222−getLHsType tms (L spn (HsTyVar U _ v)) = do
231+getLHsType deps (L spn (HsTyVar U _ v)) = do
223 let n = unLoc v
232 let n = unLoc v
224− docs <- getDocumentationTryGhc tms n
233+ docs <- getDocumentationTryGhc deps n
225#ifdef GHC_LIB
234#ifdef GHC_LIB
226 let ty = Right Nothing
235 let ty = Right Nothing
227#else
236#else
src/Development/IDE/Spans/Common.hs+4−13
@@ -18,6 +18,7 @@ module Development.IDE.Spans.Common (
18import Data.Data
18import Data.Data
19import qualified Data.Generics
19import qualified Data.Generics
20import qualified Data.Text as T
20import qualified Data.Text as T
21+import Data.List.Extra
21
22
22import GHC
23import GHC
23import Outputable
24import Outputable
@@ -28,7 +29,6 @@ import DataCon
28import Var
29import Var
29#endif
30#endif
30
31
31−import Data.Char (isSpace)
32import qualified Documentation.Haddock.Parser as H
32import qualified Documentation.Haddock.Parser as H
33import qualified Documentation.Haddock.Types as H
33import qualified Documentation.Haddock.Types as H
34
34
@@ -82,11 +82,7 @@ spanDocToMarkdown (SpanDocText txt) = txt
82
82
83spanDocToMarkdownForTest :: String -> String
83spanDocToMarkdownForTest :: String -> String
84spanDocToMarkdownForTest
84spanDocToMarkdownForTest
85−#if MIN_VERSION_haddock_library(1,6,0)
86 = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing
85 = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing
87−#else
88− = haddockToMarkdown . H.toRegular . H._doc . H.parseParas
89−#endif
90
86
91-- Simple (and a bit hacky) conversion from Haddock markup to Markdown
87-- Simple (and a bit hacky) conversion from Haddock markup to Markdown
92haddockToMarkdown
88haddockToMarkdown
@@ -127,13 +123,8 @@ haddockToMarkdown (H.DocExamples es)
127 = ">>> " ++ expr ++ "\n" ++ unlines result
123 = ">>> " ++ expr ++ "\n" ++ unlines result
128haddockToMarkdown (H.DocHyperlink (H.Hyperlink url Nothing))
124haddockToMarkdown (H.DocHyperlink (H.Hyperlink url Nothing))
129 = "<" ++ url ++ ">"
125 = "<" ++ url ++ ">"
130−#if MIN_VERSION_haddock_library(1,8,0)
131haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))
126haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))
132 = "[" ++ haddockToMarkdown label ++ "](" ++ url ++ ")"
127 = "[" ++ haddockToMarkdown label ++ "](" ++ url ++ ")"
133−#else
134−haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))
135− = "[" ++ label ++ "](" ++ url ++ ")"
136−#endif
137haddockToMarkdown (H.DocPic (H.Picture url Nothing))
128haddockToMarkdown (H.DocPic (H.Picture url Nothing))
138 = "![](" ++ url ++ ")"
129 = "![](" ++ url ++ ")"
139haddockToMarkdown (H.DocPic (H.Picture url (Just label)))
130haddockToMarkdown (H.DocPic (H.Picture url (Just label)))
@@ -144,9 +135,9 @@ haddockToMarkdown (H.DocHeader (H.Header level title))
144 = replicate level '#' ++ " " ++ haddockToMarkdown title
135 = replicate level '#' ++ " " ++ haddockToMarkdown title
145
136
146haddockToMarkdown (H.DocUnorderedList things)
137haddockToMarkdown (H.DocUnorderedList things)
147− = '\n' : (unlines $ map (("+ " ++) . dropWhile isSpace . splitForList . haddockToMarkdown) things)
138+ = '\n' : (unlines $ map (("+ " ++) . trimStart . splitForList . haddockToMarkdown) things)
148haddockToMarkdown (H.DocOrderedList things)
139haddockToMarkdown (H.DocOrderedList things)
149− = '\n' : (unlines $ map (("1. " ++) . dropWhile isSpace . splitForList . haddockToMarkdown) things)
140+ = '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things)
150haddockToMarkdown (H.DocDefList things)
141haddockToMarkdown (H.DocDefList things)
151 = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things)
142 = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things)
152
143
@@ -168,4 +159,4 @@ splitForList :: String -> String
168splitForList s
159splitForList s
169 = case lines s of
160 = case lines s of
170 [] -> ""
161 [] -> ""
171− (first:rest) -> unlines $ first : map ((" " ++) . dropWhile isSpace) rest
162+ (first:rest) -> unlines $ first : map ((" " ++) . trimStart) rest
src/Development/IDE/Spans/Documentation.hs+21−19
@@ -14,33 +14,33 @@ import Data.List.Extra
14import qualified Data.Map as M
14import qualified Data.Map as M
15import Data.Maybe
15import Data.Maybe
16import qualified Data.Text as T
16import qualified Data.Text as T
17+import Development.IDE.GHC.Compat
17import Development.IDE.GHC.Error
18import Development.IDE.GHC.Error
18import Development.IDE.Spans.Common
19import Development.IDE.Spans.Common
19import FastString
20import FastString
20−import GHC
21import SrcLoc
21import SrcLoc
22
22
23
23
24getDocumentationTryGhc
24getDocumentationTryGhc
25 :: GhcMonad m
25 :: GhcMonad m
26− => [TypecheckedModule]
26+ => [ParsedModule]
27 -> Name
27 -> Name
28 -> m SpanDoc
28 -> m SpanDoc
29-- getDocs goes through the GHCi codepaths which cause problems on ghc-lib.
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.
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)
31#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
32−getDocumentationTryGhc tcs name = do
32+getDocumentationTryGhc sources name = do
33 res <- catchSrcErrors "docs" $ getDocs name
33 res <- catchSrcErrors "docs" $ getDocs name
34 case res of
34 case res of
35 Right (Right (Just docs, _)) -> return $ SpanDocString docs
35 Right (Right (Just docs, _)) -> return $ SpanDocString docs
36− _ -> return $ SpanDocText $ getDocumentation tcs name
36+ _ -> return $ SpanDocText $ getDocumentation sources name
37#else
37#else
38−getDocumentationTryGhc tcs name = do
38+getDocumentationTryGhc sources name = do
39− return $ SpanDocText $ getDocumentation tcs name
39+ return $ SpanDocText $ getDocumentation sources name
40#endif
40#endif
41
41
42getDocumentation
42getDocumentation
43− :: [TypecheckedModule] -- ^ All of the possible modules it could be defined in.
43+ :: [ParsedModule] -- ^ All of the possible modules it could be defined in.
44 -> Name -- ^ The name you want documentation for.
44 -> Name -- ^ The name you want documentation for.
45 -> [T.Text]
45 -> [T.Text]
46-- This finds any documentation between the name you want
46-- This finds any documentation between the name you want
@@ -50,16 +50,18 @@ getDocumentation
50-- may be edge cases where it is very wrong).
50-- may be edge cases where it is very wrong).
51-- TODO : Build a version of GHC exactprint to extract this information
51-- TODO : Build a version of GHC exactprint to extract this information
52-- more accurately.
52-- more accurately.
53−getDocumentation tcs targetName = fromMaybe [] $ do
53+getDocumentation sources targetName = fromMaybe [] $ do
54 -- Find the module the target is defined in.
54 -- Find the module the target is defined in.
55 targetNameSpan <- realSpan $ nameSrcSpan targetName
55 targetNameSpan <- realSpan $ nameSrcSpan targetName
56 tc <-
56 tc <-
57 find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)
57 find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)
58− $ reverse tcs -- TODO : Is reversing the list here really neccessary?
58+ $ reverse sources -- TODO : Is reversing the list here really neccessary?
59+
59− -- Names bound by the module (we want to exclude non-"top-level"
60+ -- Top level names bound by the module
60− -- bindings but unfortunately we get all here).
61+ let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc
62+ , L _ (ValD hsbind) <- hsmodDecls
61− let bs = mapMaybe name_of_bind
63+ , Just n <- [name_of_bind hsbind]
62− (listifyAllSpans (tm_typechecked_source tc) :: [LHsBind GhcTc])
64+ ]
63 -- Sort the names' source spans.
65 -- Sort the names' source spans.
64 let sortedSpans = sortedNameSpans bs
66 let sortedSpans = sortedNameSpans bs
65 -- Now go ahead and extract the docs.
67 -- Now go ahead and extract the docs.
@@ -81,16 +83,16 @@ getDocumentation tcs targetName = fromMaybe [] $ do
81 where
83 where
82 -- Get the name bound by a binding. We only concern ourselves with
84 -- Get the name bound by a binding. We only concern ourselves with
83 -- @FunBind@ (which covers functions and variables).
85 -- @FunBind@ (which covers functions and variables).
84− name_of_bind :: LHsBind GhcTc -> Maybe Name
86+ name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)
85− name_of_bind (L _ FunBind {fun_id}) = Just (getName (unLoc fun_id))
87+ name_of_bind FunBind {fun_id} = Just fun_id
86 name_of_bind _ = Nothing
88 name_of_bind _ = Nothing
87 -- Get source spans from names, discard unhelpful spans, remove
89 -- Get source spans from names, discard unhelpful spans, remove
88 -- duplicates and sort.
90 -- duplicates and sort.
89− sortedNameSpans :: [Name] -> [RealSrcSpan]
91+ sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]
90− sortedNameSpans ls = nubSort (mapMaybe (realSpan . nameSrcSpan) ls)
92+ sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)
91 isBetween target before after = before <= target && target <= after
93 isBetween target before after = before <= target && target <= after
92− ann = snd . pm_annotations . tm_parsed_module
94+ ann = snd . pm_annotations
93− annotationFileName :: TypecheckedModule -> Maybe FastString
95+ annotationFileName :: ParsedModule -> Maybe FastString
94 annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann
96 annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann
95 realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]
97 realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]
96 realSpans =
98 realSpans =
src/Development/IDE/Types/Diagnostics.hs+19−5
@@ -6,10 +6,12 @@ module Development.IDE.Types.Diagnostics (
6 LSP.Diagnostic(..),
6 LSP.Diagnostic(..),
7 ShowDiagnostic(..),
7 ShowDiagnostic(..),
8 FileDiagnostic,
8 FileDiagnostic,
9+ IdeResult,
9 LSP.DiagnosticSeverity(..),
10 LSP.DiagnosticSeverity(..),
10 DiagnosticStore,
11 DiagnosticStore,
11 List(..),
12 List(..),
12 ideErrorText,
13 ideErrorText,
14+ ideErrorWithSource,
13 showDiagnostics,
15 showDiagnostics,
14 showDiagnosticsColored,
16 showDiagnosticsColored,
15 ) where
17 ) where
@@ -18,7 +20,7 @@ import Control.DeepSeq
18import Data.Maybe as Maybe
20import Data.Maybe as Maybe
19import qualified Data.Text as T
21import qualified Data.Text as T
20import Data.Text.Prettyprint.Doc
22import Data.Text.Prettyprint.Doc
21−import Language.Haskell.LSP.Types as LSP (
23+import Language.Haskell.LSP.Types as LSP (DiagnosticSource,
22 DiagnosticSeverity(..)
24 DiagnosticSeverity(..)
23 , Diagnostic(..)
25 , Diagnostic(..)
24 , List(..)
26 , List(..)
@@ -30,15 +32,27 @@ import Data.Text.Prettyprint.Doc.Render.Terminal (Color(..), color)
30
32
31import Development.IDE.Types.Location
33import Development.IDE.Types.Location
32
34
35+-- A rule on a file should only return diagnostics for that given file. It should
36+-- not propagate diagnostic errors through multiple phases.
37+type IdeResult v = ([FileDiagnostic], Maybe v)
33
38
34ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic
39ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic
40+ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError)
41+
42+ideErrorWithSource
43+ :: Maybe DiagnosticSource
44+ -> Maybe DiagnosticSeverity
45+ -> a
46+ -> T.Text
47+ -> (a, ShowDiagnostic, Diagnostic)
35−ideErrorText fp msg = (fp, ShowDiag, LSP.Diagnostic {
48+ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic {
36 _range = noRange,
49 _range = noRange,
37− _severity = Just LSP.DsError,
50+ _severity = sev,
38 _code = Nothing,
51 _code = Nothing,
39− _source = Just "compiler",
52+ _source = source,
40 _message = msg,
53 _message = msg,
41− _relatedInformation = Nothing
54+ _relatedInformation = Nothing,
55+ _tags = Nothing
42 })
56 })
43
57
44-- | Defines whether a particular diagnostic should be reported
58-- | Defines whether a particular diagnostic should be reported
src/Development/IDE/Types/Location.hs+24−79
@@ -10,15 +10,16 @@ module Development.IDE.Types.Location
10 , Position(..)
10 , Position(..)
11 , showPosition
11 , showPosition
12 , Range(..)
12 , Range(..)
13− , Uri(..)
13+ , LSP.Uri(..)
14− , NormalizedUri
14+ , LSP.NormalizedUri
15 , LSP.toNormalizedUri
15 , LSP.toNormalizedUri
16 , LSP.fromNormalizedUri
16 , LSP.fromNormalizedUri
17− , NormalizedFilePath
17+ , LSP.NormalizedFilePath
18 , fromUri
18 , fromUri
19+ , emptyFilePath
20+ , emptyPathUri
19− , toNormalizedFilePath
21+ , toNormalizedFilePath'
20− , fromNormalizedFilePath
22+ , LSP.fromNormalizedFilePath
21− , filePathToUri
22 , filePathToUri'
23 , filePathToUri'
23 , uriToFilePath'
24 , uriToFilePath'
24 , readSrcSpan
25 , readSrcSpan
@@ -26,98 +27,42 @@ module Development.IDE.Types.Location
26
27
27import Control.Applicative
28import Control.Applicative
28import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..))
29import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..))
29−import Control.DeepSeq
30import Control.Monad
30import Control.Monad
31−import Data.Binary
31+import Data.Hashable (Hashable(hash))
32−import Data.Maybe as Maybe
33−import Data.Hashable
34import Data.String
32import Data.String
35−import qualified Data.Text as T
36import FastString
33import FastString
37−import Network.URI
38−import System.FilePath
39−import qualified System.FilePath.Posix as FPP
40−import qualified System.FilePath.Windows as FPW
41−import System.Info.Extra
42import qualified Language.Haskell.LSP.Types as LSP
34import qualified Language.Haskell.LSP.Types as LSP
43−import Language.Haskell.LSP.Types as LSP (
44− filePathToUri
45− , NormalizedUri(..)
46− , Uri(..)
47− , toNormalizedUri
48− , fromNormalizedUri
49− )
50import SrcLoc as GHC
35import SrcLoc as GHC
51import Text.ParserCombinators.ReadP as ReadP
36import Text.ParserCombinators.ReadP as ReadP
37+import Data.Maybe (fromMaybe)
52
38
53−
54−-- | Newtype wrapper around FilePath that always has normalized slashes.
55−newtype NormalizedFilePath = NormalizedFilePath FilePath
56− deriving (Eq, Ord, Show, Hashable, NFData, Binary)
57−
58−instance IsString NormalizedFilePath where
59− fromString = toNormalizedFilePath
60−
61−toNormalizedFilePath :: FilePath -> NormalizedFilePath
39+toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath
62-- We want to keep empty paths instead of normalising them to "."
40-- We want to keep empty paths instead of normalising them to "."
63−toNormalizedFilePath "" = NormalizedFilePath ""
41+toNormalizedFilePath' "" = emptyFilePath
64−toNormalizedFilePath fp = NormalizedFilePath $ normalise fp
42+toNormalizedFilePath' fp = LSP.toNormalizedFilePath fp
65
43
66−fromNormalizedFilePath :: NormalizedFilePath -> FilePath
44+emptyFilePath :: LSP.NormalizedFilePath
67−fromNormalizedFilePath (NormalizedFilePath fp) = fp
45+emptyFilePath = LSP.NormalizedFilePath emptyPathUri ""
68
46
69-- | We use an empty string as a filepath when we don’t have a file.
47-- | We use an empty string as a filepath when we don’t have a file.
70-- However, haskell-lsp doesn’t support that in uriToFilePath and given
48-- However, haskell-lsp doesn’t support that in uriToFilePath and given
71-- that it is not a valid filepath it does not make sense to upstream a fix.
49-- that it is not a valid filepath it does not make sense to upstream a fix.
72-- So we have our own wrapper here that supports empty filepaths.
50-- So we have our own wrapper here that supports empty filepaths.
73−uriToFilePath' :: Uri -> Maybe FilePath
51+uriToFilePath' :: LSP.Uri -> Maybe FilePath
74uriToFilePath' uri
52uriToFilePath' uri
75− | uri == fromNormalizedUri emptyPathUri = Just ""
53+ | uri == LSP.fromNormalizedUri emptyPathUri = Just ""
76 | otherwise = LSP.uriToFilePath uri
54 | otherwise = LSP.uriToFilePath uri
77
55
78−emptyPathUri :: NormalizedUri
56+emptyPathUri :: LSP.NormalizedUri
79−emptyPathUri = filePathToUri' ""
57+emptyPathUri =
58+ let s = "file://"
59+ in LSP.NormalizedUri (hash s) s
80
60
81−filePathToUri' :: NormalizedFilePath -> NormalizedUri
61+filePathToUri' :: LSP.NormalizedFilePath -> LSP.NormalizedUri
82−filePathToUri' (NormalizedFilePath fp) = toNormalizedUri $ Uri $ T.pack $ LSP.fileScheme <> "//" <> platformAdjustToUriPath fp
62+filePathToUri' = LSP.normalizedFilePathToUri
83− where
84− -- The definitions below are variants of the corresponding functions in Language.Haskell.LSP.Types.Uri that assume that
85− -- the filepath has already been normalised. This is necessary since normalising the filepath has a nontrivial cost.
86−
87− toNormalizedUri :: Uri -> NormalizedUri
88− toNormalizedUri (Uri t) =
89− NormalizedUri $ T.pack $ escapeURIString isUnescapedInURI $ unEscapeString $ T.unpack t
90−
91− platformAdjustToUriPath :: FilePath -> String
92− platformAdjustToUriPath srcPath
93− | isWindows = '/' : escapedPath
94− | otherwise = escapedPath
95− where
96− (splitDirectories, splitDrive)
97− | isWindows =
98− (FPW.splitDirectories, FPW.splitDrive)
99− | otherwise =
100− (FPP.splitDirectories, FPP.splitDrive)
101− escapedPath =
102− case splitDrive srcPath of
103− (drv, rest) ->
104− convertDrive drv `FPP.joinDrive`
105− FPP.joinPath (map (escapeURIString unescaped) $ splitDirectories rest)
106− -- splitDirectories does not remove the path separator after the drive so
107− -- we do a final replacement of \ to /
108− convertDrive drv
109− | isWindows && FPW.hasTrailingPathSeparator drv =
110− FPP.addTrailingPathSeparator (init drv)
111− | otherwise = drv
112− unescaped c
113− | isWindows = isUnreserved c || c `elem` [':', '\\', '/']
114− | otherwise = isUnreserved c || c == '/'
115−
116−
117−
118−fromUri :: LSP.NormalizedUri -> NormalizedFilePath
119−fromUri = toNormalizedFilePath . fromMaybe noFilePath . uriToFilePath' . fromNormalizedUri
120
63
64+fromUri :: LSP.NormalizedUri -> LSP.NormalizedFilePath
65+fromUri = fromMaybe (toNormalizedFilePath' noFilePath) . LSP.uriToNormalizedFilePath
121
66
122noFilePath :: FilePath
67noFilePath :: FilePath
123noFilePath = "<unknown>"
68noFilePath = "<unknown>"
src/Development/IDE/Types/Options.hs+35−8
@@ -12,25 +12,25 @@ module Development.IDE.Types.Options
12 , clientSupportsProgress
12 , clientSupportsProgress
13 , IdePkgLocationOptions(..)
13 , IdePkgLocationOptions(..)
14 , defaultIdeOptions
14 , defaultIdeOptions
15+ , IdeResult
15 ) where
16 ) where
16
17
17−import Data.Maybe
18import Development.Shake
18import Development.Shake
19import Development.IDE.GHC.Util
19import Development.IDE.GHC.Util
20import GHC hiding (parseModule, typecheckModule)
20import GHC hiding (parseModule, typecheckModule)
21import GhcPlugins as GHC hiding (fst3, (<>))
21import GhcPlugins as GHC hiding (fst3, (<>))
22import qualified Language.Haskell.LSP.Types.Capabilities as LSP
22import qualified Language.Haskell.LSP.Types.Capabilities as LSP
23+import qualified Data.Text as T
24+import Development.IDE.Types.Diagnostics
23
25
24data IdeOptions = IdeOptions
26data IdeOptions = IdeOptions
25 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource
27 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource
26 -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings
28 -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings
27 -- and a list of errors, along with a new parse tree.
29 -- and a list of errors, along with a new parse tree.
28− , optGhcSession :: IO (FilePath -> Action HscEnvEq)
30+ , optGhcSession :: Action (FilePath -> Action (IdeResult HscEnvEq))
29 -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.
31 -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.
30− -- The 'IO' will be called once, then the resulting function will be applied once per file.
32+ -- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.
31 -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.
33 -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.
32− -- You should not use 'newCacheIO' to get that caching, because of
33− -- https://github.com/ndmitchell/shake/issues/725.
34 , optPkgLocationOpts :: IdePkgLocationOptions
34 , optPkgLocationOpts :: IdePkgLocationOptions
35 -- ^ How to locate source and @.hie@ files given a module name.
35 -- ^ How to locate source and @.hie@ files given a module name.
36 , optExtensions :: [String]
36 , optExtensions :: [String]
@@ -43,12 +43,17 @@ data IdeOptions = IdeOptions
43 -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds.
43 -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds.
44 , optShakeProfiling :: Maybe FilePath
44 , optShakeProfiling :: Maybe FilePath
45 -- ^ Set to 'Just' to create a directory of profiling reports.
45 -- ^ Set to 'Just' to create a directory of profiling reports.
46+ , optTesting :: Bool
47+ -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
46 , optReportProgress :: IdeReportProgress
48 , optReportProgress :: IdeReportProgress
47 -- ^ Whether to report progress during long operations.
49 -- ^ Whether to report progress during long operations.
48 , optLanguageSyntax :: String
50 , optLanguageSyntax :: String
49 -- ^ the ```language to use
51 -- ^ the ```language to use
50 , optNewColonConvention :: Bool
52 , optNewColonConvention :: Bool
51 -- ^ whether to use new colon convention
53 -- ^ whether to use new colon convention
54+ , optKeywords :: [T.Text]
55+ -- ^ keywords used for completions. These are customizable
56+ -- since DAML has a different set of keywords than Haskell.
52 , optDefer :: IdeDefer
57 , optDefer :: IdeDefer
53 -- ^ Whether to defer type errors, typed holes and out of scope
58 -- ^ Whether to defer type errors, typed holes and out of scope
54 -- variables. Deferral allows the IDE to continue to provide
59 -- variables. Deferral allows the IDE to continue to provide
@@ -70,10 +75,10 @@ newtype IdeReportProgress = IdeReportProgress Bool
70newtype IdeDefer = IdeDefer Bool
75newtype IdeDefer = IdeDefer Bool
71
76
72clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress
77clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress
73−clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $
78+clientSupportsProgress caps = IdeReportProgress $ Just True ==
74− LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)
79+ (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))
75
80
76−defaultIdeOptions :: IO (FilePath -> Action HscEnvEq) -> IdeOptions
81+defaultIdeOptions :: Action (FilePath -> Action (IdeResult HscEnvEq)) -> IdeOptions
77defaultIdeOptions session = IdeOptions
82defaultIdeOptions session = IdeOptions
78 {optPreprocessor = IdePreprocessedSource [] []
83 {optPreprocessor = IdePreprocessedSource [] []
79 ,optGhcSession = session
84 ,optGhcSession = session
@@ -85,7 +90,9 @@ defaultIdeOptions session = IdeOptions
85 ,optReportProgress = IdeReportProgress False
90 ,optReportProgress = IdeReportProgress False
86 ,optLanguageSyntax = "haskell"
91 ,optLanguageSyntax = "haskell"
87 ,optNewColonConvention = False
92 ,optNewColonConvention = False
93+ ,optKeywords = haskellKeywords
88 ,optDefer = IdeDefer True
94 ,optDefer = IdeDefer True
95+ ,optTesting = False
89 }
96 }
90
97
91
98
@@ -103,3 +110,23 @@ data IdePkgLocationOptions = IdePkgLocationOptions
103defaultIdePkgLocationOptions :: IdePkgLocationOptions
110defaultIdePkgLocationOptions :: IdePkgLocationOptions
104defaultIdePkgLocationOptions = IdePkgLocationOptions f f
111defaultIdePkgLocationOptions = IdePkgLocationOptions f f
105 where f _ _ = return Nothing
112 where f _ _ = return Nothing
113+
114+-- | From https://wiki.haskell.org/Keywords
115+haskellKeywords :: [T.Text]
116+haskellKeywords =
117+ [ "as"
118+ , "case", "of"
119+ , "class", "instance", "type"
120+ , "data", "family", "newtype"
121+ , "default"
122+ , "deriving"
123+ , "do", "mdo", "proc", "rec"
124+ , "forall"
125+ , "foreign"
126+ , "hiding"
127+ , "if", "then", "else"
128+ , "import", "qualified", "hiding"
129+ , "infix", "infixl", "infixr"
130+ , "let", "in", "where"
131+ , "module"
132+ ]
stack-ghc-lib.yaml+7−4
@@ -2,15 +2,18 @@ resolver: nightly-2019-09-16
2packages:
2packages:
3- .
3- .
4extra-deps:
4extra-deps:
5−- haskell-lsp-0.19.0.0
5+- haskell-lsp-0.22.0.0
6−- haskell-lsp-types-0.19.0.0
6+- haskell-lsp-types-0.22.0.0
7−- lsp-test-0.10.0.0
7+- lsp-test-0.10.3.0
8−- hie-bios-0.3.2
8+- hie-bios-0.5.0
9- ghc-lib-parser-8.8.1
9- ghc-lib-parser-8.8.1
10- ghc-lib-8.8.1
10- ghc-lib-8.8.1
11- fuzzy-0.1.0.0
11- fuzzy-0.1.0.0
12+- shake-0.18.5
12- regex-base-0.94.0.0
13- regex-base-0.94.0.0
13- regex-tdfa-1.3.1.0
14- regex-tdfa-1.3.1.0
15+- haddock-library-1.8.0
16+- ghc-check-0.3.0.1
14nix:
17nix:
15 packages: [zlib]
18 packages: [zlib]
16flags:
19flags:
stack.yaml+8−4
@@ -2,14 +2,18 @@ resolver: nightly-2019-09-21
2packages:
2packages:
3- .
3- .
4extra-deps:
4extra-deps:
5−- haskell-lsp-0.19.0.0
5+- haskell-lsp-0.22.0.0
6−- haskell-lsp-types-0.19.0.0
6+- haskell-lsp-types-0.22.0.0
7−- lsp-test-0.10.0.0
7+- lsp-test-0.11.0.1
8−- hie-bios-0.3.2
8+- hie-bios-0.5.0
9- fuzzy-0.1.0.0
9- fuzzy-0.1.0.0
10- regex-pcre-builtin-0.95.1.1.8.43
10- regex-pcre-builtin-0.95.1.1.8.43
11- regex-base-0.94.0.0
11- regex-base-0.94.0.0
12- regex-tdfa-1.3.1.0
12- regex-tdfa-1.3.1.0
13+- shake-0.18.5
13- parser-combinators-1.2.1
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
14nix:
18nix:
15 packages: [zlib]
19 packages: [zlib]
stack810.yamlnew file+18
@@ -0,0 +1,18 @@
1+resolver: nightly-2020-02-13
2+compiler: ghc-8.10.1
3+allow-newer: true
4+packages:
5+- .
6+extra-deps:
7+- haskell-lsp-0.22.0.0
8+- haskell-lsp-types-0.22.0.0
9+- lsp-test-0.11.0.1
10+- ghc-check-0.3.0.1
11+- hie-bios-0.5.0
12+
13+# for ghc-8.10
14+- Cabal-3.2.0.0
15+- lens-4.19.1
16+
17+nix:
18+ packages: [zlib]
stack84.yaml+19−6
@@ -3,18 +3,31 @@ packages:
3- .
3- .
4
4
5extra-deps:
5extra-deps:
6+- aeson-1.4.6.0
7+- base-orphans-0.8.2
6−- haskell-lsp-0.19.0.0
8+- haskell-lsp-0.22.0.0
7−- haskell-lsp-types-0.19.0.0
9+- haskell-lsp-types-0.22.0.0
8−- lsp-test-0.10.0.0
10+- lsp-test-0.11.0.1
9- rope-utf16-splay-0.3.1.0
11- rope-utf16-splay-0.3.1.0
10−- shake-0.18.3
11- filepattern-0.1.1
12- filepattern-0.1.1
12- js-dgtable-0.5.2
13- js-dgtable-0.5.2
13−- hie-bios-0.3.2
14+- hie-bios-0.5.0
14- fuzzy-0.1.0.0
15- fuzzy-0.1.0.0
16+- shake-0.18.5
17+- time-compat-1.9.2.2
15- regex-base-0.94.0.0
18- regex-base-0.94.0.0
16- regex-tdfa-1.3.1.0
19- regex-tdfa-1.3.1.0
17- parser-combinators-1.2.1
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+
18nix:
32nix:
19 packages: [zlib]
33 packages: [zlib]
20−allow-newer: true
stack88.yaml+6−3
@@ -1,8 +1,11 @@
1−resolver: nightly-2020-01-21
1+resolver: nightly-2020-02-13
2packages:
2packages:
3- .
3- .
4extra-deps:
4extra-deps:
5−- fuzzy-0.1.0.0
5+- haskell-lsp-0.22.0.0
6−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
7nix:
10nix:
8 packages: [zlib]
11 packages: [zlib]
test/data/hover/Bar.hsnew file+3
@@ -0,0 +1,3 @@
1+module Bar (Bar(..)) where
2+
3+data Bar = Bar
test/data/hover/Foo.hsnew file+5
@@ -0,0 +1,5 @@
1+module Foo (Bar, foo) where
2+
3+import Bar
4+
5+foo = Bar
test/data/GotoHover.hs → test/data/hover/GotoHover.hsrenamed+7
@@ -1,6 +1,10 @@
1+{-# LANGUAGE OverloadedStrings #-}
1{- HLINT ignore -}
2{- HLINT ignore -}
2module Testing ( module Testing ) where
3module Testing ( module Testing ) where
3import Data.Text (Text, pack)
4import Data.Text (Text, pack)
5+import Foo (Bar, foo)
6+
7+
4data TypeConstructor = DataConstructor
8data TypeConstructor = DataConstructor
5 { fff :: Text
9 { fff :: Text
6 , ggg :: Int }
10 , ggg :: Int }
@@ -48,3 +52,6 @@ outer = undefined where
48
52
49 inner :: Char
53 inner :: Char
50 inner = undefined
54 inner = undefined
55+
56+imported :: Bar
57+imported = foo
test/data/multi/a/A.hsnew file+3
@@ -0,0 +1,3 @@
1+module A(foo) where
2+
3+foo = ()
test/data/multi/a/a.cabalnew file+9
@@ -0,0 +1,9 @@
1+name: a
2+version: 1.0.0
3+build-type: Simple
4+cabal-version: >= 1.2
5+
6+library
7+ build-depends: base
8+ exposed-modules: A
9+ hs-source-dirs: .
test/data/multi/b/B.hsnew file+3
@@ -0,0 +1,3 @@
1+module B(module B) where
2+import A
3+qux = foo
test/data/multi/b/b.cabalnew file+9
@@ -0,0 +1,9 @@
1+name: b
2+version: 1.0.0
3+build-type: Simple
4+cabal-version: >= 1.2
5+
6+library
7+ build-depends: base, a
8+ exposed-modules: B
9+ hs-source-dirs: .
test/data/multi/cabal.projectnew file+1
@@ -0,0 +1 @@
1+packages: a b
test/data/multi/hie.yamlnew file+6
@@ -0,0 +1,6 @@
1+cradle:
2+ cabal:
3+ - path: "./a"
4+ component: "lib:a"
5+ - path: "./b"
6+ component: "lib:b"
test/exe/Main.hs+975−270
@@ -1,6 +1,7 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4+{-# LANGUAGE AllowAmbiguousTypes #-}
4{-# LANGUAGE DuplicateRecordFields #-}
5{-# LANGUAGE DuplicateRecordFields #-}
5{-# LANGUAGE PatternSynonyms #-}
6{-# LANGUAGE PatternSynonyms #-}
6{-# LANGUAGE CPP #-}
7{-# LANGUAGE CPP #-}
@@ -9,53 +10,74 @@
9module Main (main) where
10module Main (main) where
10
11
11import Control.Applicative.Combinators
12import Control.Applicative.Combinators
12−import Control.Exception (catch)
13+import Control.Exception (bracket, catch)
14+import qualified Control.Lens as Lens
13import Control.Monad
15import Control.Monad
14import Control.Monad.IO.Class (liftIO)
16import Control.Monad.IO.Class (liftIO)
15−import Data.Char (toLower)
17+import Data.Aeson (FromJSON, Value)
16import Data.Foldable
18import Data.Foldable
17−import Data.List
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)
18import Development.IDE.GHC.Util
23import Development.IDE.GHC.Util
19import qualified Data.Text as T
24import qualified Data.Text as T
25+import Data.Typeable
20import Development.IDE.Spans.Common
26import Development.IDE.Spans.Common
21import Development.IDE.Test
27import Development.IDE.Test
22import Development.IDE.Test.Runfiles
28import Development.IDE.Test.Runfiles
23import Development.IDE.Types.Location
29import Development.IDE.Types.Location
24−import qualified Language.Haskell.LSP.Test as LSPTest
30+import Development.Shake (getDirectoryFilesIO)
25−import Language.Haskell.LSP.Test hiding (openDoc')
31+import Language.Haskell.LSP.Test
32+import Language.Haskell.LSP.Messages
26import Language.Haskell.LSP.Types
33import Language.Haskell.LSP.Types
27import Language.Haskell.LSP.Types.Capabilities
34import Language.Haskell.LSP.Types.Capabilities
35+import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)
36+import Language.Haskell.LSP.VFS (applyChange)
37+import Network.URI
28−import System.Environment.Blank (setEnv)
38+import System.Environment.Blank (getEnv, setEnv, unsetEnv)
29import System.FilePath
39import System.FilePath
30import System.IO.Extra
40import System.IO.Extra
31import System.Directory
41import System.Directory
42+import Test.QuickCheck
43+import Test.QuickCheck.Instances ()
32import Test.Tasty
44import Test.Tasty
33−import Test.Tasty.HUnit
34import Test.Tasty.ExpectedFailure
45import Test.Tasty.ExpectedFailure
46+import Test.Tasty.Ingredients.Rerun
47+import Test.Tasty.HUnit
48+import Test.Tasty.QuickCheck
35import Data.Maybe
49import Data.Maybe
36
50
37main :: IO ()
51main :: IO ()
52+main = do
53+ -- We mess with env vars so run single-threaded.
54+ setEnv "TASTY_NUM_THREADS" "1" True
38−main = defaultMain $ testGroup "HIE"
55+ defaultMainWithRerun $ testGroup "HIE"
39− [ testSession "open close" $ do
56+ [ testSession "open close" $ do
40− doc <- openDoc' "Testing.hs" "haskell" ""
57+ doc <- createDoc "Testing.hs" "haskell" ""
41− void (message :: Session WorkDoneProgressCreateRequest)
58+ void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
42− void (message :: Session WorkDoneProgressBeginNotification)
59+ void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
43− closeDoc doc
60+ closeDoc doc
44− void (message :: Session WorkDoneProgressEndNotification)
61+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
45− , initializeResponseTests
62+ , initializeResponseTests
46− , completionTests
63+ , completionTests
47− , cppTests
64+ , cppTests
48− , diagnosticTests
65+ , diagnosticTests
49− , codeActionTests
66+ , codeActionTests
50− , codeLensesTests
67+ , codeLensesTests
51− , outlineTests
68+ , outlineTests
52− , findDefinitionAndHoverTests
69+ , findDefinitionAndHoverTests
53− , pluginTests
70+ , pluginTests
54− , preprocessorTests
71+ , preprocessorTests
55− , thTests
72+ , thTests
73+ , safeTests
56− , unitTests
74+ , unitTests
57− , haddockTests
75+ , haddockTests
76+ , positionMappingTests
77+ , watchedFilesTests
78+ , cradleTests
79+ , dependentFileTest
58− ]
80+ ]
59
81
60initializeResponseTests :: TestTree
82initializeResponseTests :: TestTree
61initializeResponseTests = withResource acquire release tests where
83initializeResponseTests = withResource acquire release tests where
@@ -90,8 +112,8 @@ initializeResponseTests = withResource acquire release tests where
90 , chk "NO doc link" _documentLinkProvider Nothing
112 , chk "NO doc link" _documentLinkProvider Nothing
91 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
113 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
92 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
114 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
93− , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
115+ , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
94− , chk "NO workspace" _workspace nothingWorkspace
116+ , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
95 , chk "NO experimental" _experimental Nothing
117 , chk "NO experimental" _experimental Nothing
96 ] where
118 ] where
97
119
@@ -102,14 +124,21 @@ initializeResponseTests = withResource acquire release tests where
102 , _willSaveWaitUntil = Nothing
124 , _willSaveWaitUntil = Nothing
103 , _save = Just (SaveOptions {_includeText = Nothing})}))
125 , _save = Just (SaveOptions {_includeText = Nothing})}))
104
126
105− nothingWorkspace = Just (WorkspaceOptions {_workspaceFolders = Nothing})
106−
107 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree
127 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree
108 chk title getActual expected =
128 chk title getActual expected =
109 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
129 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
110
130
131+ che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree
132+ che title getActual _expected = testCase title doTest
133+ where
134+ doTest = do
135+ ir <- getInitializeResponse
136+ let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir
137+ True @=? T.isSuffixOf "typesignature.add" command
138+
139+
111 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
112− innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c
141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
113 innerCaps _ = error "this test only expects inner capabilities"
142 innerCaps _ = error "this test only expects inner capabilities"
114
143
115 acquire :: IO InitializeResponse
144 acquire :: IO InitializeResponse
@@ -123,7 +152,7 @@ diagnosticTests :: TestTree
123diagnosticTests = testGroup "diagnostics"
152diagnosticTests = testGroup "diagnostics"
124 [ testSessionWait "fix syntax error" $ do
153 [ testSessionWait "fix syntax error" $ do
125 let content = T.unlines [ "module Testing wher" ]
154 let content = T.unlines [ "module Testing wher" ]
126− doc <- openDoc' "Testing.hs" "haskell" content
155+ doc <- createDoc "Testing.hs" "haskell" content
127 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
128 let change = TextDocumentContentChangeEvent
157 let change = TextDocumentContentChangeEvent
129 { _range = Just (Range (Position 0 15) (Position 0 19))
158 { _range = Just (Range (Position 0 15) (Position 0 19))
@@ -134,9 +163,9 @@ diagnosticTests = testGroup "diagnostics"
134 expectDiagnostics [("Testing.hs", [])]
163 expectDiagnostics [("Testing.hs", [])]
135 , testSessionWait "introduce syntax error" $ do
164 , testSessionWait "introduce syntax error" $ do
136 let content = T.unlines [ "module Testing where" ]
165 let content = T.unlines [ "module Testing where" ]
137− doc <- openDoc' "Testing.hs" "haskell" content
166+ doc <- createDoc "Testing.hs" "haskell" content
138− void (message :: Session WorkDoneProgressCreateRequest)
167+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
139− void (message :: Session WorkDoneProgressBeginNotification)
168+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
140 let change = TextDocumentContentChangeEvent
169 let change = TextDocumentContentChangeEvent
141 { _range = Just (Range (Position 0 15) (Position 0 18))
170 { _range = Just (Range (Position 0 15) (Position 0 18))
142 , _rangeLength = Nothing
171 , _rangeLength = Nothing
@@ -152,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"
152 , "bar :: Int -> Int -> Int"
181 , "bar :: Int -> Int -> Int"
153 , "bar a b = cd + b"
182 , "bar a b = cd + b"
154 ]
183 ]
155− _ <- openDoc' "Testing.hs" "haskell" content
184+ _ <- createDoc "Testing.hs" "haskell" content
156 expectDiagnostics
185 expectDiagnostics
157 [ ( "Testing.hs"
186 [ ( "Testing.hs"
158 , [ (DsError, (2, 14), "Variable not in scope: ab")
187 , [ (DsError, (2, 14), "Variable not in scope: ab")
@@ -166,7 +195,7 @@ diagnosticTests = testGroup "diagnostics"
166 , "foo :: Int -> String -> Int"
195 , "foo :: Int -> String -> Int"
167 , "foo a b = a + b"
196 , "foo a b = a + b"
168 ]
197 ]
169− _ <- openDoc' "Testing.hs" "haskell" content
198+ _ <- createDoc "Testing.hs" "haskell" content
170 expectDiagnostics
199 expectDiagnostics
171 [ ( "Testing.hs"
200 [ ( "Testing.hs"
172 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
@@ -178,7 +207,7 @@ diagnosticTests = testGroup "diagnostics"
178 , "foo :: Int -> String"
207 , "foo :: Int -> String"
179 , "foo a = _ a"
208 , "foo a = _ a"
180 ]
209 ]
181− _ <- openDoc' "Testing.hs" "haskell" content
210+ _ <- createDoc "Testing.hs" "haskell" content
182 expectDiagnostics
211 expectDiagnostics
183 [ ( "Testing.hs"
212 [ ( "Testing.hs"
184 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
@@ -200,24 +229,23 @@ diagnosticTests = testGroup "diagnostics"
200 [ ("A.hs", [(DsError, (2,4), aMessage)])
229 [ ("A.hs", [(DsError, (2,4), aMessage)])
201 , ("B.hs", [(DsError, (3,4), bMessage)])]
230 , ("B.hs", [(DsError, (3,4), bMessage)])]
202 deferralTest title binding msg = testSessionWait title $ do
231 deferralTest title binding msg = testSessionWait title $ do
203− _ <- openDoc' "A.hs" "haskell" $ sourceA binding
232+ _ <- createDoc "A.hs" "haskell" $ sourceA binding
204− _ <- openDoc' "B.hs" "haskell" sourceB
233+ _ <- createDoc "B.hs" "haskell" sourceB
205 expectDiagnostics $ expectedDs msg
234 expectDiagnostics $ expectedDs msg
206 in
235 in
207 [ deferralTest "type error" "True" "Couldn't match expected type"
236 [ deferralTest "type error" "True" "Couldn't match expected type"
208 , deferralTest "typed hole" "_" "Found hole"
237 , deferralTest "typed hole" "_" "Found hole"
209 , deferralTest "out of scope var" "unbound" "Variable not in scope"
238 , deferralTest "out of scope var" "unbound" "Variable not in scope"
210− , deferralTest "message shows error" "True" "A.hs:3:5: error:"
211 ]
239 ]
212
240
213 , testSessionWait "remove required module" $ do
241 , testSessionWait "remove required module" $ do
214 let contentA = T.unlines [ "module ModuleA where" ]
242 let contentA = T.unlines [ "module ModuleA where" ]
215− docA <- openDoc' "ModuleA.hs" "haskell" contentA
243+ docA <- createDoc "ModuleA.hs" "haskell" contentA
216 let contentB = T.unlines
244 let contentB = T.unlines
217 [ "module ModuleB where"
245 [ "module ModuleB where"
218 , "import ModuleA"
246 , "import ModuleA"
219 ]
247 ]
220− _ <- openDoc' "ModuleB.hs" "haskell" contentB
248+ _ <- createDoc "ModuleB.hs" "haskell" contentB
221 let change = TextDocumentContentChangeEvent
249 let change = TextDocumentContentChangeEvent
222 { _range = Just (Range (Position 0 0) (Position 0 20))
250 { _range = Just (Range (Position 0 0) (Position 0 20))
223 , _rangeLength = Nothing
251 , _rangeLength = Nothing
@@ -230,11 +258,21 @@ diagnosticTests = testGroup "diagnostics"
230 [ "module ModuleB where"
258 [ "module ModuleB where"
231 , "import ModuleA"
259 , "import ModuleA"
232 ]
260 ]
233− _ <- openDoc' "ModuleB.hs" "haskell" contentB
261+ _ <- createDoc "ModuleB.hs" "haskell" contentB
234 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
235 let contentA = T.unlines [ "module ModuleA where" ]
263 let contentA = T.unlines [ "module ModuleA where" ]
236− _ <- openDoc' "ModuleA.hs" "haskell" contentA
264+ _ <- createDoc "ModuleA.hs" "haskell" contentA
237 expectDiagnostics [("ModuleB.hs", [])]
265 expectDiagnostics [("ModuleB.hs", [])]
266+ , testSessionWait "add missing module (non workspace)" $ do
267+ let contentB = T.unlines
268+ [ "module ModuleB where"
269+ , "import ModuleA"
270+ ]
271+ _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB
272+ expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
273+ let contentA = T.unlines [ "module ModuleA where" ]
274+ _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA
275+ expectDiagnostics [("/tmp/ModuleB.hs", [])]
238 , testSessionWait "cyclic module dependency" $ do
276 , testSessionWait "cyclic module dependency" $ do
239 let contentA = T.unlines
277 let contentA = T.unlines
240 [ "module ModuleA where"
278 [ "module ModuleA where"
@@ -244,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"
244 [ "module ModuleB where"
282 [ "module ModuleB where"
245 , "import ModuleA"
283 , "import ModuleA"
246 ]
284 ]
247− _ <- openDoc' "ModuleA.hs" "haskell" contentA
285+ _ <- createDoc "ModuleA.hs" "haskell" contentA
248− _ <- openDoc' "ModuleB.hs" "haskell" contentB
286+ _ <- createDoc "ModuleB.hs" "haskell" contentB
249 expectDiagnostics
287 expectDiagnostics
250 [ ( "ModuleA.hs"
288 [ ( "ModuleA.hs"
251 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
@@ -266,9 +304,9 @@ diagnosticTests = testGroup "diagnostics"
266 let contentBboot = T.unlines
304 let contentBboot = T.unlines
267 [ "module ModuleB where"
305 [ "module ModuleB where"
268 ]
306 ]
269− _ <- openDoc' "ModuleA.hs" "haskell" contentA
307+ _ <- createDoc "ModuleA.hs" "haskell" contentA
270− _ <- openDoc' "ModuleB.hs" "haskell" contentB
308+ _ <- createDoc "ModuleB.hs" "haskell" contentB
271− _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
309+ _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
272 expectDiagnostics []
310 expectDiagnostics []
273 , testSessionWait "correct reference used with hs-boot" $ do
311 , testSessionWait "correct reference used with hs-boot" $ do
274 let contentB = T.unlines
312 let contentB = T.unlines
@@ -290,10 +328,10 @@ diagnosticTests = testGroup "diagnostics"
290 -- resolved to the hs-boot file
328 -- resolved to the hs-boot file
291 , "y = x"
329 , "y = x"
292 ]
330 ]
293− _ <- openDoc' "ModuleB.hs" "haskell" contentB
331+ _ <- createDoc "ModuleB.hs" "haskell" contentB
294− _ <- openDoc' "ModuleA.hs" "haskell" contentA
332+ _ <- createDoc "ModuleA.hs" "haskell" contentA
295− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
333+ _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot
296− _ <- openDoc' "ModuleC.hs" "haskell" contentC
334+ _ <- createDoc "ModuleC.hs" "haskell" contentC
297 expectDiagnostics []
335 expectDiagnostics []
298 , testSessionWait "redundant import" $ do
336 , testSessionWait "redundant import" $ do
299 let contentA = T.unlines ["module ModuleA where"]
337 let contentA = T.unlines ["module ModuleA where"]
@@ -302,8 +340,8 @@ diagnosticTests = testGroup "diagnostics"
302 , "module ModuleB where"
340 , "module ModuleB where"
303 , "import ModuleA"
341 , "import ModuleA"
304 ]
342 ]
305− _ <- openDoc' "ModuleA.hs" "haskell" contentA
343+ _ <- createDoc "ModuleA.hs" "haskell" contentA
306− _ <- openDoc' "ModuleB.hs" "haskell" contentB
344+ _ <- createDoc "ModuleB.hs" "haskell" contentB
307 expectDiagnostics
345 expectDiagnostics
308 [ ( "ModuleB.hs"
346 [ ( "ModuleB.hs"
309 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
@@ -325,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"
325 , "wrong1 = ThisList.map"
363 , "wrong1 = ThisList.map"
326 , "wrong2 = BaseList.x"
364 , "wrong2 = BaseList.x"
327 ]
365 ]
328− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent
366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
329− _ <- openDoc' "Main.hs" "haskell" mainContent
367+ _ <- createDoc "Main.hs" "haskell" mainContent
330 expectDiagnostics
368 expectDiagnostics
331 [ ( "Main.hs"
369 [ ( "Main.hs"
332 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
@@ -341,7 +379,7 @@ diagnosticTests = testGroup "diagnostics"
341 , "foo :: Ord a => a -> Int"
379 , "foo :: Ord a => a -> Int"
342 , "foo a = 1"
380 , "foo a = 1"
343 ]
381 ]
344− _ <- openDoc' "Foo.hs" "haskell" fooContent
382+ _ <- createDoc "Foo.hs" "haskell" fooContent
345 expectDiagnostics
383 expectDiagnostics
346 [ ( "Foo.hs"
384 [ ( "Foo.hs"
347 -- The test is to make sure that warnings contain unqualified names
385 -- The test is to make sure that warnings contain unqualified names
@@ -366,18 +404,18 @@ diagnosticTests = testGroup "diagnostics"
366 Just pathB <- pure $ uriToFilePath uriB
404 Just pathB <- pure $ uriToFilePath uriB
367 uriB <- pure $
405 uriB <- pure $
368 let (drive, suffix) = splitDrive pathB
406 let (drive, suffix) = splitDrive pathB
369− in filePathToUri (joinDrive (map toLower drive ) suffix)
407+ in filePathToUri (joinDrive (lower drive) suffix)
370 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
408 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
371 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
409 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
372 uriA <- getDocUri "A/A.hs"
410 uriA <- getDocUri "A/A.hs"
373 Just pathA <- pure $ uriToFilePath uriA
411 Just pathA <- pure $ uriToFilePath uriA
374 uriA <- pure $
412 uriA <- pure $
375 let (drive, suffix) = splitDrive pathA
413 let (drive, suffix) = splitDrive pathA
376− in filePathToUri (joinDrive (map toLower drive ) suffix)
414+ in filePathToUri (joinDrive (lower drive) suffix)
377 let itemA = TextDocumentItem uriA "haskell" 0 aContent
415 let itemA = TextDocumentItem uriA "haskell" 0 aContent
378 let a = TextDocumentIdentifier uriA
416 let a = TextDocumentIdentifier uriA
379 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
417 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
380− diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
418+ diagsNot <- skipManyTill anyMessage diagnostic
381 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
419 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
382 -- Check that if we put a lower-case drive in for A.A
420 -- Check that if we put a lower-case drive in for A.A
383 -- the diagnostics for A.B will also be lower-case.
421 -- the diagnostics for A.B will also be lower-case.
@@ -386,6 +424,38 @@ diagnosticTests = testGroup "diagnostics"
386 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
424 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
387 assertFailure ("Expected redundant import but got " <> T.unpack msg)
425 assertFailure ("Expected redundant import but got " <> T.unpack msg)
388 closeDoc a
426 closeDoc a
427+ , testSessionWait "haddock parse error" $ do
428+ let fooContent = T.unlines
429+ [ "module Foo where"
430+ , "foo :: Int"
431+ , "foo = 1 {-|-}"
432+ ]
433+ _ <- createDoc "Foo.hs" "haskell" fooContent
434+ expectDiagnostics
435+ [ ( "Foo.hs"
436+ , [(DsError, (2, 8), "Parse error on input")
437+ ]
438+ )
439+ ]
440+ , testSessionWait "strip file path" $ do
441+ let
442+ name = "Testing"
443+ content = T.unlines
444+ [ "module " <> name <> " where"
445+ , "value :: Maybe ()"
446+ , "value = [()]"
447+ ]
448+ _ <- createDoc (T.unpack name <> ".hs") "haskell" content
449+ notification <- skipManyTill anyMessage diagnostic
450+ let
451+ offenders =
452+ Lsp.params .
453+ Lsp.diagnostics .
454+ Lens.folded .
455+ Lsp.message .
456+ Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))
457+ failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg
458+ Lens.mapMOf_ offenders failure notification
389 ]
459 ]
390
460
391codeActionTests :: TestTree
461codeActionTests :: TestTree
@@ -394,6 +464,7 @@ codeActionTests = testGroup "code actions"
394 , typeWildCardActionTests
464 , typeWildCardActionTests
395 , removeImportTests
465 , removeImportTests
396 , extendImportTests
466 , extendImportTests
467+ , suggestImportTests
397 , addExtensionTests
468 , addExtensionTests
398 , fixConstructorImportTests
469 , fixConstructorImportTests
399 , importRenameActionTests
470 , importRenameActionTests
@@ -407,6 +478,33 @@ codeLensesTests = testGroup "code lenses"
407 [ addSigLensesTests
478 [ addSigLensesTests
408 ]
479 ]
409
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+ ]
507+
410renameActionTests :: TestTree
508renameActionTests :: TestTree
411renameActionTests = testGroup "rename actions"
509renameActionTests = testGroup "rename actions"
412 [ testSession "change to local variable name" $ do
510 [ testSession "change to local variable name" $ do
@@ -415,7 +513,7 @@ renameActionTests = testGroup "rename actions"
415 , "foo :: Int -> Int"
513 , "foo :: Int -> Int"
416 , "foo argName = argNme"
514 , "foo argName = argNme"
417 ]
515 ]
418− doc <- openDoc' "Testing.hs" "haskell" content
516+ doc <- createDoc "Testing.hs" "haskell" content
419 _ <- waitForDiagnostics
517 _ <- waitForDiagnostics
420 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
518 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"
421 executeCodeAction action
519 executeCodeAction action
@@ -433,7 +531,7 @@ renameActionTests = testGroup "rename actions"
433 , "foo :: Maybe a -> [a]"
531 , "foo :: Maybe a -> [a]"
434 , "foo = maybToList"
532 , "foo = maybToList"
435 ]
533 ]
436− doc <- openDoc' "Testing.hs" "haskell" content
534+ doc <- createDoc "Testing.hs" "haskell" content
437 _ <- waitForDiagnostics
535 _ <- waitForDiagnostics
438 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
536 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"
439 executeCodeAction action
537 executeCodeAction action
@@ -451,7 +549,7 @@ renameActionTests = testGroup "rename actions"
451 , "foo :: Char -> Char -> Char -> Char"
549 , "foo :: Char -> Char -> Char -> Char"
452 , "foo argument1 argument2 argument3 = argumentX"
550 , "foo argument1 argument2 argument3 = argumentX"
453 ]
551 ]
454− doc <- openDoc' "Testing.hs" "haskell" content
552+ doc <- createDoc "Testing.hs" "haskell" content
455 _ <- waitForDiagnostics
553 _ <- waitForDiagnostics
456 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
554 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
457 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
555 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
@@ -463,7 +561,7 @@ renameActionTests = testGroup "rename actions"
463 , "monus x y = max 0 (x - y)"
561 , "monus x y = max 0 (x - y)"
464 , "foo x y = x `monnus` y"
562 , "foo x y = x `monnus` y"
465 ]
563 ]
466− doc <- openDoc' "Testing.hs" "haskell" content
564+ doc <- createDoc "Testing.hs" "haskell" content
467 _ <- waitForDiagnostics
565 _ <- waitForDiagnostics
468 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
469 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
567 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]
@@ -486,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
486 , "func :: _"
584 , "func :: _"
487 , "func x = x"
585 , "func x = x"
488 ]
586 ]
489− doc <- openDoc' "Testing.hs" "haskell" content
587+ doc <- createDoc "Testing.hs" "haskell" content
490 _ <- waitForDiagnostics
588 _ <- waitForDiagnostics
491 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
492 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -506,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
506 , "func :: _"
604 , "func :: _"
507 , "func x y = x + y"
605 , "func x y = x + y"
508 ]
606 ]
509− doc <- openDoc' "Testing.hs" "haskell" content
607+ doc <- createDoc "Testing.hs" "haskell" content
510 _ <- waitForDiagnostics
608 _ <- waitForDiagnostics
511 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
512 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -529,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
529 , " y = x * 2"
627 , " y = x * 2"
530 , " in y"
628 , " in y"
531 ]
629 ]
532− doc <- openDoc' "Testing.hs" "haskell" content
630+ doc <- createDoc "Testing.hs" "haskell" content
533 _ <- waitForDiagnostics
631 _ <- waitForDiagnostics
534 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
535 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -554,7 +652,7 @@ removeImportTests = testGroup "remove import actions"
554 let contentA = T.unlines
652 let contentA = T.unlines
555 [ "module ModuleA where"
653 [ "module ModuleA where"
556 ]
654 ]
557− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
558 let contentB = T.unlines
656 let contentB = T.unlines
559 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
560 , "module ModuleB where"
658 , "module ModuleB where"
@@ -562,7 +660,7 @@ removeImportTests = testGroup "remove import actions"
562 , "stuffB :: Integer"
660 , "stuffB :: Integer"
563 , "stuffB = 123"
661 , "stuffB = 123"
564 ]
662 ]
565− docB <- openDoc' "ModuleB.hs" "haskell" contentB
663+ docB <- createDoc "ModuleB.hs" "haskell" contentB
566 _ <- waitForDiagnostics
664 _ <- waitForDiagnostics
567 [CACodeAction action@CodeAction { _title = actionTitle }]
665 [CACodeAction action@CodeAction { _title = actionTitle }]
568 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -580,7 +678,7 @@ removeImportTests = testGroup "remove import actions"
580 let contentA = T.unlines
678 let contentA = T.unlines
581 [ "module ModuleA where"
679 [ "module ModuleA where"
582 ]
680 ]
583− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
584 let contentB = T.unlines
682 let contentB = T.unlines
585 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
586 , "module ModuleB where"
684 , "module ModuleB where"
@@ -588,7 +686,7 @@ removeImportTests = testGroup "remove import actions"
588 , "stuffB :: Integer"
686 , "stuffB :: Integer"
589 , "stuffB = 123"
687 , "stuffB = 123"
590 ]
688 ]
591− docB <- openDoc' "ModuleB.hs" "haskell" contentB
689+ docB <- createDoc "ModuleB.hs" "haskell" contentB
592 _ <- waitForDiagnostics
690 _ <- waitForDiagnostics
593 [CACodeAction action@CodeAction { _title = actionTitle }]
691 [CACodeAction action@CodeAction { _title = actionTitle }]
594 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -610,14 +708,14 @@ removeImportTests = testGroup "remove import actions"
610 , "stuffB = 123"
708 , "stuffB = 123"
611 , "stuffC = ()"
709 , "stuffC = ()"
612 ]
710 ]
613− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
614 let contentB = T.unlines
712 let contentB = T.unlines
615 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
713 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
616 , "module ModuleB where"
714 , "module ModuleB where"
617 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
715 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
618 , "main = print stuffB"
716 , "main = print stuffB"
619 ]
717 ]
620− docB <- openDoc' "ModuleB.hs" "haskell" contentB
718+ docB <- createDoc "ModuleB.hs" "haskell" contentB
621 _ <- waitForDiagnostics
719 _ <- waitForDiagnostics
622 [CACodeAction action@CodeAction { _title = actionTitle }]
720 [CACodeAction action@CodeAction { _title = actionTitle }]
623 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
721 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -631,29 +729,26 @@ removeImportTests = testGroup "remove import actions"
631 , "main = print stuffB"
729 , "main = print stuffB"
632 ]
730 ]
633 liftIO $ expectedContentAfterAction @=? contentAfterAction
731 liftIO $ expectedContentAfterAction @=? contentAfterAction
634− , testSession "redundant symbol binding" $ do
732+ , testSession "redundant operator" $ do
635 let contentA = T.unlines
733 let contentA = T.unlines
636 [ "module ModuleA where"
734 [ "module ModuleA where"
637 , "a !! b = a"
735 , "a !! b = a"
736+ , "a <?> b = a"
638 , "stuffB :: Integer"
737 , "stuffB :: Integer"
639 , "stuffB = 123"
738 , "stuffB = 123"
640 ]
739 ]
641− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
642 let contentB = T.unlines
741 let contentB = T.unlines
643 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
742 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
644 , "module ModuleB where"
743 , "module ModuleB where"
645− , "import qualified ModuleA as A ((!!), stuffB, (!!))"
744+ , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
646 , "main = print A.stuffB"
745 , "main = print A.stuffB"
647 ]
746 ]
648− docB <- openDoc' "ModuleB.hs" "haskell" contentB
747+ docB <- createDoc "ModuleB.hs" "haskell" contentB
649 _ <- waitForDiagnostics
748 _ <- waitForDiagnostics
650 [CACodeAction action@CodeAction { _title = actionTitle }]
749 [CACodeAction action@CodeAction { _title = actionTitle }]
651 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
750 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
652−#if MIN_GHC_API_VERSION(8,6,0)
653− liftIO $ "Remove !! from import" @=? actionTitle
654−#else
655− liftIO $ "Remove A.!! from import" @=? actionTitle
751+ liftIO $ "Remove !!, <?> from import" @=? actionTitle
656−#endif
657 executeCodeAction action
752 executeCodeAction action
658 contentAfterAction <- documentContents docB
753 contentAfterAction <- documentContents docB
659 let expectedContentAfterAction = T.unlines
754 let expectedContentAfterAction = T.unlines
@@ -663,21 +758,21 @@ removeImportTests = testGroup "remove import actions"
663 , "main = print A.stuffB"
758 , "main = print A.stuffB"
664 ]
759 ]
665 liftIO $ expectedContentAfterAction @=? contentAfterAction
760 liftIO $ expectedContentAfterAction @=? contentAfterAction
666− , (`xfail` "known broken (#299)") $ testSession "redundant hierarchical import" $ do
761+ , testSession "redundant all import" $ do
667 let contentA = T.unlines
762 let contentA = T.unlines
668 [ "module ModuleA where"
763 [ "module ModuleA where"
669 , "data A = A"
764 , "data A = A"
670 , "stuffB :: Integer"
765 , "stuffB :: Integer"
671 , "stuffB = 123"
766 , "stuffB = 123"
672 ]
767 ]
673− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
674 let contentB = T.unlines
769 let contentB = T.unlines
675 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
770 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
676 , "module ModuleB where"
771 , "module ModuleB where"
677 , "import ModuleA (A(..), stuffB)"
772 , "import ModuleA (A(..), stuffB)"
678 , "main = print stuffB"
773 , "main = print stuffB"
679 ]
774 ]
680− docB <- openDoc' "ModuleB.hs" "haskell" contentB
775+ docB <- createDoc "ModuleB.hs" "haskell" contentB
681 _ <- waitForDiagnostics
776 _ <- waitForDiagnostics
682 [CACodeAction action@CodeAction { _title = actionTitle }]
777 [CACodeAction action@CodeAction { _title = actionTitle }]
683 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
778 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -691,6 +786,33 @@ removeImportTests = testGroup "remove import actions"
691 , "main = print stuffB"
786 , "main = print stuffB"
692 ]
787 ]
693 liftIO $ expectedContentAfterAction @=? contentAfterAction
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
694 ]
816 ]
695
817
696extendImportTests :: TestTree
818extendImportTests :: TestTree
@@ -715,6 +837,26 @@ extendImportTests = testGroup "extend import actions"
715 , "import ModuleA as A (stuffA, stuffB)"
837 , "import ModuleA as A (stuffA, stuffB)"
716 , "main = print (stuffA, stuffB)"
838 , "main = print (stuffA, stuffB)"
717 ])
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+ ])
718 , testSession "extend single line import with type" $ template
860 , testSession "extend single line import with type" $ template
719 (T.unlines
861 (T.unlines
720 [ "module ModuleA where"
862 [ "module ModuleA where"
@@ -798,8 +940,8 @@ extendImportTests = testGroup "extend import actions"
798 ]
940 ]
799 where
941 where
800 template contentA contentB range expectedAction expectedContentB = do
942 template contentA contentB range expectedAction expectedContentB = do
801− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
802− docB <- openDoc' "ModuleB.hs" "haskell" contentB
944+ docB <- createDoc "ModuleB.hs" "haskell" contentB
803 _ <- waitForDiagnostics
945 _ <- waitForDiagnostics
804 CACodeAction action@CodeAction { _title = actionTitle } : _
946 CACodeAction action@CodeAction { _title = actionTitle } : _
805 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
947 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -809,6 +951,61 @@ extendImportTests = testGroup "extend import actions"
809 contentAfterAction <- documentContents docB
951 contentAfterAction <- documentContents docB
810 liftIO $ expectedContentB @=? contentAfterAction
952 liftIO $ expectedContentB @=? contentAfterAction
811
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+
812addExtensionTests :: TestTree
1009addExtensionTests :: TestTree
813addExtensionTests = testGroup "add language extension actions"
1010addExtensionTests = testGroup "add language extension actions"
814 [ testSession "add NamedFieldPuns language extension" $ template
1011 [ testSession "add NamedFieldPuns language extension" $ template
@@ -854,7 +1051,7 @@ addExtensionTests = testGroup "add language extension actions"
854 ]
1051 ]
855 where
1052 where
856 template initialContent range expectedAction expectedContents = do
1053 template initialContent range expectedAction expectedContents = do
857− doc <- openDoc' "Module.hs" "haskell" initialContent
1054+ doc <- createDoc "Module.hs" "haskell" initialContent
858 _ <- waitForDiagnostics
1055 _ <- waitForDiagnostics
859 CACodeAction action@CodeAction { _title = actionTitle } : _
1056 CACodeAction action@CodeAction { _title = actionTitle } : _
860 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1057 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -877,7 +1074,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
877 [""
1074 [""
878 ,"someOtherCode = ()"
1075 ,"someOtherCode = ()"
879 ]
1076 ]
880− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
881 _ <- waitForDiagnostics
1078 _ <- waitForDiagnostics
882 CACodeAction action@CodeAction { _title = actionTitle } : _
1079 CACodeAction action@CodeAction { _title = actionTitle } : _
883 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1080 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -901,7 +1098,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
901 [""
1098 [""
902 ,"someOtherCode = ()"
1099 ,"someOtherCode = ()"
903 ]
1100 ]
904− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
905 _ <- waitForDiagnostics
1102 _ <- waitForDiagnostics
906 CACodeAction action@CodeAction { _title = actionTitle } : _
1103 CACodeAction action@CodeAction { _title = actionTitle } : _
907 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1104 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -940,8 +1137,8 @@ fixConstructorImportTests = testGroup "fix import actions"
940 ]
1137 ]
941 where
1138 where
942 template contentA contentB range expectedAction expectedContentB = do
1139 template contentA contentB range expectedAction expectedContentB = do
943− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
944− docB <- openDoc' "ModuleB.hs" "haskell" contentB
1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB
945 _diags <- waitForDiagnostics
1142 _diags <- waitForDiagnostics
946 CACodeAction action@CodeAction { _title = actionTitle } : _
1143 CACodeAction action@CodeAction { _title = actionTitle } : _
947 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1144 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -960,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"
960 [ "module Testing where"
1157 [ "module Testing where"
961 , "import Data.Mape"
1158 , "import Data.Mape"
962 ]
1159 ]
963− doc <- openDoc' "Testing.hs" "haskell" content
1160+ doc <- createDoc "Testing.hs" "haskell" content
964 _ <- waitForDiagnostics
1161 _ <- waitForDiagnostics
965 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
1162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
966 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
1163 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]
@@ -997,10 +1194,10 @@ fillTypedHoleTests = let
997 newA newB newC = testSession (T.unpack actionTitle) $ do
1194 newA newB newC = testSession (T.unpack actionTitle) $ do
998 let originalCode = sourceCode oldA oldB oldC
1195 let originalCode = sourceCode oldA oldB oldC
999 let expectedCode = sourceCode newA newB newC
1196 let expectedCode = sourceCode newA newB newC
1000− doc <- openDoc' "Testing.hs" "haskell" originalCode
1197+ doc <- createDoc "Testing.hs" "haskell" originalCode
1001 _ <- waitForDiagnostics
1198 _ <- waitForDiagnostics
1002 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
1199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
1003− let chosenAction = pickActionWithTitle actionTitle actionsOrCommands
1200+ chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
1004 executeCodeAction chosenAction
1201 executeCodeAction chosenAction
1005 modifiedCode <- documentContents doc
1202 modifiedCode <- documentContents doc
1006 liftIO $ expectedCode @=? modifiedCode
1203 liftIO $ expectedCode @=? modifiedCode
@@ -1037,36 +1234,37 @@ fillTypedHoleTests = let
1037
1234
1038addSigActionTests :: TestTree
1235addSigActionTests :: TestTree
1039addSigActionTests = let
1236addSigActionTests = let
1040− header = "{-# OPTIONS_GHC -Wmissing-signatures #-}"
1237+ header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"
1041− moduleH = "module Sigs where"
1238+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
1042 before def = T.unlines [header, moduleH, def]
1239 before def = T.unlines [header, moduleH, def]
1043 after' def sig = T.unlines [header, moduleH, sig, def]
1240 after' def sig = T.unlines [header, moduleH, sig, def]
1044
1241
1045 def >:: sig = testSession (T.unpack def) $ do
1242 def >:: sig = testSession (T.unpack def) $ do
1046 let originalCode = before def
1243 let originalCode = before def
1047 let expectedCode = after' def sig
1244 let expectedCode = after' def sig
1048− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode
1049 _ <- waitForDiagnostics
1246 _ <- waitForDiagnostics
1050 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
1247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
1051− let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
1248+ chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
1052 executeCodeAction chosenAction
1249 executeCodeAction chosenAction
1053 modifiedCode <- documentContents doc
1250 modifiedCode <- documentContents doc
1054 liftIO $ expectedCode @=? modifiedCode
1251 liftIO $ expectedCode @=? modifiedCode
1055 in
1252 in
1056 testGroup "add signature"
1253 testGroup "add signature"
1057− [ "abc = True" >:: "abc :: Bool"
1254+ [ "abc = True" >:: "abc :: Bool"
1058− , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
1255+ , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
1059− , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"
1256+ , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"
1060− , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
1257+ , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
1061− , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
1258+ , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
1062− , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"
1259+ , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"
1260+ , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"
1063 ]
1261 ]
1064
1262
1065addSigLensesTests :: TestTree
1263addSigLensesTests :: TestTree
1066addSigLensesTests = let
1264addSigLensesTests = let
1067− missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wunused-matches #-}"
1265+ missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"
1068 notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"
1266 notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"
1069− moduleH = "module Sigs where"
1267+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
1070 other = T.unlines ["f :: Integer -> Integer", "f x = 3"]
1268 other = T.unlines ["f :: Integer -> Integer", "f x = 3"]
1071 before withMissing def
1269 before withMissing def
1072 = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]
1270 = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]
@@ -1076,49 +1274,41 @@ addSigLensesTests = let
1076 sigSession withMissing def sig = testSession (T.unpack def) $ do
1274 sigSession withMissing def sig = testSession (T.unpack def) $ do
1077 let originalCode = before withMissing def
1275 let originalCode = before withMissing def
1078 let expectedCode = after' withMissing def sig
1276 let expectedCode = after' withMissing def sig
1079− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode
1080 [CodeLens {_command = Just c}] <- getCodeLenses doc
1278 [CodeLens {_command = Just c}] <- getCodeLenses doc
1081 executeCommand c
1279 executeCommand c
1082 modifiedCode <- getDocumentEdit doc
1280 modifiedCode <- getDocumentEdit doc
1083 liftIO $ expectedCode @=? modifiedCode
1281 liftIO $ expectedCode @=? modifiedCode
1084 in
1282 in
1085 testGroup "add signature"
1283 testGroup "add signature"
1086− [ testGroup "with warnings enabled"
1284+ [ testGroup title
1087− [ sigSession True "abc = True" "abc :: Bool"
1285+ [ sigSession enableWarnings "abc = True" "abc :: Bool"
1088− , sigSession True "foo a b = a + b" "foo :: Num a => a -> a -> a"
1286+ , sigSession enableWarnings "foo a b = a + b" "foo :: Num a => a -> a -> a"
1089− , sigSession True "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"
1287+ , sigSession enableWarnings "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"
1090− , sigSession True "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
1288+ , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
1091− , sigSession True "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
1289+ , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
1092− , sigSession True "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"
1290+ , sigSession enableWarnings "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"
1093− ]
1291+ , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a"
1094− , testGroup "with warnings disabled"
1095− [ sigSession False "abc = True" "abc :: Bool"
1096− , sigSession False "foo a b = a + b" "foo :: Num a => a -> a -> a"
1097− , sigSession False "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"
1098− , sigSession False "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
1099− , sigSession False "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
1100− , sigSession False "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"
1101 ]
1292 ]
1293+ | (title, enableWarnings) <-
1294+ [("with warnings enabled", True)
1295+ ,("with warnings disabled", False)
1296+ ]
1102 ]
1297 ]
1103
1298
1104−findDefinitionAndHoverTests :: TestTree
1105−findDefinitionAndHoverTests = let
1106−
1107− tst (get, check) pos targetRange title = testSession title $ do
1108− doc <- openTestDataDoc sourceFilePath
1109− found <- get doc pos
1110− check found targetRange
1111−
1112− checkDefs :: [Location] -> [Expect] -> Session ()
1299+checkDefs :: [Location] -> Session [Expect] -> Session ()
1113− checkDefs defs expectations = traverse_ check expectations where
1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
1114
1301
1115− check (ExpectRange expectedRange) = do
1302+ check (ExpectRange expectedRange) = do
1116− assertNDefinitionsFound 1 defs
1303+ assertNDefinitionsFound 1 defs
1117− assertRangeCorrect (head defs) expectedRange
1304+ assertRangeCorrect (head defs) expectedRange
1305+ check (ExpectLocation expectedLocation) = do
1306+ assertNDefinitionsFound 1 defs
1307+ liftIO $ head defs @?= expectedLocation
1118− check ExpectNoDefinitions = do
1308+ check ExpectNoDefinitions = do
1119− assertNDefinitionsFound 0 defs
1309+ assertNDefinitionsFound 0 defs
1120− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1310+ check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
1121− check _ = pure () -- all other expectations not relevant to getDefinition
1311+ check _ = pure () -- all other expectations not relevant to getDefinition
1122
1312
1123 assertNDefinitionsFound :: Int -> [a] -> Session ()
1313 assertNDefinitionsFound :: Int -> [a] -> Session ()
1124 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
1314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
@@ -1126,8 +1316,19 @@ findDefinitionAndHoverTests = let
1126 assertRangeCorrect Location{_range = foundRange} expectedRange =
1316 assertRangeCorrect Location{_range = foundRange} expectedRange =
1127 liftIO $ expectedRange @=? foundRange
1317 liftIO $ expectedRange @=? foundRange
1128
1318
1319+
1320+findDefinitionAndHoverTests :: TestTree
1321+findDefinitionAndHoverTests = let
1322+
1323+ tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do
1324+ doc <- openTestDataDoc (dir </> sourceFilePath)
1325+ found <- get doc pos
1326+ check found targetRange
1327+
1328+
1329+
1129− checkHover :: Maybe Hover -> [Expect] -> Session ()
1330+ checkHover :: Maybe Hover -> Session [Expect] -> Session ()
1130− checkHover hover expectations = traverse_ check expectations where
1331+ checkHover hover expectations = traverse_ check =<< expectations where
1131
1332
1132 check expected =
1333 check expected =
1133 case hover of
1334 case hover of
@@ -1170,9 +1371,12 @@ findDefinitionAndHoverTests = let
1170
1371
1171 mkFindTests tests = testGroup "get"
1372 mkFindTests tests = testGroup "get"
1172 [ testGroup "definition" $ mapMaybe fst tests
1373 [ testGroup "definition" $ mapMaybe fst tests
1173− , testGroup "hover" $ mapMaybe snd tests ]
1374+ , testGroup "hover" $ mapMaybe snd tests
1375+ , checkFileCompiles sourceFilePath ]
1174
1376
1175− test runDef runHover look expect title =
1377+ test runDef runHover look expect = testM runDef runHover look (return expect)
1378+
1379+ testM runDef runHover look expect title =
1176 ( runDef $ tst def look expect title
1380 ( runDef $ tst def look expect title
1177 , runHover $ tst hover look expect title ) where
1381 , runHover $ tst hover look expect title ) where
1178 def = (getDefinitions, checkDefs)
1382 def = (getDefinitions, checkDefs)
@@ -1180,87 +1384,100 @@ findDefinitionAndHoverTests = let
1180 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
1384 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
1181
1385
1182 -- search locations expectations on results
1386 -- search locations expectations on results
1183− fffL4 = _start fffR ; fffR = mkRange 4 4 4 7 ; fff = [ExpectRange fffR]
1387+ fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR]
1184− fffL8 = Position 8 4 ;
1388+ fffL8 = Position 12 4 ;
1185− fffL14 = Position 14 7 ;
1389+ fffL14 = Position 18 7 ;
1186− aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]
1390+ aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]
1187− dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]
1391+ dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]
1188− dcL12 = Position 12 11 ;
1392+ dcL12 = Position 16 11 ;
1189− xtcL5 = Position 5 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
1393+ xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]
1190− tcL6 = Position 6 11 ; tcData = [mkR 3 0 5 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:4:1"]]
1394+ tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]]
1191− vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]
1395+ vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6]
1192− opL16 = Position 16 15 ; op = [mkR 17 2 17 4]
1396+ opL16 = Position 20 15 ; op = [mkR 21 2 21 4]
1193− opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]
1397+ opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]
1194− aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]
1398+ aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]
1195− b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]
1399+ b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]
1196− xvL20 = Position 20 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
1400+ xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]
1197− clL23 = Position 23 11 ; cls = [mkR 21 0 22 20, ExpectHoverText ["MyClass", "GotoHover.hs:22:1"]]
1401+ clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]]
1198− clL25 = Position 25 9
1402+ clL25 = Position 29 9
1199− eclL15 = Position 15 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
1403+ eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]
1200− dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]
1404+ dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21]
1201− dnbL30 = Position 30 23
1405+ dnbL30 = Position 34 23
1202− lcbL33 = Position 33 26 ; lcb = [ExpectHoverText [":: Char"], mkR 33 26 33 27]
1406+ lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27]
1203− lclL33 = Position 33 22
1407+ lclL33 = Position 37 22
1204− mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14]
1408+ mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14]
1205− mclL37 = Position 37 1
1409+ mclL37 = Position 41 1
1206− spaceL37 = Position 37 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1410+ spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1207− docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1411+ docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1208 ; constr = [ExpectHoverText ["Monad m"]]
1412 ; constr = [ExpectHoverText ["Monad m"]]
1209− eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1413+ eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1210− intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]]
1414+ intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]]
1211− tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1415+ tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1212− intL41 = Position 41 20 ; litI = [ExpectHoverText ["7518"]]
1416+ intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]]
1213− chrL36 = Position 37 24 ; litC = [ExpectHoverText ["'f'"]]
1417+ chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]]
1214− txtL8 = Position 8 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1418+ txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1215− lstL43 = Position 43 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1419+ lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1216− outL45 = Position 45 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
1420+ outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
1217− innL48 = Position 48 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
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]
1218 in
1424 in
1219 mkFindTests
1425 mkFindTests
1220− -- def hover look expect
1426+ -- def hover look expect
1221− [ test yes yes fffL4 fff "field in record definition"
1427+ [ test yes yes fffL4 fff "field in record definition"
1222− , test broken broken fffL8 fff "field in record construction #71"
1428+ , test broken broken fffL8 fff "field in record construction #71"
1223− , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
1429+ , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs
1224− , test yes yes aaaL14 aaa "top-level name" -- 120
1430+ , test yes yes aaaL14 aaa "top-level name" -- 120
1225− , test yes yes dcL7 tcDC "data constructor record #247"
1431+ , test yes yes dcL7 tcDC "data constructor record #247"
1226− , test yes yes dcL12 tcDC "data constructor plain" -- 121
1432+ , test yes yes dcL12 tcDC "data constructor plain" -- 121
1227− , test yes yes tcL6 tcData "type constructor #248" -- 147
1433+ , test yes yes tcL6 tcData "type constructor #248" -- 147
1228− , test broken yes xtcL5 xtc "type constructor external #248,249"
1434+ , test broken yes xtcL5 xtc "type constructor external #248,249"
1229− , test broken yes xvL20 xvMsg "value external package #249" -- 120
1435+ , test broken yes xvL20 xvMsg "value external package #249" -- 120
1230− , test yes yes vvL16 vv "plain parameter" -- 120
1436+ , test yes yes vvL16 vv "plain parameter" -- 120
1231− , test yes yes aL18 apmp "pattern match name" -- 120
1437+ , test yes yes aL18 apmp "pattern match name" -- 120
1232− , test yes yes opL16 op "top-level operator" -- 120, 123
1438+ , test yes yes opL16 op "top-level operator" -- 120, 123
1233− , test yes yes opL18 opp "parameter operator" -- 120
1439+ , test yes yes opL18 opp "parameter operator" -- 120
1234− , test yes yes b'L19 bp "name in backticks" -- 120
1440+ , test yes yes b'L19 bp "name in backticks" -- 120
1235− , test yes yes clL23 cls "class in instance declaration #250"
1441+ , test yes yes clL23 cls "class in instance declaration #250"
1236− , test yes yes clL25 cls "class in signature #250" -- 147
1442+ , test yes yes clL25 cls "class in signature #250" -- 147
1237− , test broken yes eclL15 ecls "external class in signature #249,250"
1443+ , test broken yes eclL15 ecls "external class in signature #249,250"
1238− , test yes yes dnbL29 dnb "do-notation bind" -- 137
1444+ , test yes yes dnbL29 dnb "do-notation bind" -- 137
1239− , test yes yes dnbL30 dnb "do-notation lookup"
1445+ , test yes yes dnbL30 dnb "do-notation lookup"
1240− , test yes yes lcbL33 lcb "listcomp bind" -- 137
1446+ , test yes yes lcbL33 lcb "listcomp bind" -- 137
1241− , test yes yes lclL33 lcb "listcomp lookup"
1447+ , test yes yes lclL33 lcb "listcomp lookup"
1242− , test yes yes mclL36 mcl "top-level fn 1st clause"
1448+ , test yes yes mclL36 mcl "top-level fn 1st clause"
1243− , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1449+ , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1244− , test yes yes spaceL37 space "top-level fn on space #315"
1450+ , test yes yes spaceL37 space "top-level fn on space #315"
1245− , test no broken docL41 doc "documentation #7"
1451+ , test no broken docL41 doc "documentation #7"
1246− , test no yes eitL40 kindE "kind of Either #273"
1452+ , test no yes eitL40 kindE "kind of Either #273"
1247− , test no yes intL40 kindI "kind of Int #273"
1453+ , test no yes intL40 kindI "kind of Int #273"
1248− , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1454+ , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1249− , test no yes intL41 litI "literal Int in hover info #274"
1455+ , test no yes intL41 litI "literal Int in hover info #274"
1250− , test no yes chrL36 litC "literal Char in hover info #274"
1456+ , test no yes chrL36 litC "literal Char in hover info #274"
1251− , test no yes txtL8 litT "literal Text in hover info #274"
1457+ , test no yes txtL8 litT "literal Text in hover info #274"
1252− , test no yes lstL43 litL "literal List in hover info #274"
1458+ , test no yes lstL43 litL "literal List in hover info #274"
1253− , test no yes docL41 constr "type constraint in hover info #283"
1459+ , test no yes docL41 constr "type constraint in hover info #283"
1254− , test broken broken outL45 outSig "top-level signature #310"
1460+ , test broken broken outL45 outSig "top-level signature #310"
1255− , test broken broken innL48 innSig "inner 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)"
1256 ]
1464 ]
1257 where yes, broken :: (TestTree -> Maybe TestTree)
1465 where yes, broken :: (TestTree -> Maybe TestTree)
1258 yes = Just -- test should run and pass
1466 yes = Just -- test should run and pass
1259 broken = Just . (`xfail` "known broken")
1467 broken = Just . (`xfail` "known broken")
1260 no = const Nothing -- don't run this test at all
1468 no = const Nothing -- don't run this test at all
1261
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+
1262pluginTests :: TestTree
1478pluginTests :: TestTree
1479+pluginTests = (`xfail8101` "known broken (#556)")
1263−pluginTests = testSessionWait "plugins" $ do
1480+ $ testSessionWait "plugins" $ do
1264 let content =
1481 let content =
1265 T.unlines
1482 T.unlines
1266 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
1483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
@@ -1274,7 +1491,7 @@ pluginTests = testSessionWait "plugins" $ do
1274 , "foo :: Int -> Int -> Int"
1491 , "foo :: Int -> Int -> Int"
1275 , "foo a b = a + c"
1492 , "foo a b = a + c"
1276 ]
1493 ]
1277− _ <- openDoc' "Testing.hs" "haskell" content
1494+ _ <- createDoc "Testing.hs" "haskell" content
1278 expectDiagnostics
1495 expectDiagnostics
1279 [ ( "Testing.hs",
1496 [ ( "Testing.hs",
1280 [(DsError, (8, 14), "Variable not in scope: c")]
1497 [(DsError, (8, 14), "Variable not in scope: c")]
@@ -1301,7 +1518,7 @@ cppTests =
1301 run $ expectError content (2, 1)
1518 run $ expectError content (2, 1)
1302 )
1519 )
1303 , testSessionWait "cpp-ghcide" $ do
1520 , testSessionWait "cpp-ghcide" $ do
1304− _ <- openDoc' "A.hs" "haskell" $ T.unlines
1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines
1305 ["{-# LANGUAGE CPP #-}"
1522 ["{-# LANGUAGE CPP #-}"
1306 ,"main ="
1523 ,"main ="
1307 ,"#ifdef __GHCIDE__"
1524 ,"#ifdef __GHCIDE__"
@@ -1315,7 +1532,7 @@ cppTests =
1315 where
1532 where
1316 expectError :: T.Text -> Cursor -> Session ()
1533 expectError :: T.Text -> Cursor -> Session ()
1317 expectError content cursor = do
1534 expectError content cursor = do
1318− _ <- openDoc' "Testing.hs" "haskell" content
1535+ _ <- createDoc "Testing.hs" "haskell" content
1319 expectDiagnostics
1536 expectDiagnostics
1320 [ ( "Testing.hs",
1537 [ ( "Testing.hs",
1321 [(DsError, cursor, "error: unterminated")]
1538 [(DsError, cursor, "error: unterminated")]
@@ -1331,13 +1548,43 @@ preprocessorTests = testSessionWait "preprocessor" $ do
1331 , "module Testing where"
1548 , "module Testing where"
1332 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic
1549 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic
1333 ]
1550 ]
1334− _ <- openDoc' "Testing.hs" "haskell" content
1551+ _ <- createDoc "Testing.hs" "haskell" content
1335 expectDiagnostics
1552 expectDiagnostics
1336 [ ( "Testing.hs",
1553 [ ( "Testing.hs",
1337 [(DsError, (2, 8), "Variable not in scope: z")]
1554 [(DsError, (2, 8), "Variable not in scope: z")]
1338 )
1555 )
1339 ]
1556 ]
1340
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+
1341thTests :: TestTree
1588thTests :: TestTree
1342thTests =
1589thTests =
1343 testGroup
1590 testGroup
@@ -1363,9 +1610,30 @@ thTests =
1363 "b :: Integer",
1610 "b :: Integer",
1364 "b = $(litE $ IntegerL $ a) + n"
1611 "b = $(litE $ IntegerL $ a) + n"
1365 ]
1612 ]
1366− _ <- openDoc' "A.hs" "haskell" sourceA
1613+ _ <- createDoc "A.hs" "haskell" sourceA
1367− _ <- openDoc' "B.hs" "haskell" sourceB
1614+ _ <- createDoc "B.hs" "haskell" sourceB
1368 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
1615 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
1616+ , testSessionWait "newtype-closure" $ do
1617+ let sourceA =
1618+ T.unlines
1619+ [ "{-# LANGUAGE DeriveDataTypeable #-}"
1620+ ,"{-# LANGUAGE TemplateHaskell #-}"
1621+ ,"module A (a) where"
1622+ ,"import Data.Data"
1623+ ,"import Language.Haskell.TH"
1624+ ,"newtype A = A () deriving (Data)"
1625+ ,"a :: ExpQ"
1626+ ,"a = [| 0 |]"]
1627+ let sourceB =
1628+ T.unlines
1629+ [ "{-# LANGUAGE TemplateHaskell #-}"
1630+ ,"module B where"
1631+ ,"import A"
1632+ ,"b :: Int"
1633+ ,"b = $( a )" ]
1634+ _ <- createDoc "A.hs" "haskell" sourceA
1635+ _ <- createDoc "B.hs" "haskell" sourceB
1636+ return ()
1369 ]
1637 ]
1370
1638
1371completionTests :: TestTree
1639completionTests :: TestTree
@@ -1373,19 +1641,19 @@ completionTests
1373 = testGroup "completion"
1641 = testGroup "completion"
1374 [ testSessionWait "variable" $ do
1642 [ testSessionWait "variable" $ do
1375 let source = T.unlines ["module A where", "f = hea"]
1643 let source = T.unlines ["module A where", "f = hea"]
1376− docId <- openDoc' "A.hs" "haskell" source
1644+ docId <- createDoc "A.hs" "haskell" source
1377 compls <- getCompletions docId (Position 1 7)
1645 compls <- getCompletions docId (Position 1 7)
1378 liftIO $ map dropDocs compls @?=
1646 liftIO $ map dropDocs compls @?=
1379 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1647 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1380 let [CompletionItem { _documentation = headDocs}] = compls
1648 let [CompletionItem { _documentation = headDocs}] = compls
1381 checkDocText "head" headDocs [ "Defined in 'Prelude'"
1649 checkDocText "head" headDocs [ "Defined in 'Prelude'"
1382−#if MIN_GHC_API_VERSION(8,6,0)
1650+#if MIN_GHC_API_VERSION(8,6,5)
1383 , "Extract the first element of a list"
1651 , "Extract the first element of a list"
1384#endif
1652#endif
1385 ]
1653 ]
1386 , testSessionWait "constructor" $ do
1654 , testSessionWait "constructor" $ do
1387 let source = T.unlines ["module A where", "f = Tru"]
1655 let source = T.unlines ["module A where", "f = Tru"]
1388− docId <- openDoc' "A.hs" "haskell" source
1656+ docId <- createDoc "A.hs" "haskell" source
1389 compls <- getCompletions docId (Position 1 7)
1657 compls <- getCompletions docId (Position 1 7)
1390 liftIO $ map dropDocs compls @?=
1658 liftIO $ map dropDocs compls @?=
1391 [ complItem "True" (Just CiConstructor) (Just "Bool")
1659 [ complItem "True" (Just CiConstructor) (Just "Bool")
@@ -1397,7 +1665,7 @@ completionTests
1397 ]
1665 ]
1398 , testSessionWait "type" $ do
1666 , testSessionWait "type" $ do
1399 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]
1667 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]
1400− docId <- openDoc' "A.hs" "haskell" source
1668+ docId <- createDoc "A.hs" "haskell" source
1401 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1669 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1402 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
1670 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]
1403 compls <- getCompletions docId (Position 2 7)
1671 compls <- getCompletions docId (Position 2 7)
@@ -1407,14 +1675,14 @@ completionTests
1407 let [ CompletionItem { _documentation = boundedDocs},
1675 let [ CompletionItem { _documentation = boundedDocs},
1408 CompletionItem { _documentation = boolDocs } ] = compls
1676 CompletionItem { _documentation = boolDocs } ] = compls
1409 checkDocText "Bounded" boundedDocs [ "Defined in 'Prelude'"
1677 checkDocText "Bounded" boundedDocs [ "Defined in 'Prelude'"
1410−#if MIN_GHC_API_VERSION(8,6,0)
1678+#if MIN_GHC_API_VERSION(8,6,5)
1411 , "name the upper and lower limits"
1679 , "name the upper and lower limits"
1412#endif
1680#endif
1413 ]
1681 ]
1414 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1682 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1415 , testSessionWait "qualified" $ do
1683 , testSessionWait "qualified" $ do
1416 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]
1684 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]
1417− docId <- openDoc' "A.hs" "haskell" source
1685+ docId <- createDoc "A.hs" "haskell" source
1418 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1686 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1419 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
1687 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]
1420 compls <- getCompletions docId (Position 2 15)
1688 compls <- getCompletions docId (Position 2 15)
@@ -1422,15 +1690,36 @@ completionTests
1422 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1690 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1423 let [CompletionItem { _documentation = headDocs}] = compls
1691 let [CompletionItem { _documentation = headDocs}] = compls
1424 checkDocText "head" headDocs [ "Defined in 'Prelude'"
1692 checkDocText "head" headDocs [ "Defined in 'Prelude'"
1425−#if MIN_GHC_API_VERSION(8,6,0)
1693+#if MIN_GHC_API_VERSION(8,6,5)
1426 , "Extract the first element of a list"
1694 , "Extract the first element of a list"
1427#endif
1695#endif
1428 ]
1696 ]
1429 , testSessionWait "keyword" $ do
1697 , testSessionWait "keyword" $ do
1430 let source = T.unlines ["module A where", "f = newty"]
1698 let source = T.unlines ["module A where", "f = newty"]
1431− docId <- openDoc' "A.hs" "haskell" source
1699+ docId <- createDoc "A.hs" "haskell" source
1432 compls <- getCompletions docId (Position 1 9)
1700 compls <- getCompletions docId (Position 1 9)
1433 liftIO $ compls @?= [keywordItem "newtype"]
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 "*")]
1434 ]
1723 ]
1435 where
1724 where
1436 dropDocs :: CompletionItem -> CompletionItem
1725 dropDocs :: CompletionItem -> CompletionItem
@@ -1438,6 +1727,7 @@ completionTests
1438 complItem label kind ty = CompletionItem
1727 complItem label kind ty = CompletionItem
1439 { _label = label
1728 { _label = label
1440 , _kind = kind
1729 , _kind = kind
1730+ , _tags = List []
1441 , _detail = (":: " <>) <$> ty
1731 , _detail = (":: " <>) <$> ty
1442 , _documentation = Nothing
1732 , _documentation = Nothing
1443 , _deprecated = Nothing
1733 , _deprecated = Nothing
@@ -1455,6 +1745,7 @@ completionTests
1455 keywordItem label = CompletionItem
1745 keywordItem label = CompletionItem
1456 { _label = label
1746 { _label = label
1457 , _kind = Just CiKeyword
1747 , _kind = Just CiKeyword
1748+ , _tags = List []
1458 , _detail = Nothing
1749 , _detail = Nothing
1459 , _documentation = Nothing
1750 , _documentation = Nothing
1460 , _deprecated = Nothing
1751 , _deprecated = Nothing
@@ -1482,7 +1773,7 @@ outlineTests = testGroup
1482 "outline"
1773 "outline"
1483 [ testSessionWait "type class" $ do
1774 [ testSessionWait "type class" $ do
1484 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]
1775 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]
1485− docId <- openDoc' "A.hs" "haskell" source
1776+ docId <- createDoc "A.hs" "haskell" source
1486 symbols <- getDocumentSymbols docId
1777 symbols <- getDocumentSymbols docId
1487 liftIO $ symbols @?= Left
1778 liftIO $ symbols @?= Left
1488 [ moduleSymbol
1779 [ moduleSymbol
@@ -1495,7 +1786,7 @@ outlineTests = testGroup
1495 ]
1786 ]
1496 , testSessionWait "type class instance " $ do
1787 , testSessionWait "type class instance " $ do
1497 let source = T.unlines ["class A a where", "instance A () where"]
1788 let source = T.unlines ["class A a where", "instance A () where"]
1498− docId <- openDoc' "A.hs" "haskell" source
1789+ docId <- createDoc "A.hs" "haskell" source
1499 symbols <- getDocumentSymbols docId
1790 symbols <- getDocumentSymbols docId
1500 liftIO $ symbols @?= Left
1791 liftIO $ symbols @?= Left
1501 [ classSymbol "A a" (R 0 0 0 15) []
1792 [ classSymbol "A a" (R 0 0 0 15) []
@@ -1503,7 +1794,7 @@ outlineTests = testGroup
1503 ]
1794 ]
1504 , testSessionWait "type family" $ do
1795 , testSessionWait "type family" $ do
1505 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1796 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1506− docId <- openDoc' "A.hs" "haskell" source
1797+ docId <- createDoc "A.hs" "haskell" source
1507 symbols <- getDocumentSymbols docId
1798 symbols <- getDocumentSymbols docId
1508 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]
1799 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]
1509 , testSessionWait "type family instance " $ do
1800 , testSessionWait "type family instance " $ do
@@ -1512,7 +1803,7 @@ outlineTests = testGroup
1512 , "type family A a"
1803 , "type family A a"
1513 , "type instance A () = ()"
1804 , "type instance A () = ()"
1514 ]
1805 ]
1515− docId <- openDoc' "A.hs" "haskell" source
1806+ docId <- createDoc "A.hs" "haskell" source
1516 symbols <- getDocumentSymbols docId
1807 symbols <- getDocumentSymbols docId
1517 liftIO $ symbols @?= Left
1808 liftIO $ symbols @?= Left
1518 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
1809 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
@@ -1520,7 +1811,7 @@ outlineTests = testGroup
1520 ]
1811 ]
1521 , testSessionWait "data family" $ do
1812 , testSessionWait "data family" $ do
1522 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1813 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1523− docId <- openDoc' "A.hs" "haskell" source
1814+ docId <- createDoc "A.hs" "haskell" source
1524 symbols <- getDocumentSymbols docId
1815 symbols <- getDocumentSymbols docId
1525 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]
1816 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]
1526 , testSessionWait "data family instance " $ do
1817 , testSessionWait "data family instance " $ do
@@ -1529,7 +1820,7 @@ outlineTests = testGroup
1529 , "data family A a"
1820 , "data family A a"
1530 , "data instance A () = A ()"
1821 , "data instance A () = A ()"
1531 ]
1822 ]
1532− docId <- openDoc' "A.hs" "haskell" source
1823+ docId <- createDoc "A.hs" "haskell" source
1533 symbols <- getDocumentSymbols docId
1824 symbols <- getDocumentSymbols docId
1534 liftIO $ symbols @?= Left
1825 liftIO $ symbols @?= Left
1535 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
1826 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
@@ -1537,36 +1828,36 @@ outlineTests = testGroup
1537 ]
1828 ]
1538 , testSessionWait "constant" $ do
1829 , testSessionWait "constant" $ do
1539 let source = T.unlines ["a = ()"]
1830 let source = T.unlines ["a = ()"]
1540− docId <- openDoc' "A.hs" "haskell" source
1831+ docId <- createDoc "A.hs" "haskell" source
1541 symbols <- getDocumentSymbols docId
1832 symbols <- getDocumentSymbols docId
1542 liftIO $ symbols @?= Left
1833 liftIO $ symbols @?= Left
1543 [docSymbol "a" SkFunction (R 0 0 0 6)]
1834 [docSymbol "a" SkFunction (R 0 0 0 6)]
1544 , testSessionWait "pattern" $ do
1835 , testSessionWait "pattern" $ do
1545 let source = T.unlines ["Just foo = Just 21"]
1836 let source = T.unlines ["Just foo = Just 21"]
1546− docId <- openDoc' "A.hs" "haskell" source
1837+ docId <- createDoc "A.hs" "haskell" source
1547 symbols <- getDocumentSymbols docId
1838 symbols <- getDocumentSymbols docId
1548 liftIO $ symbols @?= Left
1839 liftIO $ symbols @?= Left
1549 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1840 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1550 , testSessionWait "pattern with type signature" $ do
1841 , testSessionWait "pattern with type signature" $ do
1551 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1842 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1552− docId <- openDoc' "A.hs" "haskell" source
1843+ docId <- createDoc "A.hs" "haskell" source
1553 symbols <- getDocumentSymbols docId
1844 symbols <- getDocumentSymbols docId
1554 liftIO $ symbols @?= Left
1845 liftIO $ symbols @?= Left
1555 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1846 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1556 , testSessionWait "function" $ do
1847 , testSessionWait "function" $ do
1557 let source = T.unlines ["a x = ()"]
1848 let source = T.unlines ["a x = ()"]
1558− docId <- openDoc' "A.hs" "haskell" source
1849+ docId <- createDoc "A.hs" "haskell" source
1559 symbols <- getDocumentSymbols docId
1850 symbols <- getDocumentSymbols docId
1560 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1851 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1561 , testSessionWait "type synonym" $ do
1852 , testSessionWait "type synonym" $ do
1562 let source = T.unlines ["type A = Bool"]
1853 let source = T.unlines ["type A = Bool"]
1563− docId <- openDoc' "A.hs" "haskell" source
1854+ docId <- createDoc "A.hs" "haskell" source
1564 symbols <- getDocumentSymbols docId
1855 symbols <- getDocumentSymbols docId
1565 liftIO $ symbols @?= Left
1856 liftIO $ symbols @?= Left
1566 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]
1857 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]
1567 , testSessionWait "datatype" $ do
1858 , testSessionWait "datatype" $ do
1568 let source = T.unlines ["data A = C"]
1859 let source = T.unlines ["data A = C"]
1569− docId <- openDoc' "A.hs" "haskell" source
1860+ docId <- createDoc "A.hs" "haskell" source
1570 symbols <- getDocumentSymbols docId
1861 symbols <- getDocumentSymbols docId
1571 liftIO $ symbols @?= Left
1862 liftIO $ symbols @?= Left
1572 [ docSymbolWithChildren "A"
1863 [ docSymbolWithChildren "A"
@@ -1574,18 +1865,47 @@ outlineTests = testGroup
1574 (R 0 0 0 10)
1865 (R 0 0 0 10)
1575 [docSymbol "C" SkConstructor (R 0 9 0 10)]
1866 [docSymbol "C" SkConstructor (R 0 9 0 10)]
1576 ]
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+ ]
1577 , testSessionWait "import" $ do
1880 , testSessionWait "import" $ do
1578 let source = T.unlines ["import Data.Maybe"]
1881 let source = T.unlines ["import Data.Maybe"]
1579− docId <- openDoc' "A.hs" "haskell" source
1882+ docId <- createDoc "A.hs" "haskell" source
1580 symbols <- getDocumentSymbols docId
1883 symbols <- getDocumentSymbols docId
1581 liftIO $ symbols @?= Left
1884 liftIO $ symbols @?= Left
1885+ [docSymbolWithChildren "imports"
1886+ SkModule
1887+ (R 0 0 0 17)
1582− [docSymbol "import Data.Maybe" SkModule (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+ ]
1583 , testSessionWait "foreign import" $ do
1903 , testSessionWait "foreign import" $ do
1584 let source = T.unlines
1904 let source = T.unlines
1585 [ "{-# language ForeignFunctionInterface #-}"
1905 [ "{-# language ForeignFunctionInterface #-}"
1586 , "foreign import ccall \"a\" a :: Int"
1906 , "foreign import ccall \"a\" a :: Int"
1587 ]
1907 ]
1588− docId <- openDoc' "A.hs" "haskell" source
1908+ docId <- createDoc "A.hs" "haskell" source
1589 symbols <- getDocumentSymbols docId
1909 symbols <- getDocumentSymbols docId
1590 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]
1910 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]
1591 , testSessionWait "foreign export" $ do
1911 , testSessionWait "foreign export" $ do
@@ -1593,7 +1913,7 @@ outlineTests = testGroup
1593 [ "{-# language ForeignFunctionInterface #-}"
1913 [ "{-# language ForeignFunctionInterface #-}"
1594 , "foreign export ccall odd :: Int -> Bool"
1914 , "foreign export ccall odd :: Int -> Bool"
1595 ]
1915 ]
1596− docId <- openDoc' "A.hs" "haskell" source
1916+ docId <- createDoc "A.hs" "haskell" source
1597 symbols <- getDocumentSymbols docId
1917 symbols <- getDocumentSymbols docId
1598 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]
1918 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]
1599 ]
1919 ]
@@ -1606,6 +1926,8 @@ outlineTests = testGroup
1606 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1926 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1607 docSymbolWithChildren name kind loc cc =
1927 docSymbolWithChildren name kind loc cc =
1608 DocumentSymbol name Nothing kind Nothing loc loc (Just $ List 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)
1609 moduleSymbol name loc cc = DocumentSymbol name
1931 moduleSymbol name loc cc = DocumentSymbol name
1610 Nothing
1932 Nothing
1611 SkFile
1933 SkFile
@@ -1627,8 +1949,16 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')
1627xfail :: TestTree -> String -> TestTree
1949xfail :: TestTree -> String -> TestTree
1628xfail = flip expectFailBecause
1950xfail = flip expectFailBecause
1629
1951
1952+xfail8101 :: TestTree -> String -> TestTree
1953+#if MIN_GHC_API_VERSION(8,10,0)
1954+xfail8101 = flip expectFailBecause
1955+#else
1956+xfail8101 t _ = t
1957+#endif
1958+
1630data Expect
1959data Expect
1631 = ExpectRange Range -- Both gotoDef and hover should report this range
1960 = ExpectRange Range -- Both gotoDef and hover should report this range
1961+ | ExpectLocation Location
1632-- | ExpectDefRange Range -- Only gotoDef should report this range
1962-- | ExpectDefRange Range -- Only gotoDef should report this range
1633 | ExpectHoverRange Range -- Only hover should report this range
1963 | ExpectHoverRange Range -- Only hover should report this range
1634 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
1964 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
@@ -1641,6 +1971,9 @@ data Expect
1641mkR :: Int -> Int -> Int -> Int -> Expect
1971mkR :: Int -> Int -> Int -> Int -> Expect
1642mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
1972mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
1643
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+
1644haddockTests :: TestTree
1977haddockTests :: TestTree
1645haddockTests
1978haddockTests
1646 = testGroup "haddock"
1979 = testGroup "haddock"
@@ -1657,11 +1990,7 @@ haddockTests
1657 (unlines
1990 (unlines
1658 [ ""
1991 [ ""
1659 , ""
1992 , ""
1660−#if MIN_VERSION_haddock_library(1,8,0)
1661 , "However, `(+)` and `(*)` are"
1993 , "However, `(+)` and `(*)` are"
1662−#else
1663− , "However, '(+)' and '(*)' are"
1664−#endif
1665 , "customarily expected to define a ring and have the following properties: "
1994 , "customarily expected to define a ring and have the following properties: "
1666 , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`"
1995 , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`"
1667 , "+ ****Commutativity of (+)****: `x + y` = `y + x`"
1996 , "+ ****Commutativity of (+)****: `x + y` = `y + x`"
@@ -1700,6 +2029,167 @@ haddockTests
1700 where
2029 where
1701 checkHaddock s txt = spanDocToMarkdownForTest s @?= txt
2030 checkHaddock s txt = spanDocToMarkdownForTest s @?= txt
1702
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+
1703----------------------------------------------------------------------
2193----------------------------------------------------------------------
1704-- Utils
2194-- Utils
1705
2195
@@ -1707,6 +2197,12 @@ haddockTests
1707testSession :: String -> Session () -> TestTree
2197testSession :: String -> Session () -> TestTree
1708testSession name = testCase name . run
2198testSession name = testCase name . run
1709
2199
2200+testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree
2201+testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix
2202+
2203+testSession' :: String -> (FilePath -> Session ()) -> TestTree
2204+testSession' name = testCase name . run'
2205+
1710testSessionWait :: String -> Session () -> TestTree
2206testSessionWait :: String -> Session () -> TestTree
1711testSessionWait name = testSession name .
2207testSessionWait name = testSession name .
1712 -- Check that any diagnostics produced were already consumed by the test case.
2208 -- Check that any diagnostics produced were already consumed by the test case.
@@ -1717,24 +2213,53 @@ testSessionWait name = testSession name .
1717 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.
2213 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.
1718 ( >> expectNoMoreDiagnostics 0.5)
2214 ( >> expectNoMoreDiagnostics 0.5)
1719
2215
1720−pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction
2216+pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction
1721−pickActionWithTitle title actions = head
2217+pickActionWithTitle title actions = do
2218+ assertBool ("Found no matching actions: " <> show titles) (not $ null matches)
2219+ return $ head matches
2220+ where
2221+ titles =
2222+ [ actionTitle
2223+ | CACodeAction CodeAction { _title = actionTitle } <- actions
2224+ ]
2225+ matches =
1722− [ action
2226+ [ action
1723− | CACodeAction action@CodeAction{ _title = actionTitle } <- actions
2227+ | CACodeAction action@CodeAction { _title = actionTitle } <- actions
1724− , title == actionTitle ]
2228+ , title == actionTitle
2229+ ]
1725
2230
1726mkRange :: Int -> Int -> Int -> Int -> Range
2231mkRange :: Int -> Int -> Int -> Int -> Range
1727mkRange a b c d = Range (Position a b) (Position c d)
2232mkRange a b c d = Range (Position a b) (Position c d)
1728
2233
1729run :: Session a -> IO a
2234run :: Session a -> IO a
1730−run s = withTempDir $ \dir -> do
2235+run s = withTempDir $ \dir -> runInDir dir s
2236+
2237+runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a
2238+runWithExtraFiles prefix s = withTempDir $ \dir -> do
2239+ copyTestDataFiles dir prefix
2240+ runInDir dir (s dir)
2241+
2242+copyTestDataFiles :: FilePath -> FilePath -> IO ()
2243+copyTestDataFiles dir prefix = do
2244+ -- Copy all the test data files to the temporary workspace
2245+ testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]
2246+ for_ testDataFiles $ \f -> do
2247+ createDirectoryIfMissing True $ dir </> takeDirectory f
2248+ copyFile ("test/data" </> prefix </> f) (dir </> f)
2249+
2250+run' :: (FilePath -> Session a) -> IO a
2251+run' s = withTempDir $ \dir -> runInDir dir (s dir)
2252+
2253+runInDir :: FilePath -> Session a -> IO a
2254+runInDir dir s = do
1731 ghcideExe <- locateGhcideExecutable
2255 ghcideExe <- locateGhcideExecutable
1732
2256
1733 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
2257 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
1734 -- since the package import test creates "Data/List.hs", which otherwise has no physical home
2258 -- since the package import test creates "Data/List.hs", which otherwise has no physical home
1735 createDirectoryIfMissing True $ dir ++ "/Data"
2259 createDirectoryIfMissing True $ dir ++ "/Data"
1736
2260
2261+
1737− let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]
2262+ let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
1738 -- HIE calls getXgdDirectory which assumes that HOME is set.
2263 -- HIE calls getXgdDirectory which assumes that HOME is set.
1739 -- Only sets HOME if it wasn't already set.
2264 -- Only sets HOME if it wasn't already set.
1740 setEnv "HOME" "/homeless-shelter" False
2265 setEnv "HOME" "/homeless-shelter" False
@@ -1751,7 +2276,7 @@ run s = withTempDir $ \dir -> do
1751openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
2276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
1752openTestDataDoc path = do
2277openTestDataDoc path = do
1753 source <- liftIO $ readFileUtf8 $ "test/data" </> path
2278 source <- liftIO $ readFileUtf8 $ "test/data" </> path
1754− openDoc' path "haskell" source
2279+ createDoc path "haskell" source
1755
2280
1756findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
2281findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
1757findCodeActions doc range expectedTitles = do
2282findCodeActions doc range expectedTitles = do
@@ -1766,7 +2291,7 @@ findCodeActions doc range expectedTitles = do
1766 [ actionTitle
2291 [ actionTitle
1767 | CACodeAction CodeAction { _title = actionTitle } <- actions
2292 | CACodeAction CodeAction { _title = actionTitle } <- actions
1768 ]
2293 ]
1769− ++ "is not a superset of "
2294+ ++ " is not a superset of "
1770 ++ show expectedTitles
2295 ++ show expectedTitles
1771 liftIO $ case matches of
2296 liftIO $ case matches of
1772 Nothing -> assertFailure msg
2297 Nothing -> assertFailure msg
@@ -1779,13 +2304,193 @@ findCodeAction doc range t = head <$> findCodeActions doc range [t]
1779unitTests :: TestTree
2304unitTests :: TestTree
1780unitTests = do
2305unitTests = do
1781 testGroup "Unit"
2306 testGroup "Unit"
1782− [ testCase "empty file path" $
2307+ [ testCase "empty file path does NOT work with the empty String literal" $
1783− uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just ""
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 ""
1784 ]
2318 ]
1785
2319
1786−-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events
2320+positionMappingTests :: TestTree
1787−openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
2321+positionMappingTests =
1788−openDoc' fp name contents = do
2322+ testGroup "position mapping"
1789− res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents
2323+ [ testGroup "toCurrent"
1790− sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])
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)
1791− return res
2492+ return
2493+ [ args
2494+ | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs
2495+ , Registration _id WorkspaceDidChangeWatchedFiles args <- regs
2496+ ]
test/src/Development/IDE/Test.hs+8−2
@@ -1,10 +1,13 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4+{-# LANGUAGE DuplicateRecordFields #-}
5+
4module Development.IDE.Test
6module Development.IDE.Test
5 ( Cursor
7 ( Cursor
6 , cursorPosition
8 , cursorPosition
7 , requireDiagnostic
9 , requireDiagnostic
10+ , diagnostic
8 , expectDiagnostics
11 , expectDiagnostics
9 , expectNoMoreDiagnostics
12 , expectNoMoreDiagnostics
10 ) where
13 ) where
@@ -15,7 +18,7 @@ import Control.Monad
15import Control.Monad.IO.Class
18import Control.Monad.IO.Class
16import qualified Data.Map.Strict as Map
19import qualified Data.Map.Strict as Map
17import qualified Data.Text as T
20import qualified Data.Text as T
18−import Language.Haskell.LSP.Test hiding (message, openDoc')
21+import Language.Haskell.LSP.Test hiding (message)
19import qualified Language.Haskell.LSP.Test as LspTest
22import qualified Language.Haskell.LSP.Test as LspTest
20import Language.Haskell.LSP.Types
23import Language.Haskell.LSP.Types
21import Language.Haskell.LSP.Types.Lens as Lsp
24import Language.Haskell.LSP.Types.Lens as Lsp
@@ -77,7 +80,7 @@ expectDiagnostics expected = do
77 go m
80 go m
78 | Map.null m = pure ()
81 | Map.null m = pure ()
79 | otherwise = do
82 | otherwise = do
80− diagsNot <- skipManyTill anyMessage LspTest.message :: Session PublishDiagnosticsNotification
83+ diagsNot <- skipManyTill anyMessage diagnostic
81 let fileUri = diagsNot ^. params . uri
84 let fileUri = diagsNot ^. params . uri
82 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of
85 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of
83 Nothing -> do
86 Nothing -> do
@@ -96,6 +99,9 @@ expectDiagnostics expected = do
96 " but got " <> show actual
99 " but got " <> show actual
97 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m
100 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m
98
101
102+diagnostic :: Session PublishDiagnosticsNotification
103+diagnostic = LspTest.message
104+
99standardizeQuotes :: T.Text -> T.Text
105standardizeQuotes :: T.Text -> T.Text
100standardizeQuotes msg = let
106standardizeQuotes msg = let
101 repl '‘' = '\''
107 repl '‘' = '\''