git.iko.soy/ghcide
on master help sign in
swap
5a754e1126 ahead, 0 behind
.azure/linux-stack.ymlnew file+63
since splitsnapshots
unifiedsplit
@@ -0,0 +1,63 @@
1+jobs:
2+- job: ghcide_stack_linux
3+ timeoutInMinutes: 60
4+ pool:
5+ vmImage: 'ubuntu-latest'
6+ strategy:
7+ matrix:
8+ stack_810:
9+ STACK_YAML: "stack810.yaml"
10+ stack_88:
11+ STACK_YAML: "stack88.yaml"
12+ stack_86:
13+ STACK_YAML: "stack.yaml"
14+ stack_84:
15+ STACK_YAML: "stack84.yaml"
16+ stack_ghc_lib_88:
17+ STACK_YAML: "stack-ghc-lib.yaml"
18+ steps:
19+ - checkout: self
20+ - task: Cache@2
21+ inputs:
22+ key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/$(STACK_YAML) | $(Build.SourcesDirectory)/ghcide.cabal
23+ path: .azure-cache
24+ cacheHitVar: CACHE_RESTORED
25+ displayName: "Cache stack artifacts"
26+ - bash: |
27+ mkdir -p ~/.stack
28+ tar xzf .azure-cache/stack-root.tar.gz -C $HOME
29+ displayName: "Unpack cache"
30+ condition: eq(variables.CACHE_RESTORED, 'true')
31+ - bash: |
32+ ./fmt.sh
33+ displayName: "HLint via ./fmt.sh"
34+ - bash: |
35+ sudo add-apt-repository ppa:hvr/ghc
36+ sudo apt-get update
37+ sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev cabal-install-3.2
38+ if ! which stack >/dev/null 2>&1; then
39+ curl -sSL https://get.haskellstack.org/ | sh
40+ fi
41+ displayName: 'Install Stack'
42+ - bash: stack setup --stack-yaml=$STACK_YAML
43+ displayName: 'stack setup'
44+ - bash: stack build --only-dependencies --stack-yaml=$STACK_YAML
45+ displayName: 'stack build --only-dependencies'
46+ - bash: |
47+ export PATH=/opt/cabal/bin:$PATH
48+ stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML || stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML|| stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML
49+ # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.
50+ displayName: 'stack test --ghc-options=-Werror'
51+ - bash: |
52+ mkdir -p .azure-cache
53+ tar czf .azure-cache/stack-root.tar.gz -C $HOME .stack
54+ displayName: "Pack cache"
55+ - bash: |
56+ set -euo pipefail
57+ MESSAGE=$(git log --pretty=format:%s -n1)
58+ curl -XPOST \
59+ -i \
60+ -H 'Content-type: application/json' \
61+ --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \
62+ $(Slack.URL)
63+ condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))
.azure/windows-stack.ymlnew file+68
@@ -0,0 +1,68 @@
1+jobs:
2+- job: ghcide_stack_windows
3+ timeoutInMinutes: 60
4+ pool:
5+ vmImage: 'windows-2019'
6+ strategy:
7+ matrix:
8+ stack_810:
9+ STACK_YAML: "stack810.yaml"
10+ stack_88:
11+ STACK_YAML: "stack88.yaml"
12+ stack_86:
13+ STACK_YAML: "stack.yaml"
14+ stack_84:
15+ STACK_YAML: "stack84.yaml"
16+ stack_ghc_lib_88:
17+ STACK_YAML: "stack-ghc-lib.yaml"
18+ variables:
19+ STACK_ROOT: "C:\\sr"
20+ steps:
21+ - checkout: self
22+ - task: Cache@2
23+ inputs:
24+ key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/$(STACK_YAML) | $(Build.SourcesDirectory)/ghcide.cabal
25+ path: .azure-cache
26+ cacheHitVar: CACHE_RESTORED
27+ displayName: "Cache stack artifacts"
28+ - bash: |
29+ mkdir -p $STACK_ROOT
30+ tar -vxzf .azure-cache/stack-root.tar.gz -C /c
31+ mkdir -p .stack-work
32+ tar -vxzf .azure-cache/stack-work.tar.gz
33+ displayName: "Unpack cache"
34+ condition: eq(variables.CACHE_RESTORED, 'true')
35+ - bash: |
36+ ./fmt.sh
37+ displayName: "HLint via ./fmt.sh"
38+ - bash: |
39+ curl -sSkL http://www.stackage.org/stack/windows-x86_64 -o /usr/bin/stack.zip
40+ unzip -o /usr/bin/stack.zip -d /usr/bin/
41+ mkdir -p "$STACK_ROOT"
42+ displayName: 'Install Stack'
43+ - bash: stack setup --stack-yaml $STACK_YAML
44+ displayName: 'stack setup'
45+ - bash: |
46+ # Installing happy and alex standalone to avoid error "strip.exe: unable to rename ../*.exe; reason: File exists"
47+ stack install happy --stack-yaml $STACK_YAML
48+ stack install alex --stack-yaml $STACK_YAML
49+ stack install cabal-install --stack-yaml $STACK_YAML
50+ stack build --only-dependencies --stack-yaml $STACK_YAML
51+ displayName: 'stack build --only-dependencies'
52+ - bash: stack test --no-run-tests --ghc-options=-Werror --stack-yaml $STACK_YAML
53+ displayName: 'stack test --ghc-options=-Werror'
54+ # TODO: run test suite when failing tests are fixed or marked as broken. See https://github.com/digital-asset/ghcide/issues/474
55+ - bash: |
56+ mkdir -p .azure-cache
57+ tar -vczf .azure-cache/stack-root.tar.gz $(cygpath $STACK_ROOT)
58+ tar -vczf .azure-cache/stack-work.tar.gz .stack-work
59+ displayName: "Pack cache"
60+ - bash: |
61+ set -euo pipefail
62+ MESSAGE=$(git log --pretty=format:%s -n1)
63+ curl -XPOST \
64+ -i \
65+ -H 'Content-type: application/json' \
66+ --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \
67+ $(Slack.URL)
68+ condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))
.editorconfignew file+11
@@ -0,0 +1,11 @@
1+; This file is for unifying the coding style for different editors and IDEs.
2+; More information at https://EditorConfig.org
3+
4+root = true
5+
6+[*]
7+end_of_line = LF
8+indent_style = space
9+indent_size = 4
10+trim_trailing_whitespace = true
11+insert_final_newline = true
.ghcideleted−24
@@ -1,24 +0,0 @@
1−:set -Wunused-binds -Wunused-imports -Worphans -Wunused-matches -Wincomplete-patterns
2−
3−:set -XBangPatterns
4−:set -XDeriveFunctor
5−:set -XDeriveGeneric
6−:set -XGeneralizedNewtypeDeriving
7−:set -XLambdaCase
8−:set -XNamedFieldPuns
9−:set -XOverloadedStrings
10−:set -XRecordWildCards
11−:set -XScopedTypeVariables
12−:set -XStandaloneDeriving
13−:set -XTupleSections
14−:set -XTypeApplications
15−:set -XViewPatterns
16−
17−:set -package=ghc
18−:set -hide-package=ghc-lib-parser
19−:set -DGHC_STABLE
20−:set -Iinclude
21−:set -isrc
22−:set -iexe
23−
24−:load Main
.gitignore+4
@@ -4,3 +4,7 @@ dist-newstyle/
4cabal.project.local
4cabal.project.local
5*~
5*~
6*.lock
6*.lock
7+/.tasty-rerun-log
8+.vscode
9+/.hlint-*
10+bench/example
.hlint.yaml+10−3
@@ -73,19 +73,23 @@
73 - {name: ViewPatterns, within: []}
73 - {name: ViewPatterns, within: []}
74
74
75 # Shady extensions
75 # Shady extensions
76− - {name: ImplicitParams, within: []}
77 - name: CPP
76 - name: CPP
78 within:
77 within:
79− - Development.IDE.Core.Completions
78+ - Development.IDE.Compat
80 - Development.IDE.Core.FileStore
79 - Development.IDE.Core.FileStore
81 - Development.IDE.Core.Compile
80 - Development.IDE.Core.Compile
81+ - Development.IDE.Core.Rules
82 - Development.IDE.GHC.Compat
82 - Development.IDE.GHC.Compat
83+ - Development.IDE.GHC.Orphans
83 - Development.IDE.GHC.Util
84 - Development.IDE.GHC.Util
84 - Development.IDE.Import.FindImports
85 - Development.IDE.Import.FindImports
85− - Development.IDE.LSP.CodeAction
86+ - Development.IDE.LSP.Outline
86 - Development.IDE.Spans.Calculate
87 - Development.IDE.Spans.Calculate
87 - Development.IDE.Spans.Documentation
88 - Development.IDE.Spans.Documentation
88 - Development.IDE.Spans.Common
89 - Development.IDE.Spans.Common
90+ - Development.IDE.Plugin.CodeAction
91+ - Development.IDE.Plugin.Completions
92+ - Development.IDE.Plugin.Completions.Logic
89 - Main
93 - Main
90
94
91- flags:
95- flags:
@@ -97,9 +101,12 @@
97# - {name: Control.Arrow, within: []} # Certain modules are banned entirely
101# - {name: Control.Arrow, within: []} # Certain modules are banned entirely
98#
102#
99- functions:
103- functions:
104+ # Things that are unsafe in Haskell base library
100 - {name: unsafeInterleaveIO, within: []}
105 - {name: unsafeInterleaveIO, within: []}
101 - {name: unsafeDupablePerformIO, within: []}
106 - {name: unsafeDupablePerformIO, within: []}
102 - {name: unsafeCoerce, within: []}
107 - {name: unsafeCoerce, within: []}
108+ # Things that are a bit dangerous in the GHC API
109+ - {name: nameModule, within: []}
103
110
104# Add custom hints for this project
111# Add custom hints for this project
105#
112#
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+546−79
@@ -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
@@ -28,31 +40,42 @@ import Development.IDE.Types.Diagnostics
28import Development.IDE.Types.Options
40import Development.IDE.Types.Options
29import Development.IDE.Types.Logger
41import Development.IDE.Types.Logger
30import Development.IDE.GHC.Util
42import Development.IDE.GHC.Util
31−import qualified Data.Text as T
43+import Development.IDE.Plugin
44+import Development.IDE.Plugin.Completions as Completions
45+import Development.IDE.Plugin.CodeAction as CodeAction
32−import qualified Data.Text.IO as T
46+import qualified Language.Haskell.LSP.Core as LSP
33import Language.Haskell.LSP.Messages
47import Language.Haskell.LSP.Messages
34−import Language.Haskell.LSP.Types (LspId(IdInt))
48+import Language.Haskell.LSP.Types
35−import Linker
36−import Data.Version
49+import Data.Aeson (ToJSON(toJSON))
37import Development.IDE.LSP.LanguageServer
50import Development.IDE.LSP.LanguageServer
38−import System.Directory.Extra as IO
51+import qualified System.Directory.Extra as IO
39import System.Environment
52import System.Environment
40import System.IO
53import System.IO
41import 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)
42import Paths_ghcide
59import Paths_ghcide
43import Development.GitRev
60import Development.GitRev
44import Development.Shake (Action, action)
61import Development.Shake (Action, action)
45−import qualified Data.Set as Set
62+import qualified Data.HashSet as HashSet
63+import qualified Data.HashMap.Strict as HM
46import qualified Data.Map.Strict as Map
64import qualified Data.Map.Strict as Map
47−
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)
48import GHC hiding (def)
71import GHC hiding (def)
49−import qualified GHC.Paths
72+import GHC.Check ( VersionCheck(..), makeGhcVersionChecker )
73+import Data.Either.Extra
50
74
51−import HIE.Bios
75+import HIE.Bios.Cradle
76+import HIE.Bios.Types
52
77
53−-- Set the GHC libdir to the nix libdir if it's present.
78+import Utils
54−getLibdir :: IO FilePath
55−getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
56
79
57ghcideVersion :: IO String
80ghcideVersion :: IO String
58ghcideVersion = do
81ghcideVersion = do
@@ -79,66 +102,68 @@ main = do
79 let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
102 let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $
80 T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
103 T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg
81
104
82− whenJust argsCwd setCurrentDirectory
105+ whenJust argsCwd IO.setCurrentDirectory
83
106
84− dir <- getCurrentDirectory
107+ dir <- IO.getCurrentDirectory
108+ command <- makeLspCommandId "typesignature.add"
109+
110+ let plugins = Completions.plugin <> CodeAction.plugin
111+ onInitialConfiguration = const $ Right ()
112+ onConfigurationChange = const $ Right ()
113+ options = def { LSP.executeCommandCommands = Just [command]
114+ , LSP.completionTriggerCharacters = Just "."
115+ }
85
116
86 if argLSP then do
117 if argLSP then do
87 t <- offsetTime
118 t <- offsetTime
88 hPutStrLn stderr "Starting LSP server..."
119 hPutStrLn stderr "Starting LSP server..."
89− hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcidie WITHOUT the --lsp option!"
120+ hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
90− runLanguageServer def def $ \getLspId event vfs caps -> do
121+ runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do
91 t <- t
122 t <- t
92 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
123 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
93− -- very important we only call loadSession once, and it's fast, so just do it before starting
94− session <- loadSession dir
95− let options = (defaultIdeOptions $ return session)
124+ let options = (defaultIdeOptions $ loadSessionShake dir)
96 { optReportProgress = clientSupportsProgress caps
125 { optReportProgress = clientSupportsProgress caps
97 , optShakeProfiling = argsShakeProfiling
126 , optShakeProfiling = argsShakeProfiling
127+ , optTesting = argsTesting
128+ , optThreads = argsThreads
98 }
129 }
130+ debouncer <- newAsyncDebouncer
131+ initialise caps (mainRule >> pluginRules plugins >> action kick)
99− initialise caps (mainRule >> action kick) getLspId event (logger minBound) options vfs
132+ getLspId event (logger minBound) debouncer options vfs
100 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+
101 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
138 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
102 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
139 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
103
140
104− putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir
141+ putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir
105− 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
106 putStrLn $ "Found " ++ show (length files) ++ " files"
145 putStrLn $ "Found " ++ show (length files) ++ " files"
107
146
108− 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"
109 cradles <- mapM findCradle files
148 cradles <- mapM findCradle files
110 let ucradles = nubOrd cradles
149 let ucradles = nubOrd cradles
111 let n = length ucradles
150 let n = length ucradles
112 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
151 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
113− sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do
114− let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x
115− putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg
116− cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x
117− when (isNothing x) $ print cradle
118− putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"
119− cradleToSession cradle
120−
121− putStrLn "\nStep 5/6: Initializing the IDE"
152+ putStrLn "\nStep 3/4: Initializing the IDE"
122 vfs <- makeVFSHandle
153 vfs <- makeVFSHandle
123− let cradlesToSessions = Map.fromList $ zip ucradles sessions
154+ debouncer <- newAsyncDebouncer
124− let filesToCradles = Map.fromList $ zip files cradles
125− let grab file = fromMaybe (head sessions) $ do
126− cradle <- Map.lookup file filesToCradles
127− Map.lookup cradle cradlesToSessions
128− ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) (defaultIdeOptions $ return $ return . grab) vfs
155+ ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs
129−
156+
130− putStrLn "\nStep 6/6: Type checking the files"
157+ putStrLn "\nStep 4/4: Type checking the files"
131− setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files
158+ setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
132− results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files
159+ results <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath' files)
133 let (worked, failed) = partition fst $ zip (map isJust results) files
160 let (worked, failed) = partition fst $ zip (map isJust results) files
134 when (failed /= []) $
161 when (failed /= []) $
135 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
162 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
136
163
137 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"
138 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
165 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
139−
166+ return ()
140− unless (null failed) exitFailure
141−
142
167
143expandFiles :: [FilePath] -> IO [FilePath]
168expandFiles :: [FilePath] -> IO [FilePath]
144expandFiles = concatMapM $ \x -> do
169expandFiles = concatMapM $ \x -> do
@@ -147,7 +172,7 @@ expandFiles = concatMapM $ \x -> do
147 let recurse "." = True
172 let recurse "." = True
148 recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
173 recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc
149 recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
174 recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories
150− 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
151 when (null files) $
176 when (null files) $
152 fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
177 fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
153 return files
178 return files
@@ -156,48 +181,414 @@ expandFiles = concatMapM $ \x -> do
156kick :: Action ()
181kick :: Action ()
157kick = do
182kick = do
158 files <- getFilesOfInterest
183 files <- getFilesOfInterest
159− void $ uses TypeCheck $ Set.toList files
184+ void $ uses TypeCheck $ HashSet.toList files
160
185
161-- | Print an LSP event.
186-- | Print an LSP event.
162showEvent :: Lock -> FromServerMessage -> IO ()
187showEvent :: Lock -> FromServerMessage -> IO ()
163showEvent _ (EventFileDiagnostics _ []) = return ()
188showEvent _ (EventFileDiagnostics _ []) = return ()
164−showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
189+showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =
165 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
190 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
166showEvent lock e = withLock lock $ print e
191showEvent lock e = withLock lock $ print e
167
192
168
193
169−cradleToSession :: Cradle -> IO HscEnvEq
194+-- | Run the specific cradle on a specific FilePath via hie-bios.
170−cradleToSession cradle = do
195+cradleToSessionOpts :: Cradle a -> FilePath -> IO (Either [CradleError] ComponentOptions)
171− cradleRes <- getCompilerOptions "" cradle
196+cradleToSessionOpts cradle file = do
197+ let showLine s = putStrLn ("> " ++ s)
198+ cradleRes <- runCradle (cradleOptsProg cradle) showLine file
172− opts <- case cradleRes of
199+ case cradleRes of
173− CradleSuccess r -> pure r
200+ CradleSuccess r -> pure (Right r)
174− CradleFail err -> throwIO err
201+ CradleFail err -> return (Left [err])
175− -- 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
176− -- That will require some more changes.
203+ -- message about the fact that the file is being ignored.
177− CradleNone -> fail "'none' cradle is not yet supported"
204+ CradleNone -> return (Left [])
205+
206+emptyHscEnv :: IO HscEnv
207+emptyHscEnv = do
178 libdir <- getLibdir
208 libdir <- getLibdir
179− env <- runGhc (Just libdir) $ do
209+ env <- runGhc (Just libdir) getSession
180− _targets <- initSession opts
181− getSession
182 initDynLinker env
210 initDynLinker env
183− 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
184
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)
185
403
186−loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq)
187−loadSession dir = do
188− cradleLoc <- memoIO $ \v -> do
189− res <- findCradle v
190− -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
191− -- try and normalise that
192− -- e.g. see https://github.com/digital-asset/ghcide/issues/126
193− res' <- traverse makeAbsolute res
194− return $ normalise <$> res'
195− session <- memoIO $ \file -> do
196− c <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file
197− cradleToSession c
198− return $ \file -> liftIO $ session =<< cradleLoc file
199
404
200
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+
201-- | Memoize an IO function, with the characteristics:
592-- | Memoize an IO function, with the characteristics:
202--
593--
203-- * 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.
@@ -214,3 +605,79 @@ memoIO op = do
214 res <- onceFork $ op k
605 res <- onceFork $ op k
215 return (Map.insert k res mp, res)
606 return (Map.insert k res mp, res)
216 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+120−23
@@ -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,51 +109,66 @@ library
99 include-dirs:
109 include-dirs:
100 include
110 include
101 exposed-modules:
111 exposed-modules:
102− Development.IDE.Core.Completions
112+ Development.IDE.Compat
103− Development.IDE.Core.CompletionsTypes
113+ Development.IDE.Core.Debouncer
104 Development.IDE.Core.FileStore
114 Development.IDE.Core.FileStore
115+ Development.IDE.Core.IdeConfiguration
105 Development.IDE.Core.OfInterest
116 Development.IDE.Core.OfInterest
106 Development.IDE.Core.PositionMapping
117 Development.IDE.Core.PositionMapping
107 Development.IDE.Core.Rules
118 Development.IDE.Core.Rules
108 Development.IDE.Core.RuleTypes
119 Development.IDE.Core.RuleTypes
109 Development.IDE.Core.Service
120 Development.IDE.Core.Service
110 Development.IDE.Core.Shake
121 Development.IDE.Core.Shake
122+ Development.IDE.GHC.Error
111 Development.IDE.GHC.Util
123 Development.IDE.GHC.Util
112 Development.IDE.Import.DependencyInformation
124 Development.IDE.Import.DependencyInformation
125+ Development.IDE.LSP.HoverDefinition
113 Development.IDE.LSP.LanguageServer
126 Development.IDE.LSP.LanguageServer
127+ Development.IDE.LSP.Outline
114 Development.IDE.LSP.Protocol
128 Development.IDE.LSP.Protocol
115 Development.IDE.LSP.Server
129 Development.IDE.LSP.Server
130+ Development.IDE.Spans.Common
116 Development.IDE.Types.Diagnostics
131 Development.IDE.Types.Diagnostics
117 Development.IDE.Types.Location
132 Development.IDE.Types.Location
118 Development.IDE.Types.Logger
133 Development.IDE.Types.Logger
119 Development.IDE.Types.Options
134 Development.IDE.Types.Options
135+ Development.IDE.Plugin
136+ Development.IDE.Plugin.Completions
137+ Development.IDE.Plugin.CodeAction
120 other-modules:
138 other-modules:
121− Development.IDE.Core.Debouncer
122 Development.IDE.Core.Compile
139 Development.IDE.Core.Compile
123 Development.IDE.Core.Preprocessor
140 Development.IDE.Core.Preprocessor
124 Development.IDE.Core.FileExists
141 Development.IDE.Core.FileExists
125 Development.IDE.GHC.Compat
142 Development.IDE.GHC.Compat
126 Development.IDE.GHC.CPP
143 Development.IDE.GHC.CPP
127− Development.IDE.GHC.Error
128 Development.IDE.GHC.Orphans
144 Development.IDE.GHC.Orphans
129 Development.IDE.GHC.Warnings
145 Development.IDE.GHC.Warnings
146+ Development.IDE.GHC.WithDynFlags
130 Development.IDE.Import.FindImports
147 Development.IDE.Import.FindImports
131− Development.IDE.LSP.CodeAction
132− Development.IDE.LSP.Completions
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.Common
139 Development.IDE.Spans.Documentation
151 Development.IDE.Spans.Documentation
140 Development.IDE.Spans.Type
152 Development.IDE.Spans.Type
153+ Development.IDE.Plugin.CodeAction.PositionIndexed
154+ Development.IDE.Plugin.CodeAction.Rules
155+ Development.IDE.Plugin.CodeAction.RuleTypes
156+ Development.IDE.Plugin.Completions.Logic
157+ Development.IDE.Plugin.Completions.Types
158+ if (impl(ghc > 8.7) && impl(ghc < 8.10)) || flag(ghc-lib)
159+ hs-source-dirs: src-ghc88
160+ other-modules:
161+ Development.IDE.GHC.HieAst
162+ if (impl(ghc > 8.9))
163+ hs-source-dirs: src-ghc810
164+ other-modules:
165+ Development.IDE.GHC.HieAst
141 ghc-options: -Wall -Wno-name-shadowing
166 ghc-options: -Wall -Wno-name-shadowing
142
167
143executable ghcide-test-preprocessor
168executable ghcide-test-preprocessor
144 default-language: Haskell2010
169 default-language: Haskell2010
145 hs-source-dirs: test/preprocessor
170 hs-source-dirs: test/preprocessor
146− ghc-options: -Wall
171+ ghc-options: -Wall -Wno-name-shadowing
147 main-is: Main.hs
172 main-is: Main.hs
148 build-depends:
173 build-depends:
149 base == 4.*
174 base == 4.*
@@ -165,29 +190,52 @@ executable ghcide
165 "-with-rtsopts=-I0 -qg -A128M"
190 "-with-rtsopts=-I0 -qg -A128M"
166 main-is: Main.hs
191 main-is: Main.hs
167 build-depends:
192 build-depends:
193+ time,
194+ async,
168 hslogger,
195 hslogger,
196+ aeson,
169 base == 4.*,
197 base == 4.*,
198+ binary,
199+ base16-bytestring >=0.1.1 && <0.2,
200+ bytestring,
170 containers,
201 containers,
202+ cryptohash-sha1 >=0.11.100 && <0.12,
171 data-default,
203 data-default,
204+ deepseq,
172 directory,
205 directory,
173 extra,
206 extra,
174 filepath,
207 filepath,
208+ ghc-check >= 0.3.0.1 && < 0.4,
175 ghc-paths,
209 ghc-paths,
176 ghc,
210 ghc,
177 gitrev,
211 gitrev,
212+ hashable,
178 haskell-lsp,
213 haskell-lsp,
214+ haskell-lsp-types,
179− hie-bios >= 0.3.2 && < 0.4,
215+ hie-bios >= 0.5.0 && < 0.6,
180 ghcide,
216 ghcide,
181 optparse-applicative,
217 optparse-applicative,
182 shake,
218 shake,
183− text
219+ text,
220+ unordered-containers
184 other-modules:
221 other-modules:
222+ Utils
185 Arguments
223 Arguments
186 Paths_ghcide
224 Paths_ghcide
187
225
188 default-extensions:
226 default-extensions:
227+ BangPatterns
228+ DeriveFunctor
229+ DeriveGeneric
230+ GeneralizedNewtypeDeriving
231+ LambdaCase
232+ NamedFieldPuns
233+ OverloadedStrings
189 RecordWildCards
234 RecordWildCards
235+ ScopedTypeVariables
236+ StandaloneDeriving
190 TupleSections
237 TupleSections
238+ TypeApplications
191 ViewPatterns
239 ViewPatterns
192
240
193test-suite ghcide-tests
241test-suite ghcide-tests
@@ -216,13 +264,22 @@ test-suite ghcide-tests
216 --------------------------------------------------------------
264 --------------------------------------------------------------
217 ghcide,
265 ghcide,
218 ghc-typelits-knownnat,
266 ghc-typelits-knownnat,
267+ haddock-library,
268+ haskell-lsp,
219 haskell-lsp-types,
269 haskell-lsp-types,
270+ network-uri,
220 lens,
271 lens,
221− lsp-test >= 0.8,
272+ lsp-test >= 0.11.0.1 && < 0.12,
222 parser-combinators,
273 parser-combinators,
274+ QuickCheck,
275+ quickcheck-instances,
276+ rope-utf16-splay,
277+ shake,
223 tasty,
278 tasty,
224− tasty-hunit,
225 tasty-expected-failure,
279 tasty-expected-failure,
280+ tasty-hunit,
281+ tasty-quickcheck,
282+ tasty-rerun,
226 text
283 text
227 hs-source-dirs: test/cabal test/exe test/src
284 hs-source-dirs: test/cabal test/exe test/src
228 include-dirs: include
285 include-dirs: include
@@ -245,3 +302,43 @@ test-suite ghcide-tests
245 TupleSections
302 TupleSections
246 TypeApplications
303 TypeApplications
247 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+306−104
@@ -9,6 +9,7 @@
9-- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.
9-- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.
10module Development.IDE.Core.Compile
10module Development.IDE.Core.Compile
11 ( TcModuleResult(..)
11 ( TcModuleResult(..)
12+ , RunSimplifier(..)
12 , compileModule
13 , compileModule
13 , parseModule
14 , parseModule
14 , typecheckModule
15 , typecheckModule
@@ -16,10 +17,18 @@ module Development.IDE.Core.Compile
16 , addRelativeImport
17 , addRelativeImport
17 , mkTcModuleResult
18 , mkTcModuleResult
18 , generateByteCode
19 , generateByteCode
20+ , generateAndWriteHieFile
21+ , generateAndWriteHiFile
22+ , getModSummaryFromImports
23+ , loadHieFile
24+ , loadInterface
25+ , loadDepModule
26+ , loadModuleHome
19 ) where
27 ) where
20
28
21import Development.IDE.Core.RuleTypes
29import Development.IDE.Core.RuleTypes
22import Development.IDE.Core.Preprocessor
30import Development.IDE.Core.Preprocessor
31+import Development.IDE.Core.Shake
23import Development.IDE.GHC.Error
32import Development.IDE.GHC.Error
24import Development.IDE.GHC.Warnings
33import Development.IDE.GHC.Warnings
25import Development.IDE.Types.Diagnostics
34import Development.IDE.Types.Diagnostics
@@ -28,6 +37,7 @@ import Development.IDE.GHC.Util
28import qualified GHC.LanguageExtensions.Type as GHC
37import qualified GHC.LanguageExtensions.Type as GHC
29import Development.IDE.Types.Options
38import Development.IDE.Types.Options
30import Development.IDE.Types.Location
39import Development.IDE.Types.Location
40+import Outputable
31
41
32#if MIN_GHC_API_VERSION(8,6,0)
42#if MIN_GHC_API_VERSION(8,6,0)
33import DynamicLoading (initializePlugins)
43import DynamicLoading (initializePlugins)
@@ -36,42 +46,60 @@ import DynamicLoading (initializePlugins)
36import GHC hiding (parseModule, typecheckModule)
46import GHC hiding (parseModule, typecheckModule)
37import qualified Parser
47import qualified Parser
38import Lexer
48import Lexer
49+#if MIN_GHC_API_VERSION(8,10,0)
50+#else
39import ErrUtils
51import ErrUtils
52+#endif
40
53
41−import qualified GHC
54+import Finder
55+import qualified Development.IDE.GHC.Compat as GHC
56+import qualified Development.IDE.GHC.Compat as Compat
42import GhcMonad
57import GhcMonad
43import GhcPlugins as GHC hiding (fst3, (<>))
58import GhcPlugins as GHC hiding (fst3, (<>))
44import qualified HeaderInfo as Hdr
59import qualified HeaderInfo as Hdr
45−import HscMain (hscInteractive)
60+import HscMain (hscInteractive, hscSimplify)
61+import LoadIface (readIface)
62+import qualified Maybes
46import MkIface
63import MkIface
64+import NameCache
47import StringBuffer as SB
65import StringBuffer as SB
66+import TcRnMonad (initIfaceLoad, tcg_th_coreplugins)
67+import TcIface (typecheckIface)
48import TidyPgm
68import TidyPgm
49
69
70+import Control.Exception.Safe
50import Control.Monad.Extra
71import Control.Monad.Extra
51import Control.Monad.Except
72import Control.Monad.Except
52import Control.Monad.Trans.Except
73import Control.Monad.Trans.Except
53−import Data.Function
74+import Data.Bifunctor (first, second)
54−import Data.Ord
55import qualified Data.Text as T
75import qualified Data.Text as T
56import Data.IORef
76import Data.IORef
57import Data.List.Extra
77import Data.List.Extra
58import Data.Maybe
78import Data.Maybe
59−import Data.Tuple.Extra
60import qualified Data.Map.Strict as Map
79import qualified Data.Map.Strict as Map
61import System.FilePath
80import System.FilePath
81+import System.Directory
82+import System.IO.Extra
83+import Data.Either.Extra (maybeToEither)
84+import Control.DeepSeq (rnf)
85+import Control.Exception (evaluate)
86+import Exception (ExceptionMonad)
62
87
63
88
64−-- | Given a string buffer, return a pre-processed @ParsedModule@.
89+-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
65parseModule
90parseModule
66 :: IdeOptions
91 :: IdeOptions
67 -> HscEnv
92 -> HscEnv
93+ -> [PackageName]
68 -> FilePath
94 -> FilePath
69 -> Maybe SB.StringBuffer
95 -> Maybe SB.StringBuffer
70− -> IO ([FileDiagnostic], Maybe ParsedModule)
96+ -> IO (IdeResult (StringBuffer, ParsedModule))
71−parseModule IdeOptions{..} env file =
97+parseModule IdeOptions{..} env comp_pkgs filename mbContents =
72− fmap (either (, Nothing) (second Just)) .
98+ fmap (either (, Nothing) id) $
73− -- We need packages since imports fail to resolve otherwise.
99+ evalGhcEnv env $ runExceptT $ do
100+ (contents, dflags) <- preprocessor filename mbContents
74− runGhcEnv env . runExceptT . parseFileContents optPreprocessor file
101+ (diag, modu) <- parseFileContents optPreprocessor dflags comp_pkgs filename contents
102+ return (diag, Just (contents, modu))
75
103
76
104
77-- | Given a package identifier, what packages does it depend on
105-- | Given a package identifier, what packages does it depend on
@@ -82,34 +110,39 @@ computePackageDeps
82computePackageDeps env pkg = do
110computePackageDeps env pkg = do
83 let dflags = hsc_dflags env
111 let dflags = hsc_dflags env
84 case lookupInstalledPackage dflags pkg of
112 case lookupInstalledPackage dflags pkg of
85− Nothing -> return $ Left [ideErrorText (toNormalizedFilePath noFilePath) $
113+ Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $
86 T.pack $ "unknown package: " ++ show pkg]
114 T.pack $ "unknown package: " ++ show pkg]
87 Just pkgInfo -> return $ Right $ depends pkgInfo
115 Just pkgInfo -> return $ Right $ depends pkgInfo
88
116
89−
90−-- | Typecheck a single module using the supplied dependencies and packages.
91−typecheckModule
92− :: IdeDefer
117+typecheckModule :: IdeDefer
93− -> HscEnv
118+ -> HscEnv
94− -> [TcModuleResult]
119+ -> [(ModSummary, (ModIface, Maybe Linkable))]
95− -> ParsedModule
120+ -> ParsedModule
96− -> IO ([FileDiagnostic], Maybe TcModuleResult)
121+ -> IO (IdeResult (HscEnv, TcModuleResult))
97−typecheckModule (IdeDefer defer) packageState deps pm =
122+typecheckModule (IdeDefer defer) hsc depsIn pm = do
98− let demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
99− in
100− fmap (either (, Nothing) (second Just)) $
123+ fmap (either (, Nothing) (second Just . sequence) . sequence) $
101− runGhcEnv packageState $
124+ runGhcEnv hsc $
102− catchSrcErrors "typecheck" $ do
125+ catchSrcErrors "typecheck" $ do
103− setupEnv deps
126+ -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.
127+ -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.
128+ -- Long-term we might just want to change the order returned by GetDependencies
129+ let deps = reverse depsIn
130+
131+ setupFinderCache (map fst deps)
132+
104− let modSummary = pm_mod_summary pm
133+ let modSummary = pm_mod_summary pm
105− dflags = ms_hspp_opts modSummary
134+ dflags = ms_hspp_opts modSummary
135+
136+ mapM_ (uncurry loadDepModule . snd) deps
106− modSummary' <- initPlugins modSummary
137+ modSummary' <- initPlugins modSummary
107− (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
138+ (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
108− GHC.typecheckModule $ enableTopLevelWarnings
139+ GHC.typecheckModule $ enableTopLevelWarnings
109− $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
140+ $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
110− tcm2 <- mkTcModuleResult tcm
141+ tcm2 <- mkTcModuleResult tcm
111− let errorPipeline = unDefer . hideDiag dflags
142+ let errorPipeline = unDefer . hideDiag dflags
112− return (map errorPipeline warnings, tcm2)
143+ return (map errorPipeline warnings, tcm2)
144+ where
145+ demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
113
146
114initPlugins :: GhcMonad m => ModSummary -> m ModSummary
147initPlugins :: GhcMonad m => ModSummary -> m ModSummary
115initPlugins modSummary = do
148initPlugins modSummary = do
@@ -121,18 +154,25 @@ initPlugins modSummary = do
121 return modSummary
154 return modSummary
122#endif
155#endif
123
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+
124-- | Compile a single type-checked module to a 'CoreModule' value, or
163-- | Compile a single type-checked module to a 'CoreModule' value, or
125-- provide errors.
164-- provide errors.
126compileModule
165compileModule
166+ :: RunSimplifier
127− :: HscEnv
167+ -> HscEnv
128− -> [TcModuleResult]
168+ -> [(ModSummary, HomeModInfo)]
129 -> TcModuleResult
169 -> TcModuleResult
130− -> IO ([FileDiagnostic], Maybe (SafeHaskellMode, CgGuts, ModDetails))
170+ -> IO (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
131−compileModule packageState deps tmr =
171+compileModule (RunSimplifier simplify) packageState deps tmr =
132 fmap (either (, Nothing) (second Just)) $
172 fmap (either (, Nothing) (second Just)) $
133− runGhcEnv packageState $
173+ evalGhcEnv packageState $
134 catchSrcErrors "compile" $ do
174 catchSrcErrors "compile" $ do
135− setupEnv (deps ++ [tmr])
175+ setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])
136
176
137 let tm = tmrModule tmr
177 let tm = tmrModule tmr
138 session <- getSession
178 session <- getSession
@@ -141,20 +181,30 @@ compileModule packageState deps tmr =
141 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
181 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}
142 let tm' = tm{tm_parsed_module = pm'}
182 let tm' = tm{tm_parsed_module = pm'}
143 GHC.dm_core_module <$> GHC.desugarModule tm'
183 GHC.dm_core_module <$> GHC.desugarModule tm'
144−
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
145 -- give variables unique OccNames
191 -- give variables unique OccNames
146− (guts, details) <- liftIO $ tidyProgram session desugar
192+ (guts, details) <- liftIO $ tidyProgram session desugared_guts
147 return (map snd warnings, (mg_safe_haskell desugar, guts, details))
193 return (map snd warnings, (mg_safe_haskell desugar, guts, details))
148
194
149−generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO ([FileDiagnostic], Maybe Linkable)
195+generateByteCode :: HscEnv -> [(ModSummary, HomeModInfo)] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable)
150generateByteCode hscEnv deps tmr guts =
196generateByteCode hscEnv deps tmr guts =
151 fmap (either (, Nothing) (second Just)) $
197 fmap (either (, Nothing) (second Just)) $
152− runGhcEnv hscEnv $
198+ evalGhcEnv hscEnv $
153 catchSrcErrors "bytecode" $ do
199 catchSrcErrors "bytecode" $ do
154− setupEnv (deps ++ [tmr])
200+ setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])
155 session <- getSession
201 session <- getSession
156 (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->
202 (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->
203+#if MIN_GHC_API_VERSION(8,10,0)
157− 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
158 let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr
208 let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr
159 let unlinked = BCOs bytecode sptEntries
209 let unlinked = BCOs bytecode sptEntries
160 let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
210 let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
@@ -176,9 +226,10 @@ demoteTypeErrorsToWarnings =
176enableTopLevelWarnings :: ParsedModule -> ParsedModule
226enableTopLevelWarnings :: ParsedModule -> ParsedModule
177enableTopLevelWarnings =
227enableTopLevelWarnings =
178 (update_pm_mod_summary . update_hspp_opts)
228 (update_pm_mod_summary . update_hspp_opts)
229+ ((`wopt_set` Opt_WarnMissingPatternSynonymSignatures) .
179− (`wopt_set` Opt_WarnMissingSignatures)
230+ (`wopt_set` Opt_WarnMissingSignatures))
180 -- 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
181− -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures))
232+ -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures)))
182
233
183update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary
234update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary
184update_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}
@@ -202,9 +253,9 @@ upgradeWarningToError (nfp, sh, fd) =
202hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
253hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
203hideDiag originalFlags (Reason warning, (nfp, _sh, fd))
254hideDiag originalFlags (Reason warning, (nfp, _sh, fd))
204 | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))
255 | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))
205−hideDiag _originalFlags t = t
256+hideDiag _originalFlags t = t
206
257
207−addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags
258+addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags
208addRelativeImport fp modu dflags = dflags
259addRelativeImport fp modu dflags = dflags
209 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
260 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
210
261
@@ -214,25 +265,81 @@ mkTcModuleResult
214 -> m TcModuleResult
265 -> m TcModuleResult
215mkTcModuleResult tcm = do
266mkTcModuleResult tcm = do
216 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
217− (iface, _) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv
272+ (iface, _) <- liftIO $ mkIfaceTc session Nothing sf details tcGblEnv
273+#endif
218 let mod_info = HomeModInfo iface details Nothing
274 let mod_info = HomeModInfo iface details Nothing
219 return $ TcModuleResult tcm mod_info
275 return $ TcModuleResult tcm mod_info
220 where
276 where
221 (tcGblEnv, details) = tm_internals_ tcm
277 (tcGblEnv, details) = tm_internals_ tcm
222
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+
223-- | Setup the environment that GHC needs according to our
325-- | Setup the environment that GHC needs according to our
224-- best understanding (!)
326-- best understanding (!)
327+--
328+-- This involves setting up the finder cache and populating the
329+-- HPT.
225−setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
330+setupEnv :: GhcMonad m => [(ModSummary, HomeModInfo)] -> m ()
226−setupEnv tmsIn = do
331+setupEnv tms = do
227− -- 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)
228− -- takes precedence, so put the .hs-boot file earlier in the list
333+ -- load dependent modules, which must be in topological order.
229− let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule
334+ modifySession $ \e ->
230− tms = sortBy (compare `on` Down . isSourceFile) tmsIn
335+ foldl' (\e (_, hmi) -> loadModuleHome hmi e) e tms
231
336
337+-- | Initialise the finder cache, dependencies should be topologically
338+-- sorted.
339+setupFinderCache :: GhcMonad m => [ModSummary] -> m ()
340+setupFinderCache mss = do
232 session <- getSession
341 session <- getSession
233
342
234− let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
235−
236 -- set the target and module graph in the session
343 -- set the target and module graph in the session
237 let graph = mkModuleGraph mss
344 let graph = mkModuleGraph mss
238 setSession session { hsc_mod_graph = graph }
345 setSession session { hsc_mod_graph = graph }
@@ -251,26 +358,40 @@ setupEnv tmsIn = do
251 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache
358 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache
252 modifySession $ \s -> s { hsc_FC = newFinderCacheVar }
359 modifySession $ \s -> s { hsc_FC = newFinderCacheVar }
253
360
254− -- load dependent modules, which must be in topological order.
255− mapM_ loadModuleHome tms
256−
257
361
258-- | Load a module, quickly. Input doesn't need to be desugared.
362-- | Load a module, quickly. Input doesn't need to be desugared.
259-- A module must be loaded before dependent modules can be typechecked.
363-- A module must be loaded before dependent modules can be typechecked.
260-- This variant of loadModuleHome will *never* cause recompilation, it just
364-- This variant of loadModuleHome will *never* cause recompilation, it just
261-- 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.
262loadModuleHome
370loadModuleHome
263− :: (GhcMonad m)
371+ :: HomeModInfo
264− => TcModuleResult
372+ -> HscEnv
265− -> m ()
373+ -> HscEnv
266−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
267− 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) }
268− where
384+ initIfaceLoad hsc' (typecheckIface iface)
269− ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
385+ let mod_info = HomeModInfo iface details linkable
270− mod_info = tmrModInfo tmr
386+ return $ loadModuleHome mod_info hsc
271− mod = ms_mod_name ms
387+ where
272−
388+ mod = moduleName $ mi_module iface
273
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'
274
395
275-- | 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
276-- name and its imports.
397-- name and its imports.
@@ -291,30 +412,18 @@ getImportsParsed dflags (L loc parsed) = do
291 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
412 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
292 ])
413 ])
293
414
294−
295-- | Produce a module summary from a StringBuffer.
415-- | Produce a module summary from a StringBuffer.
296getModSummaryFromBuffer
416getModSummaryFromBuffer
297 :: GhcMonad m
417 :: GhcMonad m
298 => FilePath
418 => FilePath
299− -> SB.StringBuffer
300 -> DynFlags
419 -> DynFlags
301 -> GHC.ParsedSource
420 -> GHC.ParsedSource
302 -> ExceptT [FileDiagnostic] m ModSummary
421 -> ExceptT [FileDiagnostic] m ModSummary
303−getModSummaryFromBuffer fp contents dflags parsed = do
422+getModSummaryFromBuffer fp dflags parsed = do
304 (modName, imports) <- liftEither $ getImportsParsed dflags parsed
423 (modName, imports) <- liftEither $ getImportsParsed dflags parsed
305
424
306− let modLoc = ModLocation
425+ modLoc <- liftIO $ mkHomeModLocation dflags modName fp
307− { ml_hs_file = Just fp
308− , ml_hi_file = derivedFile "hi"
309− , ml_obj_file = derivedFile "o"
310−#if MIN_GHC_API_VERSION(8,8,0)
311− , ml_hie_file = derivedFile "hie"
312−#endif
313− -- This does not consider the dflags configuration
314− -- (-osuf and -hisuf, object and hi dir.s).
315− -- However, we anyway don't want to generate them.
316− }
317− InstalledUnitId unitId = thisInstalledUnitId dflags
426+ let InstalledUnitId unitId = thisInstalledUnitId dflags
318 return $ ModSummary
427 return $ ModSummary
319 { ms_mod = mkModule (fsToUnitId unitId) modName
428 { ms_mod = mkModule (fsToUnitId unitId) modName
320 , ms_location = modLoc
429 , ms_location = modLoc
@@ -326,7 +435,7 @@ getModSummaryFromBuffer fp contents dflags parsed = do
326 , ms_textual_imps = [imp | (False, imp) <- imports]
435 , ms_textual_imps = [imp | (False, imp) <- imports]
327 , ms_hspp_file = fp
436 , ms_hspp_file = fp
328 , ms_hspp_opts = dflags
437 , ms_hspp_opts = dflags
329− , ms_hspp_buf = Just contents
438+ , ms_hspp_buf = Nothing
330
439
331 -- defaults:
440 -- defaults:
332 , ms_hsc_src = sourceType
441 , ms_hsc_src = sourceType
@@ -339,27 +448,71 @@ getModSummaryFromBuffer fp contents dflags parsed = do
339 , ms_parsed_mod = Nothing
448 , ms_parsed_mod = Nothing
340 }
449 }
341 where
450 where
342− (sourceType, derivedFile) =
451+ sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile
343− let (stem, ext) = splitExtension fp in
452+
344− if "-boot" `isSuffixOf` ext
453+-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports.
345− then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")
454+-- Runs preprocessors as needed.
346− else (HsSrcFile , \newExt -> stem <.> newExt)
455+getModSummaryFromImports
347−
456+ :: (HasDynFlags m, ExceptionMonad m, MonadIO m)
348−
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+
349−-- | Given a buffer, flags, file path and module summary, produce a
497+-- | Given a buffer, flags, and file path, produce a
350−-- parsed module (or errors) and any parse warnings.
498+-- parsed module (or errors) and any parse warnings. Does not run any preprocessors
351parseFileContents
499parseFileContents
352 :: GhcMonad m
500 :: GhcMonad m
353 => (GHC.ParsedSource -> IdePreprocessedSource)
501 => (GHC.ParsedSource -> IdePreprocessedSource)
502+ -> DynFlags -- ^ flags to use
503+ -> [PackageName] -- ^ The package imports to ignore
354 -> FilePath -- ^ the filename (for source locations)
504 -> FilePath -- ^ the filename (for source locations)
355− -> Maybe SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
505+ -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
356 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
506 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
357−parseFileContents customPreprocessor filename mbContents = do
507+parseFileContents customPreprocessor dflags comp_pkgs filename contents = do
358− (contents, dflags) <- preprocessor filename mbContents
359 let loc = mkRealSrcLoc (mkFastString filename) 1 1
508 let loc = mkRealSrcLoc (mkFastString filename) 1 1
360 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
361 PFailed _ locErr msgErr ->
513 PFailed _ locErr msgErr ->
362 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
514 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr
515+#endif
363 POk pst rdr_module ->
516 POk pst rdr_module ->
364 let hpm_annotations =
517 let hpm_annotations =
365 (Map.fromListWith (++) $ annotations pst,
518 (Map.fromListWith (++) $ annotations pst,
@@ -383,14 +536,63 @@ parseFileContents customPreprocessor filename mbContents = do
383 -- Ok, we got here. It's safe to continue.
536 -- Ok, we got here. It's safe to continue.
384 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
537 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
385 unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs
538 unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs
539+ let parsed' = removePackageImports comp_pkgs parsed
386 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
540 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
387− ms <- getModSummaryFromBuffer filename contents dflags parsed
541+ ms <- getModSummaryFromBuffer filename dflags parsed'
388 let pm =
542 let pm =
389 ParsedModule {
543 ParsedModule {
390 pm_mod_summary = ms
544 pm_mod_summary = ms
391− , pm_parsed_source = parsed
545+ , pm_parsed_source = parsed'
392 , pm_extra_src_files=[] -- src imports not allowed
546 , pm_extra_src_files=[] -- src imports not allowed
393 , pm_annotations = hpm_annotations
547 , pm_annotations = hpm_annotations
394 }
548 }
395 warnings = diagFromErrMsgs "parser" dflags warns
549 warnings = diagFromErrMsgs "parser" dflags warns
396 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+14−36
@@ -11,16 +11,10 @@ module Development.IDE.Core.FileStore(
11 fileStoreRules,
11 fileStoreRules,
12 VFSHandle,
12 VFSHandle,
13 makeVFSHandle,
13 makeVFSHandle,
14− makeLSPVFSHandle,
14+ makeLSPVFSHandle
15− getSourceFingerprint
16 ) where
15 ) where
17
16
18−import Foreign.Ptr
19−import Foreign.ForeignPtr
20−import Fingerprint
21−import StringBuffer
22import Development.IDE.GHC.Orphans()
17import Development.IDE.GHC.Orphans()
23−import Development.IDE.GHC.Util
24import Development.IDE.Core.Shake
18import Development.IDE.Core.Shake
25import Control.Concurrent.Extra
19import Control.Concurrent.Extra
26import qualified Data.Map.Strict as Map
20import qualified Data.Map.Strict as Map
@@ -40,7 +34,9 @@ import qualified Data.Rope.UTF16 as Rope
40
34
41#ifdef mingw32_HOST_OS
35#ifdef mingw32_HOST_OS
42import Data.Time
36import Data.Time
37+import qualified System.Directory as Dir
43#else
38#else
39+import Foreign.Ptr
44import Foreign.C.String
40import Foreign.C.String
45import Foreign.C.Types
41import Foreign.C.Types
46import Foreign.Marshal (alloca)
42import Foreign.Marshal (alloca)
@@ -87,9 +83,7 @@ makeLSPVFSHandle lspFuncs = VFSHandle
87
83
88
84
89-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
85-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
90−type instance RuleResult GetFileContents = (FileVersion, Maybe StringBuffer)
86+type instance RuleResult GetFileContents = (FileVersion, Maybe T.Text)
91−
92−type instance RuleResult FingerprintSource = Fingerprint
93
87
94data GetFileContents = GetFileContents
88data GetFileContents = GetFileContents
95 deriving (Eq, Show, Generic)
89 deriving (Eq, Show, Generic)
@@ -97,30 +91,16 @@ instance Hashable GetFileContents
97instance NFData GetFileContents
91instance NFData GetFileContents
98instance Binary GetFileContents
92instance Binary GetFileContents
99
93
100−data FingerprintSource = FingerprintSource
101− deriving (Eq, Show, Generic)
102−instance Hashable FingerprintSource
103−instance NFData FingerprintSource
104−instance Binary FingerprintSource
105−
106−fingerprintSourceRule :: Rules ()
107−fingerprintSourceRule =
108− define $ \FingerprintSource file -> do
109− (_, mbContent) <- getFileContents file
110− content <- liftIO $ maybe (hGetStringBuffer $ fromNormalizedFilePath file) pure mbContent
111− fingerprint <- liftIO $ fpStringBuffer content
112− pure ([], Just fingerprint)
113− where fpStringBuffer (StringBuffer buf len cur) = withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len
114−
115getModificationTimeRule :: VFSHandle -> Rules ()
94getModificationTimeRule :: VFSHandle -> Rules ()
116getModificationTimeRule vfs =
95getModificationTimeRule vfs =
117 defineEarlyCutoff $ \GetModificationTime file -> do
96 defineEarlyCutoff $ \GetModificationTime file -> do
118 let file' = fromNormalizedFilePath file
97 let file' = fromNormalizedFilePath file
119− let wrap time = (Just time, ([], Just $ ModificationTime time))
98+ let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s))
120 alwaysRerun
99 alwaysRerun
121 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
100 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
122 case mbVirtual of
101 case mbVirtual of
102+ Just (virtualFileVersion -> ver) ->
123− Just (virtualFileVersion -> ver) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
103+ pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
124 Nothing -> liftIO $ fmap wrap (getModTime file')
104 Nothing -> liftIO $ fmap wrap (getModTime file')
125 `catch` \(e :: IOException) -> do
105 `catch` \(e :: IOException) -> do
126 let err | isDoesNotExistError e = "File does not exist: " ++ file'
106 let err | isDoesNotExistError e = "File does not exist: " ++ file'
@@ -136,11 +116,13 @@ getModificationTimeRule vfs =
136 -- 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.
137 -- TODO leverage DidChangeWatchedFile lsp notifications on clients that
117 -- TODO leverage DidChangeWatchedFile lsp notifications on clients that
138 -- support them, as done for GetFileExists
118 -- support them, as done for GetFileExists
139− getModTime :: FilePath -> IO BS.ByteString
119+ getModTime :: FilePath -> IO (Int,Int)
140 getModTime f =
120 getModTime f =
141#ifdef mingw32_HOST_OS
121#ifdef mingw32_HOST_OS
142 do time <- Dir.getModificationTime f
122 do time <- Dir.getModificationTime f
123+ let !day = fromInteger $ toModifiedJulianDay $ utctDay time
143− pure $! BS.pack $ show (toModifiedJulianDay $ utctDay time, diffTimeToPicoseconds $ utctDayTime time)
124+ !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time
125+ pure (day, dayTime)
144#else
126#else
145 withCString f $ \f' ->
127 withCString f $ \f' ->
146 alloca $ \secPtr ->
128 alloca $ \secPtr ->
@@ -148,16 +130,13 @@ getModificationTimeRule vfs =
148 Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr
130 Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr
149 sec <- peek secPtr
131 sec <- peek secPtr
150 nsec <- peek nsecPtr
132 nsec <- peek nsecPtr
151− pure $! BS.pack $ show sec <> "." <> show nsec
133+ pure (fromEnum sec, fromIntegral nsec)
152
134
153-- 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
154-- as doing the FFI call ourselves :(.
136-- as doing the FFI call ourselves :(.
155foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int
137foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int
156#endif
138#endif
157
139
158−getSourceFingerprint :: NormalizedFilePath -> Action Fingerprint
159−getSourceFingerprint = use_ FingerprintSource
160−
161getFileContentsRule :: VFSHandle -> Rules ()
140getFileContentsRule :: VFSHandle -> Rules ()
162getFileContentsRule vfs =
141getFileContentsRule vfs =
163 define $ \GetFileContents file -> do
142 define $ \GetFileContents file -> do
@@ -165,7 +144,7 @@ getFileContentsRule vfs =
165 time <- use_ GetModificationTime file
144 time <- use_ GetModificationTime file
166 res <- liftIO $ ideTryIOException file $ do
145 res <- liftIO $ ideTryIOException file $ do
167 mbVirtual <- getVirtualFile vfs $ filePathToUri' file
146 mbVirtual <- getVirtualFile vfs $ filePathToUri' file
168− pure $ textToStringBuffer . Rope.toText . _text <$> mbVirtual
147+ pure $ Rope.toText . _text <$> mbVirtual
169 case res of
148 case res of
170 Left err -> return ([err], Nothing)
149 Left err -> return ([err], Nothing)
171 Right contents -> return ([], Just (time, contents))
150 Right contents -> return ([], Just (time, contents))
@@ -177,7 +156,7 @@ ideTryIOException fp act =
177 <$> try act
156 <$> try act
178
157
179
158
180−getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe StringBuffer)
159+getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe T.Text)
181getFileContents = use_ GetFileContents
160getFileContents = use_ GetFileContents
182
161
183fileStoreRules :: VFSHandle -> Rules ()
162fileStoreRules :: VFSHandle -> Rules ()
@@ -185,7 +164,6 @@ fileStoreRules vfs = do
185 addIdeGlobal vfs
164 addIdeGlobal vfs
186 getModificationTimeRule vfs
165 getModificationTimeRule vfs
187 getFileContentsRule vfs
166 getFileContentsRule vfs
188− fingerprintSourceRule
189
167
190
168
191-- | Notify the compiler service that a particular file has been modified.
169-- | Notify the compiler service that a particular file has been modified.
src/Development/IDE/Core/IdeConfiguration.hsnew file+71
@@ -0,0 +1,71 @@
1+{-# LANGUAGE DuplicateRecordFields #-}
2+module Development.IDE.Core.IdeConfiguration
3+ ( IdeConfiguration(..)
4+ , registerIdeConfiguration
5+ , parseConfiguration
6+ , parseWorkspaceFolder
7+ , isWorkspaceFile
8+ , modifyWorkspaceFolders
9+ )
10+where
11+
12+import Control.Concurrent.Extra
13+import Control.Monad
14+import Data.HashSet (HashSet, singleton)
15+import Data.Text (Text, isPrefixOf)
16+import Development.IDE.Core.Shake
17+import Development.IDE.Types.Location
18+import Development.Shake
19+import Language.Haskell.LSP.Types
20+import System.FilePath (isRelative)
21+
22+-- | Lsp client relevant configuration details
23+data IdeConfiguration = IdeConfiguration
24+ { workspaceFolders :: HashSet NormalizedUri
25+ }
26+ deriving (Show)
27+
28+newtype IdeConfigurationVar = IdeConfigurationVar {unIdeConfigurationRef :: Var IdeConfiguration}
29+
30+instance IsIdeGlobal IdeConfigurationVar
31+
32+registerIdeConfiguration :: ShakeExtras -> IdeConfiguration -> IO ()
33+registerIdeConfiguration extras =
34+ addIdeGlobalExtras extras . IdeConfigurationVar <=< newVar
35+
36+getIdeConfiguration :: Action IdeConfiguration
37+getIdeConfiguration =
38+ getIdeGlobalAction >>= liftIO . readVar . unIdeConfigurationRef
39+
40+parseConfiguration :: InitializeParams -> IdeConfiguration
41+parseConfiguration InitializeParams {..} =
42+ IdeConfiguration { .. }
43+ where
44+ workspaceFolders =
45+ foldMap (singleton . toNormalizedUri) _rootUri
46+ <> (foldMap . foldMap)
47+ (singleton . parseWorkspaceFolder)
48+ _workspaceFolders
49+
50+parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri
51+parseWorkspaceFolder =
52+ toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text)
53+
54+modifyWorkspaceFolders
55+ :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()
56+modifyWorkspaceFolders ide f = do
57+ IdeConfigurationVar var <- getIdeGlobalState ide
58+ IdeConfiguration ws <- readVar var
59+ writeVar var (IdeConfiguration (f ws))
60+
61+isWorkspaceFile :: NormalizedFilePath -> Action Bool
62+isWorkspaceFile file =
63+ if isRelative (fromNormalizedFilePath file)
64+ then return True
65+ else do
66+ IdeConfiguration {..} <- getIdeConfiguration
67+ let toText = getUri . fromNormalizedUri
68+ return $
69+ any
70+ (\root -> toText root `isPrefixOf` toText (filePathToUri' file))
71+ workspaceFolders
src/Development/IDE/Core/OfInterest.hs+24−24
@@ -1,19 +1,17 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4−
5−{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
7
6
8−-- | A Shake implementation of the compiler service, built
7+-- | Utilities and state for the files of interest - those which are currently
9−-- using the "Shaker" abstraction layer for in-memory use.
8+-- open in the editor. The useful function is 'getFilesOfInterest'.
10−--
11module Development.IDE.Core.OfInterest(
9module Development.IDE.Core.OfInterest(
12 ofInterestRules,
10 ofInterestRules,
13 getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,
11 getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,
14 ) where
12 ) where
15
13
16−import Control.Concurrent.Extra
14+import Control.Concurrent.Extra
17import Data.Binary
15import Data.Binary
18import Data.Hashable
16import Data.Hashable
19import Control.DeepSeq
17import Control.DeepSeq
@@ -21,25 +19,22 @@ import GHC.Generics
21import Data.Typeable
19import Data.Typeable
22import qualified Data.ByteString.UTF8 as BS
20import qualified Data.ByteString.UTF8 as BS
23import Control.Exception
21import Control.Exception
24−import Development.IDE.Types.Location
22+import Data.HashSet (HashSet)
25−import Development.IDE.Types.Logger
26−import Data.Set (Set)
27−import qualified Data.Set as Set
23+import qualified Data.HashSet as HashSet
28import qualified Data.Text as T
24import qualified Data.Text as T
29import Data.Tuple.Extra
25import Data.Tuple.Extra
30import Data.Functor
26import Data.Functor
31−import Development.Shake
32−
33−import Development.IDE.Core.Shake
27+import Development.Shake
34
28
29+import Development.IDE.Types.Location
30+import Development.IDE.Types.Logger
31+import Development.IDE.Core.Shake
35
32
36
33
37−newtype OfInterestVar = OfInterestVar (Var (Set NormalizedFilePath))
34+newtype OfInterestVar = OfInterestVar (Var (HashSet NormalizedFilePath))
38instance IsIdeGlobal OfInterestVar
35instance IsIdeGlobal OfInterestVar
39
36
40−
41−type instance RuleResult GetFilesOfInterest = Set NormalizedFilePath
37+type instance RuleResult GetFilesOfInterest = HashSet NormalizedFilePath
42−
43
38
44data GetFilesOfInterest = GetFilesOfInterest
39data GetFilesOfInterest = GetFilesOfInterest
45 deriving (Eq, Show, Typeable, Generic)
40 deriving (Eq, Show, Typeable, Generic)
@@ -48,16 +43,18 @@ instance NFData GetFilesOfInterest
48instance Binary GetFilesOfInterest
43instance Binary GetFilesOfInterest
49
44
50
45
46+-- | The rule that initialises the files of interest state.
51ofInterestRules :: Rules ()
47ofInterestRules :: Rules ()
52ofInterestRules = do
48ofInterestRules = do
53− addIdeGlobal . OfInterestVar =<< liftIO (newVar Set.empty)
49+ addIdeGlobal . OfInterestVar =<< liftIO (newVar HashSet.empty)
54 defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do
50 defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do
55 alwaysRerun
51 alwaysRerun
56 filesOfInterest <- getFilesOfInterestUntracked
52 filesOfInterest <- getFilesOfInterestUntracked
57 pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest))
53 pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest))
58
54
59
55
56+-- | Get the files that are open in the IDE.
60−getFilesOfInterest :: Action (Set NormalizedFilePath)
57+getFilesOfInterest :: Action (HashSet NormalizedFilePath)
61getFilesOfInterest = useNoFile_ GetFilesOfInterest
58getFilesOfInterest = useNoFile_ GetFilesOfInterest
62
59
63
60
@@ -65,18 +62,21 @@ getFilesOfInterest = useNoFile_ GetFilesOfInterest
65------------------------------------------------------------
62------------------------------------------------------------
66-- Exposed API
63-- Exposed API
67
64
68−-- | Set the files-of-interest which will be built and kept-up-to-date.
65+-- | Set the files-of-interest - not usually necessary or advisable.
66+-- The LSP client will keep this information up to date.
69−setFilesOfInterest :: IdeState -> Set NormalizedFilePath -> IO ()
67+setFilesOfInterest :: IdeState -> HashSet NormalizedFilePath -> IO ()
70setFilesOfInterest state files = modifyFilesOfInterest state (const files)
68setFilesOfInterest state files = modifyFilesOfInterest state (const files)
71
69
72−getFilesOfInterestUntracked :: Action (Set NormalizedFilePath)
70+getFilesOfInterestUntracked :: Action (HashSet NormalizedFilePath)
73getFilesOfInterestUntracked = do
71getFilesOfInterestUntracked = do
74 OfInterestVar var <- getIdeGlobalAction
72 OfInterestVar var <- getIdeGlobalAction
75 liftIO $ readVar var
73 liftIO $ readVar var
76
74
75+-- | Modify the files-of-interest - not usually necessary or advisable.
76+-- The LSP client will keep this information up to date.
77−modifyFilesOfInterest :: IdeState -> (Set NormalizedFilePath -> Set NormalizedFilePath) -> IO ()
77+modifyFilesOfInterest :: IdeState -> (HashSet NormalizedFilePath -> HashSet NormalizedFilePath) -> IO ()
78modifyFilesOfInterest state f = do
78modifyFilesOfInterest state f = do
79 OfInterestVar var <- getIdeGlobalState state
79 OfInterestVar var <- getIdeGlobalState state
80 files <- modifyVar var $ pure . dupe . f
80 files <- modifyVar var $ pure . dupe . f
81− logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ Set.toList files)
81+ logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashSet.toList files)
82 void $ shakeRun state []
82 void $ shakeRun state []
src/Development/IDE/Core/PositionMapping.hs+48−10
@@ -2,10 +2,15 @@
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3module Development.IDE.Core.PositionMapping
3module Development.IDE.Core.PositionMapping
4 ( PositionMapping(..)
4 ( PositionMapping(..)
5+ , fromCurrentPosition
6+ , toCurrentPosition
7+ , PositionDelta(..)
8+ , addDelta
9+ , mkDelta
5 , toCurrentRange
10 , toCurrentRange
6 , fromCurrentRange
11 , fromCurrentRange
7 , applyChange
12 , applyChange
8− , idMapping
13+ , zeroMapping
9 -- toCurrent and fromCurrent are mainly exposed for testing
14 -- toCurrent and fromCurrent are mainly exposed for testing
10 , toCurrent
15 , toCurrent
11 , fromCurrent
16 , fromCurrent
@@ -14,12 +19,25 @@ module Development.IDE.Core.PositionMapping
14import Control.Monad
19import Control.Monad
15import qualified Data.Text as T
20import qualified Data.Text as T
16import Language.Haskell.LSP.Types
21import Language.Haskell.LSP.Types
22+import Data.List
17
23
18−data PositionMapping = PositionMapping
24+-- The position delta is the difference between two versions
25+data PositionDelta = PositionDelta
19− { toCurrentPosition :: !(Position -> Maybe Position)
26+ { toDelta :: !(Position -> Maybe Position)
20− , fromCurrentPosition :: !(Position -> Maybe Position)
27+ , fromDelta :: !(Position -> Maybe Position)
21 }
28 }
22
29
30+fromCurrentPosition :: PositionMapping -> Position -> Maybe Position
31+fromCurrentPosition (PositionMapping pm) = fromDelta pm
32+
33+toCurrentPosition :: PositionMapping -> Position -> Maybe Position
34+toCurrentPosition (PositionMapping pm) = toDelta pm
35+
36+-- A position mapping is the difference from the current version to
37+-- a specific version
38+newtype PositionMapping = PositionMapping PositionDelta
39+
40+
23toCurrentRange :: PositionMapping -> Range -> Maybe Range
41toCurrentRange :: PositionMapping -> Range -> Maybe Range
24toCurrentRange mapping (Range a b) =
42toCurrentRange mapping (Range a b) =
25 Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b
43 Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b
@@ -28,13 +46,33 @@ fromCurrentRange :: PositionMapping -> Range -> Maybe Range
28fromCurrentRange mapping (Range a b) =
46fromCurrentRange mapping (Range a b) =
29 Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b
47 Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b
30
48
31−idMapping :: PositionMapping
49+zeroMapping :: PositionMapping
32−idMapping = PositionMapping Just Just
50+zeroMapping = PositionMapping idDelta
51+
52+-- | Compose two position mappings. Composes in the same way as function
53+-- composition (ie the second argument is applyed to the position first).
54+composeDelta :: PositionDelta
55+ -> PositionDelta
56+ -> PositionDelta
57+composeDelta (PositionDelta to1 from1) (PositionDelta to2 from2) =
58+ PositionDelta (to1 <=< to2)
59+ (from1 >=> from2)
60+
61+idDelta :: PositionDelta
62+idDelta = PositionDelta Just Just
63+
64+-- | Convert a set of changes into a delta from k to k + 1
65+mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta
66+mkDelta cs = foldl' applyChange idDelta cs
67+
68+-- | Add a new delta onto a Mapping k n to make a Mapping (k - 1) n
69+addDelta :: PositionDelta -> PositionMapping -> PositionMapping
70+addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm)
33
71
34−applyChange :: PositionMapping -> TextDocumentContentChangeEvent -> PositionMapping
72+applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta
35−applyChange posMapping (TextDocumentContentChangeEvent (Just r) _ t) = PositionMapping
73+applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta
36− { toCurrentPosition = toCurrent r t <=< toCurrentPosition posMapping
74+ { toDelta = toCurrent r t <=< toDelta
37− , fromCurrentPosition = fromCurrentPosition posMapping <=< fromCurrent r t
75+ , fromDelta = fromDelta <=< fromCurrent r t
38 }
76 }
39applyChange posMapping _ = posMapping
77applyChange posMapping _ = posMapping
40
78
src/Development/IDE/Core/Preprocessor.hs+16−6
@@ -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,11 +175,12 @@ 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-- | Run CPP on a file
178-- | Run CPP on a file
171runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
179runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer
172runCpp dflags filename contents = withTempDir $ \dir -> do
180runCpp dflags filename contents = withTempDir $ \dir -> do
173 let out = dir </> takeFileName filename <.> "out"
181 let out = dir </> takeFileName filename <.> "out"
182+ dflags <- pure $ addOptP "-D__GHCIDE__" dflags
183+
174 case contents of
184 case contents of
175 Nothing -> do
185 Nothing -> do
176 -- Happy case, file is not modified, so run CPP on it in-place
186 -- Happy case, file is not modified, so run CPP on it in-place
src/Development/IDE/Core/RuleTypes.hs+48−19
@@ -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,10 +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
30−import Development.IDE.Core.CompletionsTypes
31import Development.IDE.Spans.Type
28import Development.IDE.Spans.Type
29+import Development.IDE.Import.FindImports (ArtifactsLocation)
32
30
33
31
34-- NOTATION
32-- NOTATION
@@ -59,11 +57,27 @@ instance Show TcModuleResult where
59instance NFData TcModuleResult where
57instance NFData TcModuleResult where
60 rnf = rwhnf
58 rnf = rwhnf
61
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+
62-- | The type checked version of this file, requires TypeCheck+
76-- | The type checked version of this file, requires TypeCheck+
63type instance RuleResult TypeCheck = TcModuleResult
77type instance RuleResult TypeCheck = TcModuleResult
64
78
65-- | Information about what spans occur where, requires TypeCheck
79-- | Information about what spans occur where, requires TypeCheck
66−type instance RuleResult GetSpanInfo = [SpanInfo]
80+type instance RuleResult GetSpanInfo = SpansInfo
67
81
68-- | Convert to Core, requires TypeCheck*
82-- | Convert to Core, requires TypeCheck*
69type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)
83type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)
@@ -76,19 +90,24 @@ type instance RuleResult GhcSession = HscEnvEq
76
90
77-- | 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
78-- in the same package or the package id of another package.
92-- in the same package or the package id of another package.
79−type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe NormalizedFilePath)], S.Set InstalledUnitId)
93+type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId)
80
94
81-- | 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.
82-- We cannot report the cycles directly from GetDependencyInformation since
96-- We cannot report the cycles directly from GetDependencyInformation since
83-- we can only report diagnostics for the current file.
97-- we can only report diagnostics for the current file.
84type instance RuleResult ReportImportCycles = ()
98type instance RuleResult ReportImportCycles = ()
85
99
86−-- | Read the given HIE file.
100+-- | Read the module interface file
87−type instance RuleResult GetHieFile = HieFile
101+type instance RuleResult GetHiFile = HiFileResult
88
102
89−-- | Produce completions info for a file
103+-- | Get a module interface, either from an interface file or a typechecked module
90−type instance RuleResult ProduceCompletions = (CachedCompletions, TcModuleResult)
104+type instance RuleResult GetModIface = HiFileResult
91
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
92
111
93data GetParsedModule = GetParsedModule
112data GetParsedModule = GetParsedModule
94 deriving (Eq, Show, Typeable, Generic)
113 deriving (Eq, Show, Typeable, Generic)
@@ -150,16 +169,26 @@ instance Hashable GhcSession
150instance NFData GhcSession
169instance NFData GhcSession
151instance Binary GhcSession
170instance Binary GhcSession
152
171
153−-- Note that we embed the filepath here instead of using the filepath associated with Shake keys.
172+data GetHiFile = GetHiFile
154−-- Otherwise we will garbage collect the result since files in package dependencies will not be declared reachable.
173+ deriving (Eq, Show, Typeable, Generic)
155−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
156 deriving (Eq, Show, Typeable, Generic)
185 deriving (Eq, Show, Typeable, Generic)
157−instance Hashable GetHieFile
186+instance Hashable IsFileOfInterest
158−instance NFData GetHieFile
187+instance NFData IsFileOfInterest
159−instance Binary GetHieFile
188+instance Binary IsFileOfInterest
160
189
161−data ProduceCompletions = ProduceCompletions
190+data GetModSummary = GetModSummary
162 deriving (Eq, Show, Typeable, Generic)
191 deriving (Eq, Show, Typeable, Generic)
163−instance Hashable ProduceCompletions
192+instance Hashable GetModSummary
164−instance NFData ProduceCompletions
193+instance NFData GetModSummary
165−instance Binary ProduceCompletions
194+instance Binary GetModSummary
src/Development/IDE/Core/Rules.hs+422−136
@@ -1,16 +1,18 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4+{-# LANGUAGE CPP #-}
4−{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeFamilies #-}
5−{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE DuplicateRecordFields #-}
7{-# LANGUAGE DuplicateRecordFields #-}
8+#include "ghc-api-version.h"
7
9
8-- | A Shake implementation of the compiler service, built
10-- | A Shake implementation of the compiler service, built
9-- using the "Shaker" abstraction layer for in-memory use.
11-- using the "Shaker" abstraction layer for in-memory use.
10--
12--
11module Development.IDE.Core.Rules(
13module Development.IDE.Core.Rules(
12 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
14 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
13− Priority(..),
15+ Priority(..), GhcSessionIO(..), GhcSessionFun(..),
14 priorityTypeCheck,
16 priorityTypeCheck,
15 priorityGenerateCore,
17 priorityGenerateCore,
16 priorityFilesOfInterest,
18 priorityFilesOfInterest,
@@ -21,53 +23,59 @@ module Development.IDE.Core.Rules(
21 getDefinition,
23 getDefinition,
22 getDependencies,
24 getDependencies,
23 getParsedModule,
25 getParsedModule,
24− fileFromParsedModule,
25 generateCore,
26 generateCore,
26 ) where
27 ) where
27
28
28import Fingerprint
29import Fingerprint
29
30
30−import Data.Binary
31+import Data.Binary hiding (get, put)
32+import Data.Bifunctor (first, second)
31−import Control.Monad
33+import Control.Monad.Extra
32import Control.Monad.Trans.Class
34import Control.Monad.Trans.Class
33import Control.Monad.Trans.Maybe
35import Control.Monad.Trans.Maybe
34import Development.IDE.Core.Compile
36import Development.IDE.Core.Compile
35−import Development.IDE.Core.Completions
37+import Development.IDE.Core.OfInterest
36import Development.IDE.Types.Options
38import Development.IDE.Types.Options
37import Development.IDE.Spans.Calculate
39import Development.IDE.Spans.Calculate
38import Development.IDE.Import.DependencyInformation
40import Development.IDE.Import.DependencyInformation
39import Development.IDE.Import.FindImports
41import Development.IDE.Import.FindImports
40import Development.IDE.Core.FileExists
42import Development.IDE.Core.FileExists
41−import Development.IDE.Core.FileStore (getFileContents, getSourceFingerprint)
43+import Development.IDE.Core.FileStore (getFileContents)
42import Development.IDE.Types.Diagnostics
44import Development.IDE.Types.Diagnostics
43import Development.IDE.Types.Location
45import Development.IDE.Types.Location
46+import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)
44import Development.IDE.GHC.Util
47import Development.IDE.GHC.Util
45−import Data.Coerce
48+import Development.IDE.GHC.WithDynFlags
46import Data.Either.Extra
49import Data.Either.Extra
47import Data.Maybe
50import Data.Maybe
48import Data.Foldable
51import Data.Foldable
49import qualified Data.IntMap.Strict as IntMap
52import qualified Data.IntMap.Strict as IntMap
50−import qualified Data.IntSet as IntSet
53+import Data.IntMap.Strict (IntMap)
51import Data.List
54import Data.List
55+import Data.Ord
52import qualified Data.Set as Set
56import qualified Data.Set as Set
53import qualified Data.Text as T
57import qualified Data.Text as T
54import Development.IDE.GHC.Error
58import Development.IDE.GHC.Error
55import Development.Shake hiding (Diagnostic)
59import Development.Shake hiding (Diagnostic)
56import Development.IDE.Core.RuleTypes
60import Development.IDE.Core.RuleTypes
61+import Development.IDE.Spans.Type
62+import qualified Data.ByteString.Char8 as BS
57
63
58−import GHC hiding (parseModule, typecheckModule)
59import qualified GHC.LanguageExtensions as LangExt
64import qualified GHC.LanguageExtensions as LangExt
60−import Development.IDE.GHC.Compat (hie_file_result, readHieFile)
61−import UniqSupply
62−import NameCache
63import HscTypes
65import HscTypes
66+import PackageConfig
64−import DynFlags (xopt)
67+import DynFlags (gopt_set, xopt)
65import GHC.Generics(Generic)
68import GHC.Generics(Generic)
66
69
67import qualified Development.IDE.Spans.AtPoint as AtPoint
70import qualified Development.IDE.Spans.AtPoint as AtPoint
68import Development.IDE.Core.Service
71import Development.IDE.Core.Service
69import Development.IDE.Core.Shake
72import Development.IDE.Core.Shake
70−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
71
79
72-- | 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
73-- a result into the more general IdeResult type that supports producing
81-- a result into the more general IdeResult type that supports producing
@@ -81,14 +89,14 @@ useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v
81useE k = MaybeT . use k
89useE k = MaybeT . use k
82
90
83useNoFileE :: IdeRule k v => k -> MaybeT Action v
91useNoFileE :: IdeRule k v => k -> MaybeT Action v
84−useNoFileE k = useE k ""
92+useNoFileE k = useE k emptyFilePath
85
93
86usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
94usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
87usesE k = MaybeT . fmap sequence . uses k
95usesE k = MaybeT . fmap sequence . uses k
88
96
89defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
97defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
90defineNoFile f = define $ \k file -> do
98defineNoFile f = define $ \k file -> do
91− if file == "" then do res <- f k; return ([], Just res) else
99+ if file == emptyFilePath then do res <- f k; return ([], Just res) else
92 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"
93
101
94
102
@@ -112,9 +120,58 @@ getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
112getDefinition file pos = fmap join $ runMaybeT $ do
120getDefinition file pos = fmap join $ runMaybeT $ do
113 opts <- lift getIdeOptions
121 opts <- lift getIdeOptions
114 spans <- useE GetSpanInfo file
122 spans <- useE GetSpanInfo file
115− pkgState <- hscEnv <$> useE GhcSession file
116− let getHieFile x = useNoFile (GetHieFile x)
117− lift $ AtPoint.gotoDefinition getHieFile opts pkgState spans pos
123+ lift $ AtPoint.gotoDefinition (getHieFile file) opts (spansExprs spans) pos
124+
125+getHieFile
126+ :: NormalizedFilePath -- ^ file we're editing
127+ -> Module -- ^ module dep we want info for
128+ -> Action (Maybe (HieFile, FilePath)) -- ^ hie stuff for the module
129+getHieFile file mod = do
130+ TransitiveDependencies {transitiveNamedModuleDeps} <- use_ GetDependencies file
131+ case find (\x -> nmdModuleName x == moduleName mod) transitiveNamedModuleDeps of
132+ Just NamedModuleDep{nmdFilePath=nfp} -> do
133+ let modPath = fromNormalizedFilePath nfp
134+ (_diags, hieFile) <- getHomeHieFile nfp
135+ return $ (, modPath) <$> hieFile
136+ _ -> getPackageHieFile mod file
137+
138+
139+getHomeHieFile :: NormalizedFilePath -> Action ([a], Maybe HieFile)
140+getHomeHieFile f = do
141+ ms <- use_ GetModSummary f
142+ let normal_hie_f = toNormalizedFilePath' hie_f
143+ hie_f = ml_hie_file $ ms_location ms
144+ mbHieTimestamp <- use GetModificationTime normal_hie_f
145+ srcTimestamp <- use_ GetModificationTime f
146+ let isUpToDate
147+ | Just d <- mbHieTimestamp = comparing modificationTime d srcTimestamp == GT
148+ | otherwise = False
149+
150+ unless isUpToDate $
151+ void $ use_ TypeCheck f
152+
153+ hf <- liftIO $ whenMaybe isUpToDate (loadHieFile hie_f)
154+ return ([], hf)
155+
156+getPackageHieFile :: Module -- ^ Package Module to load .hie file for
157+ -> NormalizedFilePath -- ^ Path of home module importing the package module
158+ -> Action (Maybe (HieFile, FilePath))
159+getPackageHieFile mod file = do
160+ pkgState <- hscEnv <$> use_ GhcSession file
161+ IdeOptions {..} <- getIdeOptions
162+ let unitId = moduleUnitId mod
163+ case lookupPackageConfig unitId pkgState of
164+ Just pkgConfig -> do
165+ -- 'optLocateHieFile' returns Nothing if the file does not exist
166+ hieFile <- liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod
167+ path <- liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod
168+ case (hieFile, path) of
169+ (Just hiePath, Just modPath) ->
170+ -- deliberately loaded outside the Shake graph
171+ -- to avoid dependencies on non-workspace files
172+ liftIO $ Just . (, modPath) <$> loadHieFile hiePath
173+ _ -> return Nothing
174+ _ -> return Nothing
118
175
119-- | Parse the contents of a daml file.
176-- | Parse the contents of a daml file.
120getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
177getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)
@@ -134,26 +191,60 @@ priorityFilesOfInterest :: Priority
134priorityFilesOfInterest = Priority (-2)
191priorityFilesOfInterest = Priority (-2)
135
192
136getParsedModuleRule :: Rules ()
193getParsedModuleRule :: Rules ()
137−getParsedModuleRule =
138− defineEarlyCutoff $ \GetParsedModule file -> do
194+getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
139− (_, contents) <- getFileContents file
140− packageState <- hscEnv <$> use_ GhcSession file
195+ sess <- use_ GhcSession file
196+ let hsc = hscEnv sess
197+ -- These packages are used when removing PackageImports from a
198+ -- parsed module
199+ comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)
141− opt <- getIdeOptions
200+ opt <- getIdeOptions
201+ (_, contents) <- getFileContents file
202+
203+ let dflags = hsc_dflags hsc
204+ mainParse = getParsedModuleDefinition hsc opt comp_pkgs file contents
205+
206+ -- Parse again (if necessary) to capture Haddock parse errors
207+ if gopt Opt_Haddock dflags
208+ then
209+ liftIO mainParse
210+ else do
211+ let hscHaddock = hsc{hsc_dflags = gopt_set dflags Opt_Haddock}
212+ haddockParse = do
213+ (_, (!diagsHaddock, _)) <-
214+ getParsedModuleDefinition hscHaddock opt comp_pkgs file contents
215+ return diagsHaddock
216+
217+ ((fingerPrint, (diags, res)), diagsHaddock) <-
218+ -- parse twice, with and without Haddocks, concurrently
219+ -- we cannot ignore Haddock parse errors because files of
220+ -- non-interest are always parsed with Haddocks
221+ liftIO $ concurrently mainParse haddockParse
222+
223+ return (fingerPrint, (mergeDiagnostics diags diagsHaddock, res))
224+
225+getParsedModuleDefinition :: HscEnv -> IdeOptions -> [PackageName] -> NormalizedFilePath -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))
226+getParsedModuleDefinition packageState opt comp_pkgs file contents = do
142− r <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents
227+ (diag, res) <- parseModule opt packageState comp_pkgs (fromNormalizedFilePath file) (fmap textToStringBuffer contents)
143− mbFingerprint <- traverse (const $ getSourceFingerprint file) (optShakeFiles opt)
228+ case res of
229+ Nothing -> pure (Nothing, (diag, Nothing))
230+ Just (contents, modu) -> do
231+ mbFingerprint <- if isNothing $ optShakeFiles opt
232+ then pure Nothing
233+ else Just . fingerprintToBS <$> fingerprintFromStringBuffer contents
144− pure (fingerprintToBS <$> mbFingerprint, r)
234+ pure (mbFingerprint, (diag, Just modu))
145
235
146getLocatedImportsRule :: Rules ()
236getLocatedImportsRule :: Rules ()
147getLocatedImportsRule =
237getLocatedImportsRule =
148 define $ \GetLocatedImports file -> do
238 define $ \GetLocatedImports file -> do
149− pm <- use_ GetParsedModule file
239+ ms <- use_ GetModSummary file
150− let ms = pm_mod_summary pm
151 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
240 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
152− env <- hscEnv <$> use_ GhcSession file
241+ env_eq <- use_ GhcSession file
242+ let env = hscEnv env_eq
243+ let import_dirs = deps env_eq
153− let dflags = addRelativeImport file pm $ hsc_dflags env
244+ let dflags = addRelativeImport file (moduleName $ ms_mod ms) $ hsc_dflags env
154 opt <- getIdeOptions
245 opt <- getIdeOptions
155 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
246 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
156− diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource
247+ diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getFileExists modName mbPkgName isSource
157 case diagOrImp of
248 case diagOrImp of
158 Left diags -> pure (diags, Left (modName, Nothing))
249 Left diags -> pure (diags, Left (modName, Nothing))
159 Right (FileImport path) -> pure ([], Left (modName, Just path))
250 Right (FileImport path) -> pure ([], Left (modName, Just path))
@@ -167,48 +258,109 @@ getLocatedImportsRule =
167 Nothing -> pure (concat diags, Nothing)
258 Nothing -> pure (concat diags, Nothing)
168 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))
259 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))
169
260
261+type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a
262+
263+execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1)
264+execRawDepM act =
265+ execStateT act
266+ ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty
267+ , IntMap.empty
268+ )
170
269
171-- | Given a target file path, construct the raw dependency results by following
270-- | Given a target file path, construct the raw dependency results by following
172-- imports recursively.
271-- imports recursively.
173−rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation
272+rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation
174−rawDependencyInformation f = do
273+rawDependencyInformation fs = do
175− let (initialId, initialMap) = getPathId f emptyPathIdMap
274+ (rdi, ss) <- execRawDepM (mapM_ go fs)
176− go (IntSet.singleton $ getFilePathId initialId)
275+ let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss
177− (RawDependencyInformation IntMap.empty initialMap)
276+ return (rdi { rawBootMap = bm })
178 where
277 where
179− go fs rawDepInfo =
278+ go :: NormalizedFilePath -- ^ Current module being processed
180− case IntSet.minView fs of
279+ -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId
181− -- Queue is empty
280+ go f = do
182− Nothing -> pure rawDepInfo
281+ -- First check to see if we have already processed the FilePath
183− -- Pop f from the queue and process it
282+ -- If we have, just return its Id but don't update any of the state.
184− Just (f, fs) -> do
283+ -- Otherwise, we need to process its imports.
185− let fId = FilePathId f
284+ checkAlreadyProcessed f $ do
285+ al <- lift $ modSummaryToArtifactsLocation f <$> use_ GetModSummary f
286+ -- Get a fresh FilePathId for the new file
287+ fId <- getFreshFid al
288+ -- Adding an edge to the bootmap so we can make sure to
289+ -- insert boot nodes before the real files.
290+ addBootMap al fId
291+ -- Try to parse the imports of the file
186− importsOrErr <- use GetLocatedImports $ idToPath (rawPathIdMap rawDepInfo) fId
292+ importsOrErr <- lift $ use GetLocatedImports f
187− case importsOrErr of
293+ case importsOrErr of
188− Nothing ->
294+ Nothing -> do
189− -- File doesn’t parse
295+ -- File doesn't parse so add the module as a failure into the
296+ -- dependency information, continue processing the other
297+ -- elements in the queue
190− let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo
298+ modifyRawDepInfo (insertImport fId (Left ModuleParseError))
191− in go fs rawDepInfo'
299+ return fId
192− Just (modImports, pkgImports) -> do
300+ Just (modImports, pkgImports) -> do
193− let f :: PathIdMap -> (a, Maybe NormalizedFilePath) -> (PathIdMap, (a, Maybe FilePathId))
301+ -- Get NFPs of the imports which have corresponding files
194− f pathMap (imp, mbPath) = case mbPath of
302+ -- Imports either come locally from a file or from a package.
195− Nothing -> (pathMap, (imp, Nothing))
303+ let (no_file, with_file) = splitImports modImports
196− Just path ->
304+ (mns, ls) = unzip with_file
197− let (pathId, pathMap') = getPathId path pathMap
305+ -- Recursively process all the imports we just learnt about
198− in (pathMap', (imp, Just pathId))
306+ -- and get back a list of their FilePathIds
199− -- Convert paths in imports to ids and update the path map
307+ fids <- mapM (go . artifactFilePath) ls
200− let (pathIdMap, modImports') = mapAccumL f (rawPathIdMap rawDepInfo) modImports
308+ -- Associate together the ModuleName with the FilePathId
201− -- Files that we haven’t seen before are added to the queue.
309+ let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids)
202− let newFiles =
310+ -- Insert into the map the information about this modules
203− IntSet.fromList (coerce $ mapMaybe snd modImports')
311+ -- imports.
204− IntSet.\\ IntMap.keysSet (rawImports rawDepInfo)
205− let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo
312+ modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports' pkgImports)
206− go (newFiles `IntSet.union` fs) (rawDepInfo' { rawPathIdMap = pathIdMap })
313+ return fId
314+
315+
316+ checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId
317+ checkAlreadyProcessed nfp k = do
318+ (rawDepInfo, _) <- get
319+ maybe k return (lookupPathToId (rawPathIdMap rawDepInfo) nfp)
320+
321+ modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation) -> RawDepM ()
322+ modifyRawDepInfo f = modify (first f)
323+
324+ addBootMap :: ArtifactsLocation -> FilePathId -> RawDepM ()
325+ addBootMap al fId =
326+ modify (\(rd, ss) -> (rd, if isBootLocation al
327+ then IntMap.insert (getFilePathId fId) al ss
328+ else ss))
329+
330+ getFreshFid :: ArtifactsLocation -> RawDepM FilePathId
331+ getFreshFid al = do
332+ (rawDepInfo, ss) <- get
333+ let (fId, path_map) = getPathId al (rawPathIdMap rawDepInfo)
334+ -- Insert the File into the bootmap if it's a boot module
335+ let rawDepInfo' = rawDepInfo { rawPathIdMap = path_map }
336+ put (rawDepInfo', ss)
337+ return fId
338+
339+ -- Split in (package imports, local imports)
340+ splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)]
341+ -> ([Located ModuleName], [(Located ModuleName, ArtifactsLocation)])
342+ splitImports = foldr splitImportsLoop ([],[])
343+
344+ splitImportsLoop (imp, Nothing) (ns, ls) = (imp:ns, ls)
345+ splitImportsLoop (imp, Just artifact) (ns, ls) = (ns, (imp,artifact) : ls)
346+
347+ updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =
348+ if not artifactIsSource
349+ then
350+ let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix artifactModLocation)
351+ in case msource_mod_id of
352+ Just source_mod_id -> insertBootId source_mod_id (FilePathId boot_mod_id) bm
353+ Nothing -> bm
354+ else bm
355+
356+ dropBootSuffix :: ModLocation -> FilePath
357+ dropBootSuffix (ModLocation (Just hs_src) _ _) = reverse . drop (length @[] "-boot") . reverse $ hs_src
358+ dropBootSuffix _ = error "dropBootSuffix"
207
359
208getDependencyInformationRule :: Rules ()
360getDependencyInformationRule :: Rules ()
209getDependencyInformationRule =
361getDependencyInformationRule =
210 define $ \GetDependencyInformation file -> do
362 define $ \GetDependencyInformation file -> do
211− rawDepInfo <- rawDependencyInformation file
363+ rawDepInfo <- rawDependencyInformation [file]
212 pure ([], Just $ processDependencyInformation rawDepInfo)
364 pure ([], Just $ processDependencyInformation rawDepInfo)
213
365
214reportImportCyclesRule :: Rules ()
366reportImportCyclesRule :: Rules ()
@@ -236,12 +388,13 @@ reportImportCyclesRule =
236 , _message = "Cyclic module dependency between " <> showCycle mods
388 , _message = "Cyclic module dependency between " <> showCycle mods
237 , _code = Nothing
389 , _code = Nothing
238 , _relatedInformation = Nothing
390 , _relatedInformation = Nothing
391+ , _tags = Nothing
239 }
392 }
240 where loc = srcSpanToLocation (getLoc imp)
393 where loc = srcSpanToLocation (getLoc imp)
241− fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)
394+ fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp)
242 getModuleName file = do
395 getModuleName file = do
243− pm <- use_ GetParsedModule file
396+ ms <- use_ GetModSummary file
244− pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)
397+ pure (moduleNameString . moduleName . ms_mod $ ms)
245 showCycle mods = T.intercalate ", " (map T.pack mods)
398 showCycle mods = T.intercalate ", " (map T.pack mods)
246
399
247-- returns all transitive dependencies in topological order.
400-- returns all transitive dependencies in topological order.
@@ -249,7 +402,7 @@ reportImportCyclesRule =
249getDependenciesRule :: Rules ()
402getDependenciesRule :: Rules ()
250getDependenciesRule =
403getDependenciesRule =
251 defineEarlyCutoff $ \GetDependencies file -> do
404 defineEarlyCutoff $ \GetDependencies file -> do
252− depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file
405+ depInfo <- use_ GetDependencyInformation file
253 let allFiles = reachableModules depInfo
406 let allFiles = reachableModules depInfo
254 _ <- uses_ ReportImportCycles allFiles
407 _ <- uses_ ReportImportCycles allFiles
255 opts <- getIdeOptions
408 opts <- getIdeOptions
@@ -261,64 +414,101 @@ getSpanInfoRule :: Rules ()
261getSpanInfoRule =
414getSpanInfoRule =
262 define $ \GetSpanInfo file -> do
415 define $ \GetSpanInfo file -> do
263 tc <- use_ TypeCheck file
416 tc <- use_ TypeCheck file
264− deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file
265− tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)
266− (fileImports, _) <- use_ GetLocatedImports file
267 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
268− x <- liftIO $ getSrcSpanInfos packageState fileImports tc tms
432+ x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps (map hirModIface ifaces)
269 return ([], Just x)
433 return ([], Just x)
270
434
271-- Typechecks a module.
435-- Typechecks a module.
272typeCheckRule :: Rules ()
436typeCheckRule :: Rules ()
273−typeCheckRule =
274− define $ \TypeCheck file -> do
437+typeCheckRule = define $ \TypeCheck file -> do
275− 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
276− deps <- use_ GetDependencies file
458+ deps <- use_ GetDependencies file
277− packageState <- hscEnv <$> use_ GhcSession file
459+ hsc <- hscEnv <$> use_ GhcSession file
278− -- Figure out whether we need TemplateHaskell or QuasiQuotes support
460+ -- Figure out whether we need TemplateHaskell or QuasiQuotes support
279− let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph packageState
461+ let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc
280− 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)
281− 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)
282− tms <- if any_uses_th_qq
465+ bytecodes <- if any_uses_th_qq
283− -- If we use TH or QQ, we must obtain the bytecode
466+ then -- If we use TH or QQ, we must obtain the bytecode
284− then do
285− bytecodes <- uses_ GenerateByteCode (transitiveModuleDeps deps)
467+ fmap Just <$> uses_ GenerateByteCode (transitiveModuleDeps deps)
286− tmrs <- uses_ TypeCheck (transitiveModuleDeps deps)
468+ else
287− pure (zipWith addByteCode bytecodes tmrs)
469+ pure $ repeat Nothing
288− else uses_ TypeCheck (transitiveModuleDeps deps)
470+
289− setPriority priorityTypeCheck
471+ setPriority priorityTypeCheck
290− IdeOptions{ optDefer = defer} <- getIdeOptions
472+ IdeOptions { optDefer = defer } <- getIdeOptions
473+
474+ addUsageDependencies $ liftIO $ do
291− 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)
292− where
483+ where
484+ unpack HiFileResult{..} bc = (hirModSummary, (hirModIface, bc))
485+ uses_th_qq dflags =
293− uses_th_qq dflags = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
486+ xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
487+
294− addByteCode :: Linkable -> TcModuleResult -> TcModuleResult
488+ addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)
295− addByteCode lm tmr = tmr { tmrModInfo = (tmrModInfo tmr) { hm_linkable = Just lm } }
489+ addUsageDependencies a = do
296−
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+
297−generateCore :: NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
501+generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
298−generateCore file = do
502+generateCore runSimplifier file = do
299 deps <- use_ GetDependencies file
503 deps <- use_ GetDependencies file
300 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
504 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
301 setPriority priorityGenerateCore
505 setPriority priorityGenerateCore
302 packageState <- hscEnv <$> use_ GhcSession file
506 packageState <- hscEnv <$> use_ GhcSession file
303− liftIO $ compileModule packageState tms tm
507+ liftIO $ compileModule runSimplifier packageState [(tmrModSummary x, tmrModInfo x) | x <- tms] tm
304
508
305generateCoreRule :: Rules ()
509generateCoreRule :: Rules ()
306generateCoreRule =
510generateCoreRule =
307− define $ \GenerateCore -> generateCore
511+ define $ \GenerateCore -> generateCore (RunSimplifier True)
308−
309−produceCompletions :: Rules ()
310−produceCompletions =
311− define $ \ProduceCompletions file -> do
312− deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file
313− tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)
314− tm <- fmap fst <$> useWithStale TypeCheck file
315− packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file
316− case (tm, packageState) of
317− (Just tm', Just packageState') -> do
318− cdata <- liftIO $ cacheDataProducer packageState' (hsc_dflags packageState')
319− (tmrModule tm') (map tmrModule tms)
320− return ([], Just (cdata, tm'))
321− _ -> return ([], Nothing)
322
512
323generateByteCodeRule :: Rules ()
513generateByteCodeRule :: Rules ()
324generateByteCodeRule =
514generateByteCodeRule =
@@ -327,7 +517,7 @@ generateByteCodeRule =
327 (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)
517 (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)
328 session <- hscEnv <$> use_ GhcSession file
518 session <- hscEnv <$> use_ GhcSession file
329 (_, guts, _) <- use_ GenerateCore file
519 (_, guts, _) <- use_ GenerateCore file
330− liftIO $ generateByteCode session tms tm guts
520+ liftIO $ generateByteCode session [(tmrModSummary x, tmrModInfo x) | x <- tms] tm guts
331
521
332-- 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
333-- 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.
@@ -339,7 +529,7 @@ instance Hashable GhcSessionIO
339instance NFData GhcSessionIO
529instance NFData GhcSessionIO
340instance Binary GhcSessionIO
530instance Binary GhcSessionIO
341
531
342−newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq)
532+newtype GhcSessionFun = GhcSessionFun (FilePath -> Action (IdeResult HscEnvEq))
343instance Show GhcSessionFun where show _ = "GhcSessionFun"
533instance Show GhcSessionFun where show _ = "GhcSessionFun"
344instance NFData GhcSessionFun where rnf !_ = ()
534instance NFData GhcSessionFun where rnf !_ = ()
345
535
@@ -348,20 +538,119 @@ loadGhcSession :: Rules ()
348loadGhcSession = do
538loadGhcSession = do
349 defineNoFile $ \GhcSessionIO -> do
539 defineNoFile $ \GhcSessionIO -> do
350 opts <- getIdeOptions
540 opts <- getIdeOptions
351− 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
352 defineEarlyCutoff $ \GhcSession file -> do
546 defineEarlyCutoff $ \GhcSession file -> do
353 GhcSessionFun fun <- useNoFile_ GhcSessionIO
547 GhcSessionFun fun <- useNoFile_ GhcSessionIO
548+ alwaysRerun
354 val <- fun $ fromNormalizedFilePath file
549 val <- fun $ fromNormalizedFilePath file
355− opts <- getIdeOptions
356− return ("" <$ optShakeFiles opts, ([], Just val))
357
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)
358
648
359−getHieFileRule :: Rules ()
649+isFileOfInterestRule :: Rules ()
360−getHieFileRule =
650+isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do
361− defineNoFile $ \(GetHieFile f) -> do
651+ filesOfInterest <- getFilesOfInterest
362− u <- liftIO $ mkSplitUniqSupply 'a'
652+ let res = f `elem` filesOfInterest
363− let nameCache = initNameCache u []
653+ return (Just (if res then "1" else ""), ([], Just res))
364− liftIO $ fmap (hie_file_result . fst) $ readHieFile nameCache f
365
654
366-- | A rule that wires per-file rules together
655-- | A rule that wires per-file rules together
367mainRule :: Rules ()
656mainRule :: Rules ()
@@ -376,10 +665,7 @@ mainRule = do
376 generateCoreRule
665 generateCoreRule
377 generateByteCodeRule
666 generateByteCodeRule
378 loadGhcSession
667 loadGhcSession
379− getHieFileRule
668+ getHiFileRule
380− produceCompletions
669+ getModIfaceRule
381−
670+ isFileOfInterestRule
382−------------------------------------------------------------
671+ getModSummaryRule
383−
384−fileFromParsedModule :: ParsedModule -> NormalizedFilePath
385−fileFromParsedModule = toNormalizedFilePath . ms_hspp_file . pm_mod_summary
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+170−146
@@ -19,24 +19,24 @@
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,
27 shakeProfile,
27 shakeProfile,
28 use, useWithStale, useNoFile, uses, usesWithStale,
28 use, useWithStale, useNoFile, uses, usesWithStale,
29 use_, useNoFile_, uses_,
29 use_, useNoFile_, uses_,
30− define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, fingerprintToBS,
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,13 +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
54−import qualified Data.ByteString.Internal as BS
55import Data.Dynamic
53import Data.Dynamic
56import Data.Maybe
54import Data.Maybe
57import Data.Map.Strict (Map)
55import Data.Map.Strict (Map)
58−import Data.List.Extra (foldl', partition, takeEnd)
56+import Data.List.Extra (partition, takeEnd)
59import qualified Data.Set as Set
57import qualified Data.Set as Set
60import qualified Data.Text as T
58import qualified Data.Text as T
61import Data.Traversable (for)
59import Data.Traversable (for)
@@ -64,16 +62,14 @@ import Data.Unique
64import Development.IDE.Core.Debouncer
62import Development.IDE.Core.Debouncer
65import Development.IDE.Core.PositionMapping
63import Development.IDE.Core.PositionMapping
66import Development.IDE.Types.Logger hiding (Priority)
64import Development.IDE.Types.Logger hiding (Priority)
67−import Foreign.Ptr
68−import Foreign.Storable
69−import GHC.Fingerprint
70import Language.Haskell.LSP.Diagnostics
65import Language.Haskell.LSP.Diagnostics
71import qualified Data.SortedList as SL
66import qualified Data.SortedList as SL
72import Development.IDE.Types.Diagnostics
67import Development.IDE.Types.Diagnostics
73import Development.IDE.Types.Location
68import Development.IDE.Types.Location
74import Development.IDE.Types.Options
69import Development.IDE.Types.Options
70+import Control.Concurrent.Async
75import Control.Concurrent.Extra
71import Control.Concurrent.Extra
76−import Control.Exception
72+import Control.Exception.Extra
77import Control.DeepSeq
73import Control.DeepSeq
78import System.Time.Extra
74import System.Time.Extra
79import Data.Typeable
75import Data.Typeable
@@ -98,12 +94,16 @@ data ShakeExtras = ShakeExtras
98 ,state :: Var Values
94 ,state :: Var Values
99 ,diagnostics :: Var DiagnosticStore
95 ,diagnostics :: Var DiagnosticStore
100 ,hiddenDiagnostics :: Var DiagnosticStore
96 ,hiddenDiagnostics :: Var DiagnosticStore
101− ,publishedDiagnostics :: Var (Map NormalizedUri [Diagnostic])
97+ ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])
102 -- ^ This represents the set of diagnostics that we have published.
98 -- ^ This represents the set of diagnostics that we have published.
103 -- Due to debouncing not every change might get published.
99 -- Due to debouncing not every change might get published.
104− ,positionMapping :: Var (Map NormalizedUri (Map TextDocumentVersion PositionMapping))
100+ ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))
105 -- ^ 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
106 -- 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
107 }
107 }
108
108
109getShakeExtras :: Action ShakeExtras
109getShakeExtras :: Action ShakeExtras
@@ -116,22 +116,29 @@ getShakeExtrasRules = do
116 Just x <- getShakeExtraRules @ShakeExtras
116 Just x <- getShakeExtraRules @ShakeExtras
117 return x
117 return x
118
118
119−
120−
121class Typeable a => IsIdeGlobal a where
119class Typeable a => IsIdeGlobal a where
122
120
123addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
121addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
124−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 ()
125− ShakeExtras{globals} <- getShakeExtrasRules
127+addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =
126 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
128 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
127− 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
128 Nothing -> return $! HMap.insert ty (toDyn x) mp
130 Nothing -> return $! HMap.insert ty (toDyn x) mp
129
131
130
132
131getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
133getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
132getIdeGlobalExtras ShakeExtras{globals} = do
134getIdeGlobalExtras ShakeExtras{globals} = do
135+ let typ = typeRep (Proxy :: Proxy a)
133− Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
136+ x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
134− 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
135
142
136getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
143getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
137getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
144getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
@@ -154,7 +161,7 @@ instance Eq Key where
154 | otherwise = False
161 | otherwise = False
155
162
156instance Hashable Key where
163instance Hashable Key where
157− hashWithSalt salt (Key key) = hashWithSalt salt key
164+ hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)
158
165
159-- | 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,
160-- 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
@@ -164,9 +171,6 @@ instance Hashable Key where
164-- 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
165-- errors but still failed.
172-- errors but still failed.
166--
173--
167−-- A rule on a file should only return diagnostics for that given file. It should
168−-- not propagate diagnostic errors through multiple phases.
169−type IdeResult v = ([FileDiagnostic], Maybe v)
170
174
171data Value v
175data Value v
172 = Succeeded TextDocumentVersion v
176 = Succeeded TextDocumentVersion v
@@ -201,14 +205,14 @@ valueVersion = \case
201 Failed -> Nothing
205 Failed -> Nothing
202
206
203mappingForVersion
207mappingForVersion
204− :: Map NormalizedUri (Map TextDocumentVersion PositionMapping)
208+ :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))
205 -> NormalizedFilePath
209 -> NormalizedFilePath
206 -> TextDocumentVersion
210 -> TextDocumentVersion
207 -> PositionMapping
211 -> PositionMapping
208mappingForVersion allMappings file ver =
212mappingForVersion allMappings file ver =
209− fromMaybe idMapping $
213+ maybe zeroMapping snd $
210 Map.lookup ver =<<
214 Map.lookup ver =<<
211− Map.lookup (filePathToUri' file) allMappings
215+ HMap.lookup (filePathToUri' file) allMappings
212
216
213type IdeRule k v =
217type IdeRule k v =
214 ( Shake.RuleResult k ~ v
218 ( Shake.RuleResult k ~ v
@@ -239,7 +243,6 @@ shakeRunDatabaseProfile mbProfileDir shakeDb acts = do
239 shakeProfileDatabase shakeDb $ dir </> file
243 shakeProfileDatabase shakeDb $ dir </> file
240 return (dir </> file)
244 return (dir </> file)
241 return (res, proFile)
245 return (res, proFile)
242− where
243
246
244{-# NOINLINE profileStartTime #-}
247{-# NOINLINE profileStartTime #-}
245profileStartTime :: String
248profileStartTime :: String
@@ -295,34 +298,40 @@ seqValue v b = case v of
295shakeOpen :: IO LSP.LspId
298shakeOpen :: IO LSP.LspId
296 -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
299 -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
297 -> Logger
300 -> Logger
301+ -> Debouncer NormalizedUri
298 -> Maybe FilePath
302 -> Maybe FilePath
299 -> IdeReportProgress
303 -> IdeReportProgress
300 -> ShakeOptions
304 -> ShakeOptions
301 -> Rules ()
305 -> Rules ()
302 -> IO IdeState
306 -> IO IdeState
303−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
304 shakeExtras <- do
309 shakeExtras <- do
305 globals <- newVar HMap.empty
310 globals <- newVar HMap.empty
306 state <- newVar HMap.empty
311 state <- newVar HMap.empty
307 diagnostics <- newVar mempty
312 diagnostics <- newVar mempty
308 hiddenDiagnostics <- newVar mempty
313 hiddenDiagnostics <- newVar mempty
309 publishedDiagnostics <- newVar mempty
314 publishedDiagnostics <- newVar mempty
310− debouncer <- newDebouncer
311− positionMapping <- newVar Map.empty
315+ positionMapping <- newVar HMap.empty
312 pure ShakeExtras{..}
316 pure ShakeExtras{..}
313 (shakeDb, shakeClose) <-
317 (shakeDb, shakeClose) <-
314 shakeOpenDatabase
318 shakeOpenDatabase
315 opts
319 opts
316 { 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
317− , shakeProgress = if reportProgress then lspShakeProgress getLspId eventer else const (pure ())
323+ , shakeProgress = const $ if reportProgress then lspShakeProgress getLspId eventer inProgress else pure ()
318 }
324 }
319 rules
325 rules
320 shakeAbort <- newMVar $ return ()
326 shakeAbort <- newMVar $ return ()
321 shakeDb <- shakeDb
327 shakeDb <- shakeDb
322 return IdeState{..}
328 return IdeState{..}
323
329
324−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 ()
325−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
326 lspId <- getLspId
335 lspId <- getLspId
327 u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique
336 u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique
328 sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest
337 sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest
@@ -350,9 +359,9 @@ lspShakeProgress getLspId sendMsg prog = do
350 sample = 0.1
359 sample = 0.1
351 loop id prev = do
360 loop id prev = do
352 sleep sample
361 sleep sample
353− p <- prog
362+ current <- readVar inProgress
354− let done = countSkipped p + countBuilt p
363+ let done = length $ filter (== 0) $ HMap.elems current
355− let todo = done + countUnknown p + countTodo p
364+ let todo = HMap.size current
356 let next = Just $ T.pack $ show done <> "/" <> show todo
365 let next = Just $ T.pack $ show done <> "/" <> show todo
357 when (next /= prev) $
366 when (next /= prev) $
358 sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification
367 sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification
@@ -378,11 +387,11 @@ shakeShut IdeState{..} = withMVar shakeAbort $ \stop -> do
378
387
379-- | This is a variant of withMVar where the first argument is run unmasked and if it throws
388-- | This is a variant of withMVar where the first argument is run unmasked and if it throws
380-- an exception, the previous value is restored while the second argument is executed masked.
389-- an exception, the previous value is restored while the second argument is executed masked.
381−withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
390+withMVar' :: MVar a -> (a -> IO ()) -> IO (a, c) -> IO c
382withMVar' var unmasked masked = mask $ \restore -> do
391withMVar' var unmasked masked = mask $ \restore -> do
383 a <- takeMVar var
392 a <- takeMVar var
384− b <- restore (unmasked a) `onException` putMVar var a
393+ restore (unmasked a) `onException` putMVar var a
385− (a', c) <- masked b
394+ (a', c) <- masked
386 putMVar var a'
395 putMVar var a'
387 pure c
396 pure c
388
397
@@ -394,29 +403,33 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =
394 (\stop -> do
403 (\stop -> do
395 (stopTime,_) <- duration stop
404 (stopTime,_) <- duration stop
396 logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
405 logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
397− bar <- newBarrier
406+ )
398− start <- offsetTime
399− pure (start, bar))
400 -- It is crucial to be masked here, otherwise we can get killed
407 -- It is crucial to be masked here, otherwise we can get killed
401 -- between spawning the new thread and updating shakeAbort.
408 -- between spawning the new thread and updating shakeAbort.
402 -- See https://github.com/digital-asset/ghcide/issues/79
409 -- See https://github.com/digital-asset/ghcide/issues/79
410+ (do
403− (\(start, bar) -> do
411+ start <- offsetTime
412+ aThread <- asyncWithUnmask $ \restore -> do
404− thread <- forkFinally (shakeRunDatabaseProfile shakeProfileDir shakeDb acts) $ \res -> do
413+ res <- try (restore $ shakeRunDatabaseProfile shakeProfileDir shakeDb acts)
405− runTime <- start
414+ runTime <- start
406− let res' = case res of
415+ let res' = case res of
407− Left e -> "exception: " <> displayException e
416+ Left e -> "exception: " <> displayException e
408− Right _ -> "completed"
417+ Right _ -> "completed"
409− profile = case res of
418+ profile = case res of
410− Right (_, Just fp) ->
419+ Right (_, Just fp) ->
411− let link = case filePathToUri' $ toNormalizedFilePath fp of
420+ let link = case filePathToUri' $ toNormalizedFilePath' fp of
412− NormalizedUri x -> x
421+ NormalizedUri _ x -> x
413− in ", profile saved at " <> T.unpack link
422+ in ", profile saved at " <> T.unpack link
414− _ -> ""
423+ _ -> ""
415− logDebug logger $ T.pack $
424+ let logMsg = logDebug logger $ T.pack $
416− "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ profile ++ ")"
425+ "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ profile ++ ")"
417− signalBarrier bar (fst <$> res)
426+ return (fst <$> res, logMsg)
418− -- important: we send an async exception to the thread, then wait for it to die, before continuing
427+ let wrapUp (res, _) = do
419− pure (killThread thread >> void (waitBarrier bar), either throwIO return =<< waitBarrier bar))
428+ either (throwIO @SomeException) return res
429+ _ <- async $ do
430+ (_, logMsg) <- wait aThread
431+ logMsg
432+ pure (cancel aThread, wrapUp =<< wait aThread))
420
433
421getDiagnostics :: IdeState -> IO [FileDiagnostic]
434getDiagnostics :: IdeState -> IO [FileDiagnostic]
422getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
435getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
@@ -443,9 +456,9 @@ garbageCollect keep = do
443 return $! dupe values
456 return $! dupe values
444 modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags
457 modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags
445 modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags
458 modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags
446− modifyVar_ publishedDiagnostics $ \diags -> return $! Map.filterWithKey (\uri _ -> keep (fromUri uri)) diags
459+ modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags
447 let versionsForFile =
460 let versionsForFile =
448− Map.fromListWith Set.union $
461+ HMap.fromListWith Set.union $
449 mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
462 mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
450 HMap.toList newState
463 HMap.toList newState
451 modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings
464 modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings
@@ -463,25 +476,25 @@ useWithStale :: IdeRule k v
463useWithStale key file = head <$> usesWithStale key [file]
476useWithStale key file = head <$> usesWithStale key [file]
464
477
465useNoFile :: IdeRule k v => k -> Action (Maybe v)
478useNoFile :: IdeRule k v => k -> Action (Maybe v)
466−useNoFile key = use key ""
479+useNoFile key = use key emptyFilePath
467
480
468use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
481use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
469use_ key file = head <$> uses_ key [file]
482use_ key file = head <$> uses_ key [file]
470
483
471useNoFile_ :: IdeRule k v => k -> Action v
484useNoFile_ :: IdeRule k v => k -> Action v
472−useNoFile_ key = use_ key ""
485+useNoFile_ key = use_ key emptyFilePath
473
486
474uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
487uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
475uses_ key files = do
488uses_ key files = do
476 res <- uses key files
489 res <- uses key files
477 case sequence res of
490 case sequence res of
478− Nothing -> liftIO $ throwIO BadDependency
491+ Nothing -> liftIO $ throwIO $ BadDependency (show key)
479 Just v -> return v
492 Just v -> return v
480
493
481
494
482-- | 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
483-- which short-circuits the rest of the action
496-- which short-circuits the rest of the action
484−data BadDependency = BadDependency deriving Show
497+data BadDependency = BadDependency String deriving Show
485instance Exception BadDependency
498instance Exception BadDependency
486
499
487isBadDependency :: SomeException -> Bool
500isBadDependency :: SomeException -> Bool
@@ -500,12 +513,10 @@ instance Show k => Show (Q k) where
500
513
501-- | Invariant: the 'v' must be in normal form (fully evaluated).
514-- | Invariant: the 'v' must be in normal form (fully evaluated).
502-- 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
503−-- Note (MK) I am not sure why we need the ShakeValue here, maybe we
504−-- can just remove it?
505−data A v = A (Value v) ShakeValue
516+newtype A v = A (Value v)
506 deriving Show
517 deriving Show
507
518
508−instance NFData (A v) where rnf (A v x) = v `seq` rnf x
519+instance NFData (A v) where rnf (A v) = v `seq` ()
509
520
510-- 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,
511-- namely Q (question) / A (answer).
522-- namely Q (question) / A (answer).
@@ -515,59 +526,70 @@ type instance RuleResult (Q k) = A (RuleResult k)
515-- | Return up2date results. Stale results will be ignored.
526-- | Return up2date results. Stale results will be ignored.
516uses :: IdeRule k v
527uses :: IdeRule k v
517 => k -> [NormalizedFilePath] -> Action [Maybe v]
528 => k -> [NormalizedFilePath] -> Action [Maybe v]
518−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)
519
530
520-- | Return the last computed result which might be stale.
531-- | Return the last computed result which might be stale.
521usesWithStale :: IdeRule k v
532usesWithStale :: IdeRule k v
522 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
533 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
523usesWithStale key files = do
534usesWithStale key files = do
524− values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
535+ values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files)
525− 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+
526
546
527defineEarlyCutoff
547defineEarlyCutoff
528 :: IdeRule k v
548 :: IdeRule k v
529 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
549 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
530 -> Rules ()
550 -> Rules ()
531defineEarlyCutoff 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
532− 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
533− val <- case old of
555+ val <- case old of
534− Just old | mode == RunDependenciesSame -> do
556+ Just old | mode == RunDependenciesSame -> do
535− v <- liftIO $ getValues state key file
557+ v <- liftIO $ getValues state key file
536− case v of
558+ case v of
537− -- No changes in the dependencies and we have
559+ -- No changes in the dependencies and we have
538− -- an existing result.
560+ -- an existing result.
539− Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)
561+ Just v -> return $ Just $ RunResult ChangedNothing old $ A v
540− _ -> return Nothing
562+ _ -> return Nothing
541− _ -> return Nothing
563+ _ -> return Nothing
542− case val of
564+ case val of
543− Just res -> return res
565+ Just res -> return res
544− Nothing -> do
566+ Nothing -> do
545− (bs, (diags, res)) <- actionCatch
567+ (bs, (diags, res)) <- actionCatch
546− (do v <- op key file; liftIO $ evaluate $ force $ v) $
568+ (do v <- op key file; liftIO $ evaluate $ force v) $
547− \(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))
548− modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file
570+ modTime <- liftIO $ (currentValue =<<) <$> getValues state GetModificationTime file
549− (bs, res) <- case res of
571+ (bs, res) <- case res of
550− Nothing -> do
572+ Nothing -> do
551− staleV <- liftIO $ getValues state key file
573+ staleV <- liftIO $ getValues state key file
552− pure $ case staleV of
574+ pure $ case staleV of
553− Nothing -> (toShakeValue ShakeResult bs, Failed)
575+ Nothing -> (toShakeValue ShakeResult bs, Failed)
554− Just v -> case v of
576+ Just v -> case v of
555− Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
577+ Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
556− Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
578+ Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
557− Failed -> (toShakeValue ShakeResult bs, Failed)
579+ Failed -> (toShakeValue ShakeResult bs, Failed)
558− Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
580+ Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
559− liftIO $ setValues state key file res
581+ liftIO $ setValues state key file res
560− updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
582+ updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
561− let eq = case (bs, fmap decodeShakeValue old) of
583+ let eq = case (bs, fmap decodeShakeValue old) of
562− (ShakeResult a, Just (ShakeResult b)) -> a == b
584+ (ShakeResult a, Just (ShakeResult b)) -> a == b
563− (ShakeStale a, Just (ShakeStale b)) -> a == b
585+ (ShakeStale a, Just (ShakeStale b)) -> a == b
564− -- If we do not have a previous result
586+ -- If we do not have a previous result
565− -- or we got ShakeNoCutoff we always return False.
587+ -- or we got ShakeNoCutoff we always return False.
566− _ -> False
588+ _ -> False
567− return $ RunResult
589+ return $ RunResult
568− (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
590+ (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
569− (encodeShakeValue bs) $
591+ (encodeShakeValue bs) $
570− A res bs
592+ A res
571
593
572
594
573-- | Rule type, input file
595-- | Rule type, input file
@@ -635,21 +657,15 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $
635 | otherwise = ChangedRecomputeDiff
657 | otherwise = ChangedRecomputeDiff
636 pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)
658 pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)
637
659
638−fingerprintToBS :: Fingerprint -> BS.ByteString
639−fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do
640− ptr <- pure $ castPtr ptr
641− pokeElemOff ptr 0 a
642− pokeElemOff ptr 1 b
643−
644needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()
660needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()
645needOnDisk k file = do
661needOnDisk k file = do
646 successfull <- apply1 (QDisk k file)
662 successfull <- apply1 (QDisk k file)
647− liftIO $ unless successfull $ throwIO BadDependency
663+ liftIO $ unless successfull $ throwIO $ BadDependency (show k)
648
664
649needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()
665needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()
650needOnDisks k files = do
666needOnDisks k files = do
651 successfulls <- apply $ map (QDisk k) files
667 successfulls <- apply $ map (QDisk k) files
652− liftIO $ unless (and successfulls) $ throwIO BadDependency
668+ liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k)
653
669
654toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue
670toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue
655toShakeValue = maybe ShakeNoCutoff
671toShakeValue = maybe ShakeNoCutoff
@@ -688,7 +704,7 @@ updateFileDiagnostics ::
688 -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
704 -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
689 -> Action ()
705 -> Action ()
690updateFileDiagnostics 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
691− modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp
707+ modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp
692 let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
708 let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
693 mask_ $ do
709 mask_ $ do
694 -- Mask async exceptions to ensure that updated diagnostics are always
710 -- Mask async exceptions to ensure that updated diagnostics are always
@@ -701,7 +717,7 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, published
701 let newDiags = getFileDiagnostics fp newDiagsStore
717 let newDiags = getFileDiagnostics fp newDiagsStore
702 _ <- evaluate newDiagsStore
718 _ <- evaluate newDiagsStore
703 _ <- evaluate newDiags
719 _ <- evaluate newDiags
704− pure $! (newDiagsStore, newDiags)
720+ pure (newDiagsStore, newDiags)
705 modifyVar_ hiddenDiagnostics $ \old -> do
721 modifyVar_ hiddenDiagnostics $ \old -> do
706 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
722 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
707 (T.pack $ show k) (map snd currentHidden) old
723 (T.pack $ show k) (map snd currentHidden) old
@@ -713,10 +729,10 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, published
713 let delay = if null newDiags then 0.1 else 0
729 let delay = if null newDiags then 0.1 else 0
714 registerEvent debouncer delay uri $ do
730 registerEvent debouncer delay uri $ do
715 mask_ $ modifyVar_ publishedDiagnostics $ \published -> do
731 mask_ $ modifyVar_ publishedDiagnostics $ \published -> do
716− let lastPublish = Map.findWithDefault [] uri published
732+ let lastPublish = HMap.lookupDefault [] uri published
717 when (lastPublish /= newDiags) $
733 when (lastPublish /= newDiags) $
718 eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags
734 eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags
719− pure $! Map.insert uri newDiags published
735+ pure $! HMap.insert uri newDiags published
720
736
721publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage
737publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage
722publishDiagnosticsNotification uri diags =
738publishDiagnosticsNotification uri diags =
@@ -727,7 +743,7 @@ publishDiagnosticsNotification uri diags =
727newtype Priority = Priority Double
743newtype Priority = Priority Double
728
744
729setPriority :: Priority -> Action ()
745setPriority :: Priority -> Action ()
730−setPriority (Priority p) = deprioritize p
746+setPriority (Priority p) = reschedule p
731
747
732sendEvent :: LSP.FromServerMessage -> Action ()
748sendEvent :: LSP.FromServerMessage -> Action ()
733sendEvent e = do
749sendEvent e = do
@@ -752,19 +768,22 @@ instance Binary GetModificationTime
752-- | Get the modification time of a file.
768-- | Get the modification time of a file.
753type instance RuleResult GetModificationTime = FileVersion
769type instance RuleResult GetModificationTime = FileVersion
754
770
755−-- | We store the modification time as a ByteString since we need
771+data FileVersion
756−-- a ByteString anyway for Shake and we do not care about how times
772+ = VFSVersion !Int
757−-- are represented.
758−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)
759 deriving (Show, Generic)
776 deriving (Show, Generic)
760
777
761instance NFData FileVersion
778instance NFData FileVersion
762
779
763vfsVersion :: FileVersion -> Maybe Int
780vfsVersion :: FileVersion -> Maybe Int
764vfsVersion (VFSVersion i) = Just i
781vfsVersion (VFSVersion i) = Just i
765−vfsVersion (ModificationTime _) = Nothing
782+vfsVersion ModificationTime{} = Nothing
766−
767
783
784+modificationTime :: FileVersion -> Maybe (Int, Int)
785+modificationTime VFSVersion{} = Nothing
786+modificationTime (ModificationTime large small) = Just (large, small)
768
787
769getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
788getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
770getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
789getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
@@ -789,7 +808,7 @@ getAllDiagnostics ::
789 DiagnosticStore ->
808 DiagnosticStore ->
790 [FileDiagnostic]
809 [FileDiagnostic]
791getAllDiagnostics =
810getAllDiagnostics =
792− concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . Map.toList
811+ concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList
793
812
794getFileDiagnostics ::
813getFileDiagnostics ::
795 NormalizedFilePath ->
814 NormalizedFilePath ->
@@ -797,29 +816,34 @@ getFileDiagnostics ::
797 [LSP.Diagnostic]
816 [LSP.Diagnostic]
798getFileDiagnostics fp ds =
817getFileDiagnostics fp ds =
799 maybe [] getDiagnosticsFromStore $
818 maybe [] getDiagnosticsFromStore $
800− Map.lookup (filePathToUri' fp) ds
819+ HMap.lookup (filePathToUri' fp) ds
801
820
802filterDiagnostics ::
821filterDiagnostics ::
803 (NormalizedFilePath -> Bool) ->
822 (NormalizedFilePath -> Bool) ->
804 DiagnosticStore ->
823 DiagnosticStore ->
805 DiagnosticStore
824 DiagnosticStore
806filterDiagnostics keep =
825filterDiagnostics keep =
807− Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)
826+ HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri)
808
827
809filterVersionMap
828filterVersionMap
810− :: Map NormalizedUri (Set.Set TextDocumentVersion)
829+ :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)
811− -> Map NormalizedUri (Map TextDocumentVersion a)
830+ -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
812− -> Map NormalizedUri (Map TextDocumentVersion a)
831+ -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)
813filterVersionMap =
832filterVersionMap =
814− Map.merge Map.dropMissing Map.dropMissing $
815− Map.zipWithMatched $ \_ versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
833+ HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
816
834
817updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
835updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
818−updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do
836+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do
819 modifyVar_ positionMapping $ \allMappings -> do
837 modifyVar_ positionMapping $ \allMappings -> do
820 let uri = toNormalizedUri _uri
838 let uri = toNormalizedUri _uri
821− let mappingForUri = Map.findWithDefault Map.empty uri allMappings
839+ let mappingForUri = HMap.lookupDefault Map.empty uri allMappings
822− let updatedMapping =
840+ let (_, updatedMapping) =
823− Map.insert _version idMapping $
841+ -- Very important to use mapAccum here so that the tails of
824− 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)
825− pure $! Map.insert uri updatedMapping allMappings
847+ pure $! HMap.insert uri updatedMapping allMappings
848+ where
849+ shared_change = mkDelta changes
src/Development/IDE/GHC/CPP.hs+34−5
@@ -19,7 +19,8 @@
19--
19--
20-----------------------------------------------------------------------------
20-----------------------------------------------------------------------------
21
21
22−module Development.IDE.GHC.CPP(doCpp) where
22+module Development.IDE.GHC.CPP(doCpp, addOptP)
23+where
23
24
24import Development.IDE.GHC.Compat
25import Development.IDE.GHC.Compat
25import Packages
26import Packages
@@ -28,9 +29,15 @@ import Module
28import DynFlags
29import DynFlags
29import Panic
30import Panic
30import FileCleanup
31import FileCleanup
31−#if MIN_GHC_API_VERSION(8,8,0)
32+#if MIN_GHC_API_VERSION(8,8,2)
33+import LlvmCodeGen (llvmVersionList)
34+#elif MIN_GHC_API_VERSION(8,8,0)
32import LlvmCodeGen (LlvmVersion (..))
35import LlvmCodeGen (LlvmVersion (..))
33#endif
36#endif
37+#if MIN_GHC_API_VERSION (8,10,0)
38+import Fingerprint
39+import ToolSettings
40+#endif
34
41
35import System.Directory
42import System.Directory
36import System.FilePath
43import System.FilePath
@@ -57,7 +64,11 @@ doCpp dflags raw input_fn output_fn = do
57 let verbFlags = getVerbFlags dflags
64 let verbFlags = getVerbFlags dflags
58
65
59 let cpp_prog args | raw = SysTools.runCpp dflags args
66 let cpp_prog args | raw = SysTools.runCpp dflags args
67+#if MIN_GHC_API_VERSION(8,10,0)
68+ | otherwise = SysTools.runCc Nothing
69+#else
60 | otherwise = SysTools.runCc
70 | otherwise = SysTools.runCc
71+#endif
61 dflags (SysTools.Option "-E" : args)
72 dflags (SysTools.Option "-E" : args)
62
73
63 let target_defs =
74 let target_defs =
@@ -114,8 +125,6 @@ doCpp dflags raw input_fn output_fn = do
114 ++ map SysTools.Option sse_defs
125 ++ map SysTools.Option sse_defs
115 ++ map SysTools.Option avx_defs
126 ++ map SysTools.Option avx_defs
116 ++ mb_macro_include
127 ++ mb_macro_include
117− -- Define a special macro "__GHCIDE__"
118− ++ [ SysTools.Option "-D__GHCIDE__"]
119 -- Set the language mode to assembler-with-cpp when preprocessing. This
128 -- Set the language mode to assembler-with-cpp when preprocessing. This
120 -- alleviates some of the C99 macro rules relating to whitespace and the hash
129 -- alleviates some of the C99 macro rules relating to whitespace and the hash
121 -- operator, which we tend to abuse. Clang in particular is not very happy
130 -- operator, which we tend to abuse. Clang in particular is not very happy
@@ -139,7 +148,11 @@ getBackendDefs :: DynFlags -> IO [String]
139getBackendDefs dflags | hscTarget dflags == HscLlvm = do
148getBackendDefs dflags | hscTarget dflags == HscLlvm = do
140 llvmVer <- figureLlvmVersion dflags
149 llvmVer <- figureLlvmVersion dflags
141 return $ case llvmVer of
150 return $ case llvmVer of
142−#if MIN_GHC_API_VERSION(8,8,0)
151+#if MIN_GHC_API_VERSION(8,8,2)
152+ Just v
153+ | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ]
154+ | m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ]
155+#elif MIN_GHC_API_VERSION(8,8,0)
143 Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]
156 Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]
144 Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
157 Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
145#else
158#else
@@ -154,6 +167,22 @@ getBackendDefs dflags | hscTarget dflags == HscLlvm = do
154getBackendDefs _ =
167getBackendDefs _ =
155 return []
168 return []
156
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+
157-- ---------------------------------------------------------------------------
186-- ---------------------------------------------------------------------------
158-- Macros (cribbed from Cabal)
187-- Macros (cribbed from Cabal)
159
188
src/Development/IDE/GHC/Compat.hs+188−33
@@ -7,23 +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,
19− ghcEnumerateExtensions,
28+ getModuleHash,
29+ getPackageName,
20 pattern DerivD,
30 pattern DerivD,
21 pattern ForD,
31 pattern ForD,
22 pattern InstD,
32 pattern InstD,
23 pattern TyClD,
33 pattern TyClD,
24 pattern ValD,
34 pattern ValD,
25 pattern ClassOpSig,
35 pattern ClassOpSig,
36+ pattern IEThingAll,
26 pattern IEThingWith,
37 pattern IEThingWith,
38+ GHC.ModLocation,
39+ Module.addBootSuffix,
40+ pattern ModLocation,
41+ getConArgs,
27
42
28 module GHC
43 module GHC
29 ) where
44 ) where
@@ -31,46 +46,62 @@ module Development.IDE.GHC.Compat(
31import StringBuffer
46import StringBuffer
32import DynFlags
47import DynFlags
33import FieldLabel
48import FieldLabel
34−import GHC.LanguageExtensions.Type
49+import Fingerprint (Fingerprint)
50+import qualified Module
51+import Packages
35
52
53+import qualified GHC
54+import GHC hiding (
55+ ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation
36−#if MIN_GHC_API_VERSION(8,8,0)
56+#if MIN_GHC_API_VERSION(8,6,0)
37−import Data.List.Extra (enumerate)
57+ , getConArgs
38#endif
58#endif
59+ )
60+import qualified HeaderInfo as Hdr
61+import Avail
62+import ErrUtils (ErrorMessages)
63+import FastString (FastString)
39
64
40−import qualified GHC
65+#if MIN_GHC_API_VERSION(8,10,0)
41−import GHC hiding (ClassOpSig, DerivD, ForD, IEThingWith, InstD, TyClD, ValD)
66+import HscTypes (mi_mod_hash)
67+#endif
42
68
43#if MIN_GHC_API_VERSION(8,8,0)
69#if MIN_GHC_API_VERSION(8,8,0)
44−import HieAst
70+import Control.Applicative ((<|>))
71+import Development.IDE.GHC.HieAst (mkHieFile)
45import HieBin
72import HieBin
46import HieTypes
73import HieTypes
74+
75+supportsHieFiles :: Bool
76+supportsHieFiles = True
77+
78+hieExportNames :: HieFile -> [(SrcSpan, Name)]
79+hieExportNames = nameListFromAvails . hie_exports
80+
47#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)
48−import GhcPlugins
92+import GhcPlugins hiding (ModLocation)
49import NameCache
93import NameCache
50−import Avail
51import TcRnTypes
94import TcRnTypes
52import System.IO
95import System.IO
53import Foreign.ForeignPtr
96import Foreign.ForeignPtr
97+import MkIface
54
98
55
99
56−#if !MIN_GHC_API_VERSION(8,8,0)
57hPutStringBuffer :: Handle -> StringBuffer -> IO ()
100hPutStringBuffer :: Handle -> StringBuffer -> IO ()
58hPutStringBuffer hdl (StringBuffer buf len cur)
101hPutStringBuffer hdl (StringBuffer buf len cur)
59 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->
102 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->
60 hPutBuf hdl ptr len
103 hPutBuf hdl ptr len
61−#endif
62−
63−mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile
64−mkHieFile _ _ _ = return (HieFile () [])
65−
66−writeHieFile :: FilePath -> HieFile -> IO ()
67−writeHieFile _ _ = return ()
68
104
69−readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())
70−readHieFile _ _ = return (HieFileResult (HieFile () []), ())
71−
72−data HieFile = HieFile {hie_module :: (), hie_exports :: [AvailInfo]}
73−data HieFileResult = HieFileResult { hie_file_result :: HieFile }
74#endif
105#endif
75
106
76#if !MIN_GHC_API_VERSION(8,6,0)
107#if !MIN_GHC_API_VERSION(8,6,0)
@@ -88,15 +119,6 @@ addIncludePathsQuote path x = x{includePaths = f $ includePaths x}
88addIncludePathsQuote path x = x{includePaths = path : includePaths x}
119addIncludePathsQuote path x = x{includePaths = path : includePaths x}
89#endif
120#endif
90
121
91−ghcEnumerateExtensions :: [Extension]
92−#if MIN_GHC_API_VERSION(8,8,0)
93−ghcEnumerateExtensions = enumerate
94−#elif MIN_GHC_API_VERSION(8,6,0)
95−ghcEnumerateExtensions = [Cpp .. StarIsType]
96−#else
97−ghcEnumerateExtensions = [Cpp .. EmptyDataDeriving]
98−#endif
99−
100pattern DerivD :: DerivDecl p -> HsDecl p
122pattern DerivD :: DerivDecl p -> HsDecl p
101pattern DerivD x <-
123pattern DerivD x <-
102#if MIN_GHC_API_VERSION(8,6,0)
124#if MIN_GHC_API_VERSION(8,6,0)
@@ -151,4 +173,137 @@ pattern IEThingWith a b c d <-
151 GHC.IEThingWith _ a b c d
173 GHC.IEThingWith _ a b c d
152#else
174#else
153 GHC.IEThingWith a b c d
175 GHC.IEThingWith a b c d
154−#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+28−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
@@ -17,6 +18,7 @@ module Development.IDE.GHC.Error
17 , zeroSpan
18 , zeroSpan
18 , realSpan
19 , realSpan
19 , isInsideSrcSpan
20 , isInsideSrcSpan
21+ , noSpan
20
22
21 -- * utilities working with severities
23 -- * utilities working with severities
22 , toDSeverity
24 , toDSeverity
@@ -35,11 +37,12 @@ import Panic
35import ErrUtils
37import ErrUtils
36import SrcLoc
38import SrcLoc
37import qualified Outputable as Out
39import qualified Outputable as Out
40+import Exception (ExceptionMonad)
38
41
39
42
40
43
41diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
44diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
42−diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,ShowDiag,)
45+diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename loc,ShowDiag,)
43 Diagnostic
46 Diagnostic
44 { _range = srcSpanToRange loc
47 { _range = srcSpanToRange loc
45 , _severity = Just sev
48 , _severity = Just sev
@@ -47,18 +50,39 @@ diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename
47 , _message = msg
50 , _message = msg
48 , _code = Nothing
51 , _code = Nothing
49 , _relatedInformation = Nothing
52 , _relatedInformation = Nothing
53+ , _tags = Nothing
50 }
54 }
51
55
52-- | 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.
53diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]
57diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]
54diagFromErrMsg diagSource dflags e =
58diagFromErrMsg diagSource dflags e =
55− [ 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
56 | Just sev <- [toDSeverity $ errMsgSeverity e]]
61 | Just sev <- [toDSeverity $ errMsgSeverity e]]
57
62
58
63
59diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
64diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
60diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList
65diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList
61
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
62
86
63-- | Convert a GHC SrcSpan to a DAML compiler Range
87-- | Convert a GHC SrcSpan to a DAML compiler Range
64srcSpanToRange :: SrcSpan -> Range
88srcSpanToRange :: SrcSpan -> Range
@@ -79,7 +103,7 @@ srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real
79srcSpanToLocation :: SrcSpan -> Location
103srcSpanToLocation :: SrcSpan -> Location
80srcSpanToLocation src =
104srcSpanToLocation src =
81 -- 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
82− Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath $ srcSpanToFilename src) (srcSpanToRange src)
106+ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ srcSpanToFilename src) (srcSpanToRange src)
83
107
84isInsideSrcSpan :: Position -> SrcSpan -> Bool
108isInsideSrcSpan :: Position -> SrcSpan -> Bool
85p `isInsideSrcSpan` r = sp <= p && p <= ep
109p `isInsideSrcSpan` r = sp <= p && p <= ep
@@ -126,7 +150,7 @@ realSpan = \case
126
150
127-- | 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
128-- compiler-internal exceptions like Panic or InstallationError).
152-- compiler-internal exceptions like Panic or InstallationError).
129−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)
130catchSrcErrors fromWhere ghcM = do
154catchSrcErrors fromWhere ghcM = do
131 dflags <- getDynFlags
155 dflags <- getDynFlags
132 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+146−65
@@ -1,65 +1,83 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4−{-# OPTIONS_GHC -Wno-missing-fields #-} -- to enable prettyPrint
4+-- | General utility functions, mostly focused around GHC operations.
5−{-# LANGUAGE CPP #-}
6−#include "ghc-api-version.h"
7−
8−-- | GHC utility functions. Importantly, code using our GHC should never:
9−--
10−-- * Call runGhc, use runGhcFast instead. It's faster and doesn't require config we don't have.
11−--
12−-- * Call setSessionDynFlags, use modifyDynFlags instead. It's faster and avoids loading packages.
13module Development.IDE.GHC.Util(
5module Development.IDE.GHC.Util(
14− lookupPackageConfig,
6+ -- * HcsEnv and environment
7+ HscEnvEq(GhcVersionMismatch, compileTime, runTime), hscEnv, newHscEnvEq,
15 modifyDynFlags,
8 modifyDynFlags,
16− fakeDynFlags,
9+ evalGhcEnv,
17− prettyPrint,
18 runGhcEnv,
10 runGhcEnv,
11+ deps,
12+ -- * GHC wrappers
13+ prettyPrint,
14+ printRdrName,
15+ printName,
16+ ParseResult(..), runParser,
17+ lookupPackageConfig,
19 textToStringBuffer,
18 textToStringBuffer,
19+ stringBufferToByteString,
20 moduleImportPath,
20 moduleImportPath,
21− HscEnvEq, hscEnv, newHscEnvEq,
21+ cgGutsToCoreModule,
22+ fingerprintToBS,
23+ fingerprintFromStringBuffer,
24+ -- * General utilities
22 readFileUtf8,
25 readFileUtf8,
23 hDuplicateTo',
26 hDuplicateTo',
24− cgGutsToCoreModule
27+ setDefaultHieDir,
28+ dontWriteHieFiles
25 ) where
29 ) where
26
30
27−import Config
28import Control.Concurrent
31import Control.Concurrent
29import Data.List.Extra
32import Data.List.Extra
33+import Data.ByteString.Internal (ByteString(..))
30import Data.Maybe
34import Data.Maybe
31import Data.Typeable
35import Data.Typeable
32−#if MIN_GHC_API_VERSION(8,6,0)
36+import qualified Data.ByteString.Internal as BS
33import Fingerprint
37import Fingerprint
34−#endif
35−import GHC
36import GhcMonad
38import GhcMonad
37−import GhcPlugins hiding (Unique)
38−import Data.IORef
39import Control.Exception
39import Control.Exception
40+import Data.IORef
41+import Data.Version (showVersion, Version)
40import FileCleanup
42import FileCleanup
43+import Foreign.Ptr
44+import Foreign.ForeignPtr
45+import Foreign.Storable
41import GHC.IO.BufferedIO (BufferedIO)
46import GHC.IO.BufferedIO (BufferedIO)
42import GHC.IO.Device as IODevice
47import GHC.IO.Device as IODevice
43import GHC.IO.Encoding
48import GHC.IO.Encoding
44import GHC.IO.Exception
49import GHC.IO.Exception
45import GHC.IO.Handle.Types
50import GHC.IO.Handle.Types
46import GHC.IO.Handle.Internals
51import GHC.IO.Handle.Internals
47−import Platform
48import Data.Unique
52import Data.Unique
49import Development.Shake.Classes
53import Development.Shake.Classes
50import qualified Data.Text as T
54import qualified Data.Text as T
51import qualified Data.Text.Encoding as T
55import qualified Data.Text.Encoding as T
52import qualified Data.Text.Encoding.Error as T
56import qualified Data.Text.Encoding.Error as T
53import qualified Data.ByteString as BS
57import qualified Data.ByteString as BS
58+import Lexer
54import StringBuffer
59import StringBuffer
55import System.FilePath
60import System.FilePath
61+import HscTypes (cg_binds, md_types, cg_module, ModDetails, CgGuts, ic_dflags, hsc_IC, HscEnv(hsc_dflags))
62+import PackageConfig (PackageConfig)
63+import Outputable (showSDocUnsafe, ppr, showSDoc, Outputable)
64+import Packages (getPackageConfigMap, lookupPackage')
65+import SrcLoc (mkRealSrcLoc)
66+import FastString (mkFastString)
67+import DynFlags (emptyFilesToClean, unsafeGlobalDynFlags)
68+import Module (moduleNameSlashes, InstalledUnitId)
69+import OccName (parenSymOcc)
70+import RdrName (nameRdrName, rdrNameOcc)
56
71
72+import Development.IDE.GHC.Compat as GHC
57import Development.IDE.Types.Location
73import Development.IDE.Types.Location
58
74
59
75
60----------------------------------------------------------------------
76----------------------------------------------------------------------
61-- GHC setup
77-- GHC setup
62
78
79+-- | Used to modify dyn flags in preference to calling 'setSessionDynFlags',
80+-- since that function also reloads packages (which is very slow).
63modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()
81modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()
64modifyDynFlags f = do
82modifyDynFlags f = do
65 newFlags <- f <$> getSessionDynFlags
83 newFlags <- f <$> getSessionDynFlags
@@ -68,6 +86,7 @@ modifyDynFlags f = do
68 modifySession $ \h ->
86 modifySession $ \h ->
69 h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} }
87 h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} }
70
88
89+-- | Given a 'UnitId' try and find the associated 'PackageConfig' in the environment.
71lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig
90lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig
72lookupPackageConfig unitId env =
91lookupPackageConfig unitId env =
73 lookupPackage' False pkgConfigMap unitId
92 lookupPackage' False pkgConfigMap unitId
@@ -78,86 +97,134 @@ lookupPackageConfig unitId env =
78 getPackageConfigMap $ hsc_dflags env
97 getPackageConfigMap $ hsc_dflags env
79
98
80
99
81−-- would be nice to do this more efficiently...
100+-- | Convert from the @text@ package to the @GHC@ 'StringBuffer'.
101+-- Currently implemented somewhat inefficiently (if it ever comes up in a profile).
82textToStringBuffer :: T.Text -> StringBuffer
102textToStringBuffer :: T.Text -> StringBuffer
83textToStringBuffer = stringToStringBuffer . T.unpack
103textToStringBuffer = stringToStringBuffer . T.unpack
84
104
105+runParser :: DynFlags -> String -> P a -> ParseResult a
106+runParser flags str parser = unP parser parseState
107+ where
108+ filename = "<interactive>"
109+ location = mkRealSrcLoc (mkFastString filename) 1 1
110+ buffer = stringToStringBuffer str
111+ parseState = mkPState flags buffer location
112+
113+stringBufferToByteString :: StringBuffer -> ByteString
114+stringBufferToByteString StringBuffer{..} = PS buf cur len
85
115
116+-- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.
86prettyPrint :: Outputable a => a -> String
117prettyPrint :: Outputable a => a -> String
87−prettyPrint = showSDoc fakeDynFlags . ppr
118+prettyPrint = showSDoc unsafeGlobalDynFlags . ppr
119+
120+-- | Pretty print a 'RdrName' wrapping operators in parens
121+printRdrName :: RdrName -> String
122+printRdrName name = showSDocUnsafe $ parenSymOcc rn (ppr rn)
123+ where
124+ rn = rdrNameOcc name
88
125
126+-- | Pretty print a 'Name' wrapping operators in parens
127+printName :: Name -> String
128+printName = printRdrName . nameRdrName
129+
130+-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required
131+-- pieces, but designed to be more efficient than a standard 'runGhc'.
132+evalGhcEnv :: HscEnv -> Ghc b -> IO b
133+evalGhcEnv env act = snd <$> runGhcEnv env act
134+
135+-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required
136+-- pieces, but designed to be more efficient than a standard 'runGhc'.
89−runGhcEnv :: HscEnv -> Ghc a -> IO a
137+runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a)
90runGhcEnv env act = do
138runGhcEnv env act = do
91 filesToClean <- newIORef emptyFilesToClean
139 filesToClean <- newIORef emptyFilesToClean
92 dirsToClean <- newIORef mempty
140 dirsToClean <- newIORef mempty
93 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}
141 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}
94 ref <- newIORef env{hsc_dflags=dflags}
142 ref <- newIORef env{hsc_dflags=dflags}
95− unGhc act (Session ref) `finally` do
143+ res <- unGhc act (Session ref) `finally` do
96 cleanTempFiles dflags
144 cleanTempFiles dflags
97 cleanTempDirs dflags
145 cleanTempDirs dflags
146+ (,res) <$> readIORef ref
98
147
99−-- Fake DynFlags which are mostly undefined, but define enough to do a
148+-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.
100−-- little bit.
149+-- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory
101−fakeDynFlags :: DynFlags
150+-- @\/usr\/Test@ should be on the include path to find sibling modules.
102−fakeDynFlags = defaultDynFlags settings mempty
103− where
104− settings = Settings
105− { sTargetPlatform = platform
106− , sPlatformConstants = platformConstants
107− , sProgramName = "ghc"
108− , sProjectVersion = cProjectVersion
109−#if MIN_GHC_API_VERSION(8,6,0)
110− , sOpt_P_fingerprint = fingerprint0
111−#endif
112− }
113− platform = Platform
114− { platformWordSize=8
115− , platformOS=OSUnknown
116− , platformUnregisterised=True
117− }
118− platformConstants = PlatformConstants
119− { pc_DYNAMIC_BY_DEFAULT=False
120− , pc_WORD_SIZE=8
121− }
122−
123−moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath
151+moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath
124-- The call to takeDirectory is required since DAML does not require that
152-- The call to takeDirectory is required since DAML does not require that
125-- the file name matches the module name in the last component.
153-- the file name matches the module name in the last component.
126-- Once that has changed we can get rid of this.
154-- Once that has changed we can get rid of this.
127−moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm
155+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn
128 -- This happens for single-component modules since takeDirectory "A" == "."
156 -- This happens for single-component modules since takeDirectory "A" == "."
129 | modDir == "." = Just pathDir
157 | modDir == "." = Just pathDir
130 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir
158 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir
131 where
159 where
132− ms = GHC.pm_mod_summary pm
133− mod' = GHC.ms_mod ms
134 -- A for module A.B
160 -- A for module A.B
135 modDir =
161 modDir =
136 takeDirectory $
162 takeDirectory $
137− fromNormalizedFilePath $ toNormalizedFilePath $
163+ fromNormalizedFilePath $ toNormalizedFilePath' $
138− moduleNameSlashes $ GHC.moduleName mod'
164+ moduleNameSlashes mn
139
165
140−-- | An HscEnv with equality.
166+-- | An 'HscEnv' with equality. Two values are considered equal
167+-- if they are created with the same call to 'newHscEnvEq'.
168+data HscEnvEq
141−data HscEnvEq = HscEnvEq Unique HscEnv
169+ = HscEnvEq !Unique !HscEnv
170+ [(InstalledUnitId, DynFlags)] -- In memory components for this HscEnv
171+ -- This is only used at the moment for the import dirs in
172+ -- the DynFlags
173+ | GhcVersionMismatch { compileTime :: !Version
174+ , runTime :: !Version
175+ }
142
176
177+-- | Unwrap an 'HsEnvEq'.
143hscEnv :: HscEnvEq -> HscEnv
178hscEnv :: HscEnvEq -> HscEnv
179+hscEnv = either error id . hscEnv'
180+
181+hscEnv' :: HscEnvEq -> Either String HscEnv
144−hscEnv (HscEnvEq _ x) = x
182+hscEnv' (HscEnvEq _ x _) = Right x
183+hscEnv' GhcVersionMismatch{..} = Left $
184+ unwords
185+ ["ghcide compiled against GHC"
186+ ,showVersion compileTime
187+ ,"but currently using"
188+ ,showVersion runTime
189+ ,". This is unsupported, ghcide must be compiled with the same GHC version as the project."
190+ ]
191+
192+deps :: HscEnvEq -> [(InstalledUnitId, DynFlags)]
193+deps (HscEnvEq _ _ u) = u
194+deps GhcVersionMismatch{} = []
145
195
196+-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
146−newHscEnvEq :: HscEnv -> IO HscEnvEq
197+newHscEnvEq :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
147−newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e
198+newHscEnvEq e uids = do u <- newUnique; return $ HscEnvEq u e uids
148
199
149instance Show HscEnvEq where
200instance Show HscEnvEq where
150− show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)
201+ show (HscEnvEq a _ _) = "HscEnvEq " ++ show (hashUnique a)
202+ show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)
151
203
152instance Eq HscEnvEq where
204instance Eq HscEnvEq where
153− HscEnvEq a _ == HscEnvEq b _ = a == b
205+ HscEnvEq a _ _ == HscEnvEq b _ _ = a == b
206+ GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d
207+ _ == _ = False
154
208
155instance NFData HscEnvEq where
209instance NFData HscEnvEq where
156− rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()
210+ rnf (HscEnvEq a b c) = rnf (hashUnique a) `seq` b `seq` c `seq` ()
211+ rnf GhcVersionMismatch{} = rnf runTime
157
212
213+instance Hashable HscEnvEq where
214+ hashWithSalt s (HscEnvEq a _b _c) = hashWithSalt s a
215+ hashWithSalt salt GhcVersionMismatch{..} = hashWithSalt salt (compileTime, runTime)
216+
217+-- Fake instance needed to persuade Shake to accept this type as a key.
218+-- No harm done as ghcide never persists these keys currently
219+instance Binary HscEnvEq where
220+ put _ = error "not really"
221+ get = error "not really"
222+
223+-- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error.
158readFileUtf8 :: FilePath -> IO T.Text
224readFileUtf8 :: FilePath -> IO T.Text
159readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f
225readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f
160
226
227+-- | Convert from a 'CgGuts' to a 'CoreModule'.
161cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule
228cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule
162cgGutsToCoreModule safeMode guts modDetails = CoreModule
229cgGutsToCoreModule safeMode guts modDetails = CoreModule
163 (cg_module guts)
230 (cg_module guts)
@@ -165,8 +232,22 @@ cgGutsToCoreModule safeMode guts modDetails = CoreModule
165 (cg_binds guts)
232 (cg_binds guts)
166 safeMode
233 safeMode
167
234
235+-- | Convert a 'Fingerprint' to a 'ByteString' by copying the byte across.
236+-- Will produce an 8 byte unreadable ByteString.
237+fingerprintToBS :: Fingerprint -> BS.ByteString
238+fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do
239+ ptr <- pure $ castPtr ptr
240+ pokeElemOff ptr 0 a
241+ pokeElemOff ptr 1 b
242+
243+-- | Take the 'Fingerprint' of a 'StringBuffer'.
244+fingerprintFromStringBuffer :: StringBuffer -> IO Fingerprint
245+fingerprintFromStringBuffer (StringBuffer buf len cur) =
246+ withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len
247+
248+
168−-- This is a slightly modified version of hDuplicateTo in GHC.
249+-- | A slightly modified version of 'hDuplicateTo' from GHC.
169−-- See the inline comment for more details.
250+-- Importantly, it avoids the bug listed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2318.
170hDuplicateTo' :: Handle -> Handle -> IO ()
251hDuplicateTo' :: Handle -> Handle -> IO ()
171hDuplicateTo' h1@(FileHandle path m1) h2@(FileHandle _ m2) = do
252hDuplicateTo' h1@(FileHandle path m1) h2@(FileHandle _ m2) = do
172 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
253 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
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/Completions.hsdeleted−51
@@ -1,51 +0,0 @@
1−module Development.IDE.LSP.Completions (
2− setHandlersCompletion
3−) where
4−
5−import Language.Haskell.LSP.Messages
6−import Language.Haskell.LSP.Types
7−import qualified Language.Haskell.LSP.Core as LSP
8−import qualified Language.Haskell.LSP.VFS as VFS
9−import Language.Haskell.LSP.Types.Capabilities
10−
11−import Development.IDE.Core.Service
12−import Development.IDE.Core.Completions
13−import Development.IDE.Types.Location
14−import Development.IDE.Core.PositionMapping
15−import Development.IDE.Core.RuleTypes
16−import Development.IDE.Core.Shake
17−import Development.IDE.LSP.Server
18−
19−-- | Generate code actions.
20−getCompletionsLSP
21− :: LSP.LspFuncs ()
22− -> IdeState
23− -> CompletionParams
24− -> IO CompletionResponseResult
25−getCompletionsLSP lsp ide
26− CompletionParams{_textDocument=TextDocumentIdentifier uri
27− ,_position=position
28− ,_context=completionContext} = do
29− contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
30− case (contents, uriToFilePath' uri) of
31− (Just cnts, Just path) -> do
32− let npath = toNormalizedFilePath path
33− (ideOpts, compls) <- runAction ide ((,) <$> getIdeOptions <*> useWithStale ProduceCompletions npath)
34− case compls of
35− Just ((cci', tm'), mapping) -> do
36− let position' = fromCurrentPosition mapping position
37− pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'
38− case (pfix, completionContext) of
39− (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
40− -> return (Completions $ List [])
41− (Just pfix', _) -> do
42− let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing
43− Completions . List <$> getCompletions ideOpts cci' (tmrModule tm') pfix' fakeClientCapabilities (WithSnippets True)
44− _ -> return (Completions $ List [])
45− _ -> return (Completions $ List [])
46− _ -> return (Completions $ List [])
47−
48−setHandlersCompletion :: PartialHandlers
49−setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{
50− LSP.completionHandler = withResponse RspCompletion getCompletionsLSP
51− }
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−32
@@ -28,23 +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
32−import Development.IDE.LSP.CodeAction
33−import Development.IDE.LSP.Completions
34import Development.IDE.LSP.Notifications
34import Development.IDE.LSP.Notifications
35import Development.IDE.LSP.Outline
35import Development.IDE.LSP.Outline
36−import Development.IDE.Core.Service
37import Development.IDE.Types.Logger
36import Development.IDE.Types.Logger
38import Development.IDE.Core.FileStore
37import Development.IDE.Core.FileStore
39import Language.Haskell.LSP.Core (LspFuncs(..))
38import Language.Haskell.LSP.Core (LspFuncs(..))
40import Language.Haskell.LSP.Messages
39import Language.Haskell.LSP.Messages
41
40
42runLanguageServer
41runLanguageServer
42+ :: forall config. (Show config)
43− :: LSP.Options
43+ => LSP.Options
44− -> PartialHandlers
44+ -> PartialHandlers config
45+ -> (InitializeRequest -> Either T.Text config)
46+ -> (DidChangeConfigurationNotification -> Either T.Text config)
45 -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)
47 -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)
46 -> IO ()
48 -> IO ()
47−runLanguageServer options userHandlers getIdeState = do
49+runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do
48 -- Move stdout to another file descriptor and duplicate stderr
50 -- Move stdout to another file descriptor and duplicate stderr
49 -- 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
50 -- message stream.
52 -- message stream.
@@ -61,7 +63,7 @@ runLanguageServer options userHandlers getIdeState = do
61
63
62 -- 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
63 -- LspFuncs is available
65 -- LspFuncs is available
64− clientMsgChan :: Chan Message <- newChan
66+ clientMsgChan :: Chan (Message config) <- newChan
65
67
66 -- 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.
67 -- 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
@@ -80,6 +82,7 @@ runLanguageServer options userHandlers getIdeState = do
80 let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do
82 let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do
81 atomically $ modifyTVar pendingRequests (Set.insert _id)
83 atomically $ modifyTVar pendingRequests (Set.insert _id)
82 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)
83 let cancelRequest reqId = atomically $ do
86 let cancelRequest reqId = atomically $ do
84 queued <- readTVar pendingRequests
87 queued <- readTVar pendingRequests
85 -- We want to avoid that the list of cancelled requests
88 -- We want to avoid that the list of cancelled requests
@@ -96,21 +99,20 @@ runLanguageServer options userHandlers getIdeState = do
96 cancelled <- readTVar cancelledRequests
99 cancelled <- readTVar cancelledRequests
97 unless (reqId `Set.member` cancelled) retry
100 unless (reqId `Set.member` cancelled) retry
98 let PartialHandlers parts =
101 let PartialHandlers parts =
102+ initializeRequestHandler <>
99 setHandlersIgnore <> -- least important
103 setHandlersIgnore <> -- least important
100 setHandlersDefinition <> setHandlersHover <>
104 setHandlersDefinition <> setHandlersHover <>
101− setHandlersCodeAction <> setHandlersCodeLens <> -- useful features someone may override
102− setHandlersCompletion <>
103 setHandlersOutline <>
105 setHandlersOutline <>
104 userHandlers <>
106 userHandlers <>
105 setHandlersNotifications <> -- absolutely critical, join them with user notifications
107 setHandlersNotifications <> -- absolutely critical, join them with user notifications
106 cancelHandler cancelRequest
108 cancelHandler cancelRequest
107 -- Cancel requests are special since they need to be handled
109 -- Cancel requests are special since they need to be handled
108 -- out of order to be useful. Existing handlers are run afterwards.
110 -- out of order to be useful. Existing handlers are run afterwards.
109− handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def
111+ handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def
110
112
111 let initializeCallbacks = LSP.InitializeCallbacks
113 let initializeCallbacks = LSP.InitializeCallbacks
112− { LSP.onInitialConfiguration = const $ Right ()
114+ { LSP.onInitialConfiguration = onInitialConfig
113− , LSP.onConfigurationChange = const $ Right ()
115+ , LSP.onConfigurationChange = onConfigChange
114 , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan
116 , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan
115 }
117 }
116
118
@@ -125,9 +127,11 @@ runLanguageServer options userHandlers getIdeState = do
125 , void $ waitBarrier clientMsgBarrier
127 , void $ waitBarrier clientMsgBarrier
126 ]
128 ]
127 where
129 where
128− 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)
129 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
131 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
132+
130 ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities
133 ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities
134+
131 _ <- flip forkFinally (const exitClientMsg) $ forever $ do
135 _ <- flip forkFinally (const exitClientMsg) $ forever $ do
132 msg <- readChan clientMsgChan
136 msg <- readChan clientMsgChan
133 case msg of
137 case msg of
@@ -138,17 +142,25 @@ runLanguageServer options userHandlers getIdeState = do
138 "Message: " ++ show x ++ "\n" ++
142 "Message: " ++ show x ++ "\n" ++
139 "Exception: " ++ show e
143 "Exception: " ++ show e
140 Response x@RequestMessage{_id, _params} wrap act ->
144 Response x@RequestMessage{_id, _params} wrap act ->
141− checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
145+ checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
146+ \case
142− \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)
143 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->
149 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->
144 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
150 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
145 \(res, newReq) -> do
151 \(res, newReq) -> do
146− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
152+ case res of
147− case newReq of
153+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)
148− Nothing -> return ()
154+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)
149− Just (rm, newReqParams) -> do
155+ whenJust newReq $ \(rm, newReqParams) -> do
150 reqId <- getNextReqId
156 reqId <- getNextReqId
151 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
152 pure Nothing
164 pure Nothing
153
165
154 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 =
@@ -163,28 +175,39 @@ runLanguageServer options userHandlers getIdeState = do
163 Left () -> do
175 Left () -> do
164 logDebug (ideLogger ide) $ T.pack $
176 logDebug (ideLogger ide) $ T.pack $
165 "Cancelled request " <> show _id
177 "Cancelled request " <> show _id
166− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
178+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left
167− Just $ ResponseError RequestCancelled "" Nothing
179+ $ ResponseError RequestCancelled "" Nothing
168 Right res -> k res
180 Right res -> k res
169 ) $ \(e :: SomeException) -> do
181 ) $ \(e :: SomeException) -> do
170 logError (ideLogger ide) $ T.pack $
182 logError (ideLogger ide) $ T.pack $
171 "Unexpected exception on request, please report!\n" ++
183 "Unexpected exception on request, please report!\n" ++
172 "Message: " ++ show msg ++ "\n" ++
184 "Message: " ++ show msg ++ "\n" ++
173 "Exception: " ++ show e
185 "Exception: " ++ show e
174− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
186+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left
175− Just $ ResponseError InternalError (T.pack $ show e) Nothing
187+ $ ResponseError InternalError (T.pack $ show e) Nothing
176
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)
177
200
178-- | 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.
179-- Set them to avoid a warning in VS Code output.
202-- Set them to avoid a warning in VS Code output.
180−setHandlersIgnore :: PartialHandlers
203+setHandlersIgnore :: PartialHandlers config
181setHandlersIgnore = PartialHandlers $ \_ x -> return x
204setHandlersIgnore = PartialHandlers $ \_ x -> return x
182 {LSP.initializedHandler = none
205 {LSP.initializedHandler = none
183 ,LSP.responseHandler = none
206 ,LSP.responseHandler = none
184 }
207 }
185 where none = Just $ const $ return ()
208 where none = Just $ const $ return ()
186
209
187−cancelHandler :: (LspId -> IO ()) -> PartialHandlers
210+cancelHandler :: (LspId -> IO ()) -> PartialHandlers config
188cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
211cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
189 {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do
212 {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do
190 cancelRequest _id
213 cancelRequest _id
@@ -194,19 +217,18 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x
194
217
195-- | 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
196-- 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)
197−data Message
220+data Message c
198− = 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))
199 -- | 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,
200 -- but also an additional request to the client.
223 -- but also an additional request to the client.
201 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
224 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
202− | 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)))
203− | 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 ())
204−
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 ())
205
229
206modifyOptions :: LSP.Options -> LSP.Options
230modifyOptions :: LSP.Options -> LSP.Options
207modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS
231modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS
208− , LSP.executeCommandCommands = Just ["typesignature.add"]
209− , LSP.completionTriggerCharacters = Just "."
210 }
232 }
211 where
233 where
212 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.hsnew file+60
@@ -0,0 +1,60 @@
1+
2+module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules,makeLspCommandId,getPid) where
3+
4+import Data.Default
5+import qualified Data.Text as T
6+import Development.Shake
7+import Development.IDE.LSP.Server
8+
9+import Language.Haskell.LSP.Types
10+import Development.IDE.Compat
11+import Development.IDE.Core.Rules
12+import qualified Language.Haskell.LSP.Core as LSP
13+import Language.Haskell.LSP.Messages
14+
15+
16+data Plugin c = Plugin
17+ {pluginRules :: Rules ()
18+ ,pluginHandler :: PartialHandlers c
19+ }
20+
21+instance Default (Plugin c) where
22+ def = Plugin mempty def
23+
24+instance Semigroup (Plugin c) where
25+ Plugin x1 y1 <> Plugin x2 y2 = Plugin (x1<>x2) (y1<>y2)
26+
27+instance Monoid (Plugin c) where
28+ mempty = def
29+
30+
31+codeActionPlugin :: (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c
32+codeActionPlugin = codeActionPluginWithRules mempty
33+
34+codeActionPluginWithRules :: Rules () -> (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c
35+codeActionPluginWithRules rr f = Plugin rr $ PartialHandlers $ \WithMessage{..} x -> return x{
36+ LSP.codeActionHandler = withResponse RspCodeAction g
37+ }
38+ where
39+ g lsp state (CodeActionParams a b c _) = fmap List <$> f lsp state a b c
40+
41+-- | Prefix to uniquely identify commands sent to the client. This
42+-- has two parts
43+--
44+-- - A representation of the process id to make sure that a client has
45+-- unique commands if it is running multiple servers, since some
46+-- clients have a global command table and get confused otherwise.
47+--
48+-- - A string to identify ghcide, to ease integration into
49+-- haskell-language-server, which routes commands to plugins based
50+-- on that.
51+makeLspCommandId :: T.Text -> IO T.Text
52+makeLspCommandId command = do
53+ pid <- getPid
54+ return $ pid <> ":ghcide:" <> command
55+
56+-- | Get the operating system process id for the running server
57+-- instance. This should be the same for the lifetime of the instance,
58+-- and different from that of any other currently running instance.
59+getPid :: IO T.Text
60+getPid = T.pack . show <$> getProcessID
src/Development/IDE/LSP/CodeAction.hs → src/Development/IDE/Plugin/CodeAction.hsrenamed+177−112
@@ -6,24 +6,35 @@
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.LSP.CodeAction
9+module Development.IDE.Plugin.CodeAction
10− ( setHandlersCodeAction
10+ (
11− , setHandlersCodeLens
11+ plugin
12+
13+ -- * For haskell-language-server
14+ , codeAction
15+ , codeLens
16+ , rulePackageExports
17+ , executeAddSignatureCommand
12 ) where
18 ) where
13
19
14import Language.Haskell.LSP.Types
20import Language.Haskell.LSP.Types
15import Control.Monad (join)
21import Control.Monad (join)
22+import Development.IDE.Plugin
16import Development.IDE.GHC.Compat
23import Development.IDE.GHC.Compat
17import Development.IDE.Core.Rules
24import Development.IDE.Core.Rules
18import Development.IDE.Core.RuleTypes
25import Development.IDE.Core.RuleTypes
19import Development.IDE.Core.Service
26import Development.IDE.Core.Service
20import Development.IDE.Core.Shake
27import Development.IDE.Core.Shake
21import Development.IDE.GHC.Error
28import Development.IDE.GHC.Error
29+import Development.IDE.GHC.Util
22import 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
23import Development.IDE.Types.Location
34import Development.IDE.Types.Location
24import Development.IDE.Types.Options
35import Development.IDE.Types.Options
36+import Development.Shake (Rules)
25import qualified Data.HashMap.Strict as Map
37import qualified Data.HashMap.Strict as Map
26−import qualified Data.HashSet as Set
27import qualified Language.Haskell.LSP.Core as LSP
38import qualified Language.Haskell.LSP.Core as LSP
28import Language.Haskell.LSP.VFS
39import Language.Haskell.LSP.VFS
29import Language.Haskell.LSP.Messages
40import Language.Haskell.LSP.Messages
@@ -34,69 +45,98 @@ import Data.Char
34import Data.Maybe
45import Data.Maybe
35import Data.List.Extra
46import Data.List.Extra
36import qualified Data.Text as T
47import qualified Data.Text as T
48+import Data.Tuple.Extra ((&&&))
49+import HscTypes
50+import Parser
37import Text.Regex.TDFA ((=~), (=~~))
51import Text.Regex.TDFA ((=~), (=~~))
38import Text.Regex.TDFA.Text()
52import Text.Regex.TDFA.Text()
39import Outputable (ppr, showSDocUnsafe)
53import Outputable (ppr, showSDocUnsafe)
54+import DynFlags (xFlags, FlagSpec(..))
55+import GHC.LanguageExtensions.Type (Extension)
56+
57+plugin :: Plugin c
58+plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens
59+
60+rules :: Rules ()
61+rules = rulePackageExports
40
62
41-- | Generate code actions.
63-- | Generate code actions.
42codeAction
64codeAction
43− :: LSP.LspFuncs ()
65+ :: LSP.LspFuncs c
44 -> IdeState
66 -> IdeState
45− -> CodeActionParams
67+ -> TextDocumentIdentifier
68+ -> Range
69+ -> CodeActionContext
46− -> IO (List CAResult)
70+ -> IO (Either ResponseError [CAResult])
47−codeAction lsp state CodeActionParams{_textDocument=TextDocumentIdentifier uri,_context=CodeActionContext{_diagnostics=List xs}} = do
71+codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do
48 -- disable logging as its quite verbose
72 -- disable logging as its quite verbose
49 -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg
73 -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg
50 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
74 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
51 let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
75 let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
76+ mbFile = toNormalizedFilePath' <$> uriToFilePath uri
52− (ideOptions, parsedModule) <- runAction state $
77+ (ideOptions, parsedModule, join -> env) <- runAction state $
53− (,) <$> getIdeOptions
78+ (,,) <$> getIdeOptions
54− <*> (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
55− pure $ List
83+ pure $ Right
56 [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
84 [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
57− | 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
58 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
86 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
59 ]
87 ]
60
88
61-- | Generate code lenses.
89-- | Generate code lenses.
62codeLens
90codeLens
63− :: LSP.LspFuncs ()
91+ :: LSP.LspFuncs c
64 -> IdeState
92 -> IdeState
65 -> CodeLensParams
93 -> CodeLensParams
66− -> IO (List CodeLens)
94+ -> IO (Either ResponseError (List CodeLens))
67codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
95codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
96+ commandId <- makeLspCommandId "typesignature.add"
68− case uriToFilePath' uri of
97+ fmap (Right . List) $ case uriToFilePath' uri of
69− Just (toNormalizedFilePath -> filePath) -> do
98+ Just (toNormalizedFilePath' -> filePath) -> do
70 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
99 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
71 diag <- getDiagnostics ideState
100 diag <- getDiagnostics ideState
72 hDiag <- getHiddenDiagnostics ideState
101 hDiag <- getHiddenDiagnostics ideState
73− pure $ List
102+ pure
74− [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing
103+ [ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing
75− | (dFile, _, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag ++ hDiag
104+ | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag
76 , dFile == filePath
105 , dFile == filePath
77 , (title, tedit) <- suggestSignature False dDiag
106 , (title, tedit) <- suggestSignature False dDiag
78 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
107 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
79 ]
108 ]
80− Nothing -> pure $ List []
109+ Nothing -> pure []
81
110
82-- | Execute the "typesignature.add" command.
111-- | Execute the "typesignature.add" command.
83executeAddSignatureCommand
112executeAddSignatureCommand
84− :: LSP.LspFuncs ()
113+ :: LSP.LspFuncs c
85 -> IdeState
114 -> IdeState
86 -> ExecuteCommandParams
115 -> ExecuteCommandParams
87− -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
116+ -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
88executeAddSignatureCommand _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.
89− | _command == "typesignature.add"
122+ | T.isSuffixOf "typesignature.add" _command
90 , Just (List [edit]) <- _arguments
123 , Just (List [edit]) <- _arguments
91− , Success wedit <- fromJSON edit
124+ , Success wedit <- fromJSON edit
92− = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
125+ = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
93 | otherwise
126 | otherwise
94− = return (Null, Nothing)
127+ = return (Right Null, Nothing)
95−
128+
96−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])]
97−suggestAction ideOptions parsedModule text diag = concat
137+suggestAction dflags packageExports ideOptions parsedModule text diag = concat
98 [ suggestAddExtension diag
138 [ suggestAddExtension diag
99− , suggestExtendImport text diag
139+ , suggestExtendImport dflags text diag
100 , suggestFillHole diag
140 , suggestFillHole diag
101 , suggestFillTypeWildcard diag
141 , suggestFillTypeWildcard diag
102 , suggestFixConstructorImport text diag
142 , suggestFixConstructorImport text diag
@@ -106,17 +146,19 @@ suggestAction ideOptions parsedModule text diag = concat
106 ] ++ concat
146 ] ++ concat
107 [ suggestNewDefinition ideOptions pm text diag
147 [ suggestNewDefinition ideOptions pm text diag
108 ++ suggestRemoveRedundantImport pm text diag
148 ++ suggestRemoveRedundantImport pm text diag
149+ ++ suggestNewImport packageExports pm diag
109 | Just pm <- [parsedModule]]
150 | Just pm <- [parsedModule]]
110
151
111
152
112suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
153suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
113−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,..}
114-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant
155-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant
115 | 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"
116 , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports
157 , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports
117 , Just c <- contents
158 , Just c <- contents
118 , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)
159 , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)
119 , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)
160 , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)
161+ , not (null ranges')
120 = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]
162 = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]
121
163
122-- File.hs:16:1: warning:
164-- File.hs:16:1: warning:
@@ -128,7 +170,7 @@ suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmod
128 | otherwise = []
170 | otherwise = []
129
171
130suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
172suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
131−suggestReplaceIdentifier contents Diagnostic{_range=_range@Range{..},..}
173+suggestReplaceIdentifier contents Diagnostic{_range=_range,..}
132-- File.hs:52:41: error:
174-- File.hs:52:41: error:
133-- * Variable not in scope:
175-- * Variable not in scope:
134-- suggestAcion :: Maybe T.Text -> Range -> Range
176-- suggestAcion :: Maybe T.Text -> Range -> Range
@@ -175,7 +217,7 @@ newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ
175
217
176
218
177suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]
219suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]
178−suggestFillTypeWildcard Diagnostic{_range=_range@Range{..},..}
220+suggestFillTypeWildcard Diagnostic{_range=_range,..}
179-- Foo.hs:3:8: error:
221-- Foo.hs:3:8: error:
180-- * Found type wildcard `_' standing for `p -> p1 -> p'
222-- * Found type wildcard `_' standing for `p -> p1 -> p'
181
223
@@ -186,7 +228,7 @@ suggestFillTypeWildcard Diagnostic{_range=_range@Range{..},..}
186 | otherwise = []
228 | otherwise = []
187
229
188suggestAddExtension :: Diagnostic -> [(T.Text, [TextEdit])]
230suggestAddExtension :: Diagnostic -> [(T.Text, [TextEdit])]
189−suggestAddExtension Diagnostic{_range=_range@Range{..},..}
231+suggestAddExtension Diagnostic{_range=_range,..}
190-- File.hs:22:8: error:
232-- File.hs:22:8: error:
191-- Illegal lambda-case (use -XLambdaCase)
233-- Illegal lambda-case (use -XLambdaCase)
192-- File.hs:22:6: error:
234-- File.hs:22:6: error:
@@ -207,12 +249,16 @@ suggestAddExtension Diagnostic{_range=_range@Range{..},..}
207-- * In the context: a ~ ()
249-- * In the context: a ~ ()
208-- While checking an instance declaration
250-- While checking an instance declaration
209-- In the instance declaration for `Unit (m a)'
251-- In the instance declaration for `Unit (m a)'
210− | exts@(_:_) <- filter (`Set.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message
252+ | exts@(_:_) <- filter (`Map.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message
211 = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts]
253 = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts]
212 | otherwise = []
254 | otherwise = []
213
255
256+-- | All the GHC extensions
257+ghcExtensions :: Map.HashMap T.Text Extension
258+ghcExtensions = Map.fromList . map ( ( T.pack . flagSpecName ) &&& flagSpecFlag ) $ xFlags
259+
214suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]
260suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]
215−suggestModuleTypo Diagnostic{_range=_range@Range{..},..}
261+suggestModuleTypo Diagnostic{_range=_range,..}
216-- src/Development/IDE/Core/Compile.hs:58:1: error:
262-- src/Development/IDE/Core/Compile.hs:58:1: error:
217-- Could not find module ‘Data.Cha’
263-- Could not find module ‘Data.Cha’
218-- Perhaps you meant Data.Char (from base-4.12.0.0)
264-- Perhaps you meant Data.Char (from base-4.12.0.0)
@@ -224,7 +270,7 @@ suggestModuleTypo Diagnostic{_range=_range@Range{..},..}
224 | otherwise = []
270 | otherwise = []
225
271
226suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])]
272suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])]
227−suggestFillHole Diagnostic{_range=_range@Range{..},..}
273+suggestFillHole Diagnostic{_range=_range,..}
228-- ...Development/IDE/LSP/CodeAction.hs:103:9: warning:
274-- ...Development/IDE/LSP/CodeAction.hs:103:9: warning:
229-- * Found hole: _ :: Int -> String
275-- * Found hole: _ :: Int -> String
230-- * In the expression: _
276-- * In the expression: _
@@ -259,20 +305,22 @@ suggestFillHole Diagnostic{_range=_range@Range{..},..}
259
305
260 | otherwise = []
306 | otherwise = []
261
307
262−suggestExtendImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
308+suggestExtendImport :: Maybe DynFlags -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
263−suggestExtendImport contents Diagnostic{_range=_range,..}
309+suggestExtendImport (Just dflags) contents Diagnostic{_range=_range,..}
264 | Just [binding, mod, srcspan] <-
310 | Just [binding, mod, srcspan] <-
265 matchRegex _message
311 matchRegex _message
266 "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 ‘([^’]*)’ *\\((.*)\\).$"
267 , Just c <- contents
313 , Just c <- contents
314+ , POk _ (L _ name) <- runParser dflags (T.unpack binding) parseIdentifier
268 = let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of
315 = let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of
269 [s] -> let x = srcSpanToRange s
316 [s] -> let x = srcSpanToRange s
270 in x{_end = (_end x){_character = succ (_character (_end x))}}
317 in x{_end = (_end x){_character = succ (_character (_end x))}}
271 _ -> error "bug in srcspan parser"
318 _ -> error "bug in srcspan parser"
272 importLine = textInRange range c
319 importLine = textInRange range c
273 in [("Add " <> binding <> " to the import list of " <> mod
320 in [("Add " <> binding <> " to the import list of " <> mod
274− , [TextEdit range (addBindingToImportList binding importLine)])]
321+ , [TextEdit range (addBindingToImportList (T.pack $ printRdrName name) importLine)])]
275 | otherwise = []
322 | otherwise = []
323+suggestExtendImport Nothing _ _ = []
276
324
277suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
325suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]
278suggestFixConstructorImport _ Diagnostic{_range=_range,..}
326suggestFixConstructorImport _ Diagnostic{_range=_range,..}
@@ -290,29 +338,103 @@ suggestFixConstructorImport _ Diagnostic{_range=_range,..}
290
338
291suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
339suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
292suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
340suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
293− | "Top-level binding with no type signature" `T.isInfixOf` _message = let
341+ | _message =~
294− signature = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
295− startOfLine = Position (_line _start) 0
296− beforeLine = Range startOfLine startOfLine
297− title = if isQuickFix then "add signature: " <> signature else signature
298− action = TextEdit beforeLine $ signature <> "\n"
299− in [(title, [action])]
300−suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
301− | "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
302 signature = removeInitialForAll
343 signature = removeInitialForAll
303 $ T.takeWhile (\x -> x/='*' && x/='•')
344 $ T.takeWhile (\x -> x/='*' && x/='•')
304 $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
345 $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
305− startOfLine = Position (_line _start) (_character _start)
346+ startOfLine = Position (_line _start) startCharacter
306 beforeLine = Range startOfLine startOfLine
347 beforeLine = Range startOfLine startOfLine
307 title = if isQuickFix then "add signature: " <> signature else signature
348 title = if isQuickFix then "add signature: " <> signature else signature
308− action = TextEdit beforeLine $ signature <> "\n" <> T.replicate (_character _start) " "
349+ action = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " "
309 in [(title, [action])]
350 in [(title, [action])]
310 where removeInitialForAll :: T.Text -> T.Text
351 where removeInitialForAll :: T.Text -> T.Text
311 removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))
352 removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))
312 | "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))
313 | otherwise = nm <> ty
354 | otherwise = nm <> ty
355+ startCharacter
356+ | "Polymorphic local binding" `T.isPrefixOf` _message
357+ = _character _start
358+ | otherwise
359+ = 0
360+
314suggestSignature _ _ = []
361suggestSignature _ _ = []
315
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+
316topOfHoleFitsMarker :: T.Text
438topOfHoleFitsMarker :: T.Text
317topOfHoleFitsMarker =
439topOfHoleFitsMarker =
318#if MIN_GHC_API_VERSION(8,6,0)
440#if MIN_GHC_API_VERSION(8,6,0)
@@ -323,7 +445,7 @@ topOfHoleFitsMarker =
323
445
324mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit
446mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit
325mkRenameEdit contents range name =
447mkRenameEdit contents range name =
326− if fromMaybe False maybeIsInfixFunction
448+ if maybeIsInfixFunction == Just True
327 then TextEdit range ("`" <> name <> "`")
449 then TextEdit range ("`" <> name <> "`")
328 else TextEdit range name
450 else TextEdit range name
329 where
451 where
@@ -364,10 +486,6 @@ extendToWholeLineIfPossible contents range@Range{..} =
364 extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line
486 extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line
365 in if extend then Range _start (Position (_line _end + 1) 0) else range
487 in if extend then Range _start (Position (_line _end + 1) 0) else range
366
488
367−-- | All the GHC extensions
368−ghcExtensions :: Set.HashSet T.Text
369−ghcExtensions = Set.fromList $ map (T.pack . show) ghcEnumerateExtensions
370−
371splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)
489splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)
372splitTextAtPosition (Position row col) x
490splitTextAtPosition (Position row col) x
373 | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x
491 | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x
@@ -409,7 +527,7 @@ rangesForBinding _ _ = []
409rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]
527rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]
410rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]
528rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]
411rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]
529rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]
412−rangesForBinding' b (L l x@IEThingAll{}) | showSDocUnsafe (ppr x) == b = [l]
530+rangesForBinding' b (L l (IEThingAll x)) | showSDocUnsafe (ppr x) == b = [l]
413rangesForBinding' b (L l (IEThingWith thing _ inners labels))
531rangesForBinding' b (L l (IEThingWith thing _ inners labels))
414 | showSDocUnsafe (ppr thing) == b = [l]
532 | showSDocUnsafe (ppr thing) == b = [l]
415 | otherwise =
533 | otherwise =
@@ -439,12 +557,7 @@ matchRegex message regex = case unifySpaces message =~~ regex of
439 Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings
557 Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings
440 Nothing -> Nothing
558 Nothing -> Nothing
441
559
442−setHandlersCodeAction :: PartialHandlers
443−setHandlersCodeAction = PartialHandlers $ \WithMessage{..} x -> return x{
444− LSP.codeActionHandler = withResponse RspCodeAction codeAction
445− }
446−
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.hsnew file+103
@@ -0,0 +1,103 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE TypeFamilies #-}
3+#include "ghc-api-version.h"
4+
5+module Development.IDE.Plugin.Completions(plugin) where
6+
7+import Control.Applicative
8+import Language.Haskell.LSP.Messages
9+import Language.Haskell.LSP.Types
10+import qualified Language.Haskell.LSP.Core as LSP
11+import qualified Language.Haskell.LSP.VFS as VFS
12+import Language.Haskell.LSP.Types.Capabilities
13+import Development.Shake.Classes
14+import Development.Shake
15+import GHC.Generics
16+
17+import Development.IDE.Plugin
18+import Development.IDE.Core.Service
19+import Development.IDE.Plugin.Completions.Logic
20+import Development.IDE.Types.Location
21+import Development.IDE.Core.PositionMapping
22+import Development.IDE.Core.RuleTypes
23+import Development.IDE.Core.Shake
24+import Development.IDE.GHC.Util
25+import Development.IDE.LSP.Server
26+
27+#if !MIN_GHC_API_VERSION(8,6,0) || defined(GHC_LIB)
28+import Data.Maybe
29+import Development.IDE.Import.DependencyInformation
30+#endif
31+
32+plugin :: Plugin c
33+plugin = Plugin produceCompletions setHandlersCompletion
34+
35+produceCompletions :: Rules ()
36+produceCompletions =
37+ define $ \ProduceCompletions file -> do
38+
39+-- When possible, rely on the haddocks embedded in our interface files
40+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'
41+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
42+ let parsedDeps = []
43+#else
44+ deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
45+ parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)
46+#endif
47+ tm <- fmap fst <$> useWithStale TypeCheck file
48+ packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file
49+ case (tm, packageState) of
50+ (Just tm', Just packageState') -> do
51+ cdata <- liftIO $ cacheDataProducer packageState'
52+ (tmrModule tm') parsedDeps
53+ return ([], Just cdata)
54+ _ -> return ([], Nothing)
55+
56+
57+-- | Produce completions info for a file
58+type instance RuleResult ProduceCompletions = CachedCompletions
59+
60+data ProduceCompletions = ProduceCompletions
61+ deriving (Eq, Show, Typeable, Generic)
62+instance Hashable ProduceCompletions
63+instance NFData ProduceCompletions
64+instance Binary ProduceCompletions
65+
66+
67+-- | Generate code actions.
68+getCompletionsLSP
69+ :: LSP.LspFuncs c
70+ -> IdeState
71+ -> CompletionParams
72+ -> IO (Either ResponseError CompletionResponseResult)
73+getCompletionsLSP lsp ide
74+ CompletionParams{_textDocument=TextDocumentIdentifier uri
75+ ,_position=position
76+ ,_context=completionContext} = do
77+ contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
78+ fmap Right $ case (contents, uriToFilePath' uri) of
79+ (Just cnts, Just path) -> do
80+ let npath = toNormalizedFilePath' path
81+ (ideOpts, compls) <- runAction ide $ do
82+ opts <- getIdeOptions
83+ compls <- useWithStale ProduceCompletions npath
84+ pm <- useWithStale GetParsedModule npath
85+ pure (opts, liftA2 (,) compls pm)
86+ case compls of
87+ Just ((cci', _), (pm, mapping)) -> do
88+ let !position' = fromCurrentPosition mapping position
89+ pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'
90+ case (pfix, completionContext) of
91+ (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
92+ -> return (Completions $ List [])
93+ (Just pfix', _) -> do
94+ let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing
95+ Completions . List <$> getCompletions ideOpts cci' pm pfix' fakeClientCapabilities (WithSnippets True)
96+ _ -> return (Completions $ List [])
97+ _ -> return (Completions $ List [])
98+ _ -> return (Completions $ List [])
99+
100+setHandlersCompletion :: PartialHandlers c
101+setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{
102+ LSP.completionHandler = withResponse RspCompletion getCompletionsLSP
103+ }
src/Development/IDE/Core/Completions.hs → src/Development/IDE/Plugin/Completions/Logic.hsrenamed+46−27
@@ -1,6 +1,7 @@
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"
3−module Development.IDE.Core.Completions (
4+module Development.IDE.Plugin.Completions.Logic (
4 CachedCompletions
5 CachedCompletions
5, cacheDataProducer
6, cacheDataProducer
6, WithSnippets(..)
7, WithSnippets(..)
@@ -10,7 +11,7 @@ module Development.IDE.Core.Completions (
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,11 +26,17 @@ 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
31import qualified Language.Haskell.LSP.VFS as VFS
38import qualified Language.Haskell.LSP.VFS as VFS
32−import Development.IDE.Core.CompletionsTypes
39+import Development.IDE.Plugin.Completions.Types
33import Development.IDE.Spans.Documentation
40import Development.IDE.Spans.Documentation
34import Development.IDE.GHC.Error
41import Development.IDE.GHC.Error
35import Development.IDE.Types.Options
42import Development.IDE.Types.Options
@@ -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,6 +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
376+ | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)
377+ | otherwise = []
364
378
365 stripLeading :: Char -> String -> String
379 stripLeading :: Char -> String -> String
366 stripLeading _ [] = []
380 stripLeading _ [] = []
@@ -380,13 +394,18 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl
380 | otherwise
394 | otherwise
381 = filtModNameCompls ++ map (toggleSnippets caps withSnippets
395 = filtModNameCompls ++ map (toggleSnippets caps withSnippets
382 . mkCompl ideOpts . stripAutoGenerated) filtCompls
396 . mkCompl ideOpts . stripAutoGenerated) filtCompls
383−
397+ ++ filtKeywordCompls
398+
384 return result
399 return result
385
400
386-- The supported languages and extensions
401-- The supported languages and extensions
387languagesAndExts :: [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
388languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions
406languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions
389−
407+#endif
408+
390-- ---------------------------------------------------------------------
409-- ---------------------------------------------------------------------
391-- helper functions for pragmas
410-- helper functions for pragmas
392-- ---------------------------------------------------------------------
411-- ---------------------------------------------------------------------
src/Development/IDE/Core/CompletionsTypes.hs → src/Development/IDE/Plugin/Completions/Types.hsrenamed+2−2
@@ -1,5 +1,5 @@
1−module Development.IDE.Core.CompletionsTypes (
1+module Development.IDE.Plugin.Completions.Types (
2− module Development.IDE.Core.CompletionsTypes
2+ module Development.IDE.Plugin.Completions.Types
3) where
3) where
4
4
5import Control.DeepSeq
5import Control.DeepSeq
src/Development/IDE/Spans/AtPoint.hs+35−25
@@ -13,20 +13,19 @@ 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
28import Outputable hiding ((<>))
25import Outputable hiding ((<>))
29import SrcLoc
26import SrcLoc
27+import Type
28+import VarSet
30
29
31import Control.Monad.Extra
30import Control.Monad.Extra
32import Control.Monad.Trans.Maybe
31import Control.Monad.Trans.Maybe
@@ -38,27 +37,27 @@ import qualified Data.Text as T
38-- | Locate the definition of the name at a given position.
37-- | Locate the definition of the name at a given position.
39gotoDefinition
38gotoDefinition
40 :: MonadIO m
39 :: MonadIO m
41− => (FilePath -> m (Maybe HieFile))
40+ => (Module -> m (Maybe (HieFile, FilePath)))
42 -> IdeOptions
41 -> IdeOptions
43− -> HscEnv
44 -> [SpanInfo]
42 -> [SpanInfo]
45 -> Position
43 -> Position
46 -> m (Maybe Location)
44 -> m (Maybe Location)
47−gotoDefinition getHieFile ideOpts pkgState srcSpans pos =
45+gotoDefinition getHieFile ideOpts srcSpans pos =
48− listToMaybe <$> locationsAtPoint getHieFile ideOpts pkgState pos srcSpans
46+ listToMaybe <$> locationsAtPoint getHieFile ideOpts pos srcSpans
49
47
50-- | Synopsis for the name at a given position.
48-- | Synopsis for the name at a given position.
51atPoint
49atPoint
52 :: IdeOptions
50 :: IdeOptions
53− -> [SpanInfo]
51+ -> SpansInfo
54 -> Position
52 -> Position
55 -> Maybe (Maybe Range, [T.Text])
53 -> Maybe (Maybe Range, [T.Text])
56−atPoint IdeOptions{..} srcSpans pos = do
54+atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do
57 firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans
55 firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans
56+ let constraintsAtPoint = mapMaybe spaninfoType (spansAtPoint pos cntsSpans)
58− return (Just (range firstSpan), hoverInfo firstSpan)
57+ return (Just (range firstSpan), hoverInfo firstSpan constraintsAtPoint)
59 where
58 where
60 -- Hover info for types, classes, type variables
59 -- Hover info for types, classes, type variables
61− hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs , ..} =
60+ hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs , ..} _ =
62 (wrapLanguageSyntax <$> name) <> location <> spanDocToMarkdown docs
61 (wrapLanguageSyntax <$> name) <> location <> spanDocToMarkdown docs
63 where
62 where
64 name = [maybe shouldNotHappen showName mbName]
63 name = [maybe shouldNotHappen showName mbName]
@@ -67,11 +66,10 @@ atPoint IdeOptions{..} srcSpans pos = do
67 mbName = getNameM spaninfoSource
66 mbName = getNameM spaninfoSource
68
67
69 -- Hover info for values/data
68 -- Hover info for values/data
70− hoverInfo SpanInfo{spaninfoType = (Just typ), spaninfoDocs = docs , ..} =
69+ hoverInfo SpanInfo{spaninfoType = (Just typ), spaninfoDocs = docs , ..} cnts =
71 (wrapLanguageSyntax <$> nameOrSource) <> location <> spanDocToMarkdown docs
70 (wrapLanguageSyntax <$> nameOrSource) <> location <> spanDocToMarkdown docs
72 where
71 where
73 mbName = getNameM spaninfoSource
72 mbName = getNameM spaninfoSource
74− typeAnnotation = colon <> showName typ
75 expr = case spaninfoSource of
73 expr = case spaninfoSource of
76 Named n -> qualifyNameIfPossible n
74 Named n -> qualifyNameIfPossible n
77 Lit l -> crop $ T.pack l
75 Lit l -> crop $ T.pack l
@@ -81,6 +79,15 @@ atPoint IdeOptions{..} srcSpans pos = do
81 where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')
79 where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')
82 location = [maybe "" definedAt mbName]
80 location = [maybe "" definedAt mbName]
83
81
82+ thisFVs = tyCoVarsOfType typ
83+ constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts
84+ constraintsT = T.intercalate ", " (map showName constraintsOverFVs)
85+
86+ typeAnnotation = case constraintsOverFVs of
87+ [] -> colon <> showName typ
88+ [_] -> colon <> constraintsT <> "\n=> " <> showName typ
89+ _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ
90+
84 definedAt name = "*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*\n"
91 definedAt name = "*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*\n"
85
92
86 crop txt
93 crop txt
@@ -108,8 +115,15 @@ atPoint IdeOptions{..} srcSpans pos = do
108 Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]
115 Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]
109 Nothing -> False
116 Nothing -> False
110
117
111−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]
112−locationsAtPoint getHieFile IdeOptions{..} pkgState pos =
126+locationsAtPoint getHieFile _ideOptions pos =
113 fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos
127 fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos
114 where getSpan :: SpanSource -> m (Maybe SrcSpan)
128 where getSpan :: SpanSource -> m (Maybe SrcSpan)
115 getSpan NoSource = pure Nothing
129 getSpan NoSource = pure Nothing
@@ -119,24 +133,20 @@ locationsAtPoint getHieFile IdeOptions{..} pkgState pos =
119 sp@(RealSrcSpan _) -> pure $ Just sp
133 sp@(RealSrcSpan _) -> pure $ Just sp
120 sp@(UnhelpfulSpan _) -> runMaybeT $ do
134 sp@(UnhelpfulSpan _) -> runMaybeT $ do
121 guard (sp /= wiredInSrcSpan)
135 guard (sp /= wiredInSrcSpan)
122− -- 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).
123 -- In this case the interface files contain garbage source spans
137 -- In this case the interface files contain garbage source spans
124 -- 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.
125− let mod = nameModule name
139+ mod <- MaybeT $ return $ nameModule_maybe name
126− let unitId = moduleUnitId mod
127− pkgConfig <- MaybeT $ pure $ lookupPackageConfig unitId pkgState
128− hiePath <- MaybeT $ liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod
129− hieFile <- MaybeT $ getHieFile hiePath
140+ (hieFile, srcPath) <- MaybeT $ getHieFile mod
130− avail <- MaybeT $ pure $ listToMaybe (filterAvails (eqName name) $ hie_exports hieFile)
141+ avail <- MaybeT $ pure $ find (eqName name . snd) $ hieExportNames hieFile
131− srcPath <- MaybeT $ liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod
132 -- The location will point to the source file used during compilation.
142 -- The location will point to the source file used during compilation.
133 -- 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
134 -- to the compilation directory which we don’t know.
144 -- to the compilation directory which we don’t know.
135− let span = setFileName srcPath $ nameSrcSpan $ availName avail
145+ let span = setFileName srcPath $ fst avail
136 pure span
146 pure span
137 -- 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.
138 eqName :: Name -> Name -> Bool
148 eqName :: Name -> Name -> Bool
139− eqName n n' = nameOccName n == nameOccName n' && nameModule n == nameModule n'
149+ eqName n n' = nameOccName n == nameOccName n' && nameModule_maybe n == nameModule_maybe n'
140 setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })
150 setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })
141 setFileName _ span@(UnhelpfulSpan _) = span
151 setFileName _ span@(UnhelpfulSpan _) = span
142
152
src/Development/IDE/Spans/Calculate.hs+78−30
@@ -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
55− -> IO [SpanInfo]
56+ -> [ModIface] -- ^ Dependencies module interfaces, required
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]
65− -> m [SpanInfo]
67+ -> [ModIface]
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
@@ -78,13 +87,16 @@ getSpanInfo mods tcm tcms =
78 let imports = importInfo mods
87 let imports = importInfo mods
79 let exports = getExports tcm
88 let exports = getExports tcm
80 let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)
89 let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)
90+ let constraints = map constraintToInfo (concatMap getConstraintsLHsBind bs)
81− return (mapMaybe toSpanInfo (sortBy cmp exprs))
91+ return $ SpansInfo (mapMaybe toSpanInfo (sortBy cmp exprs))
92+ (mapMaybe toSpanInfo (sortBy cmp constraints))
82 where cmp (_,a,_,_) (_,b,_,_)
93 where cmp (_,a,_,_) (_,b,_,_)
83 | a `isSubspanOf` b = LT
94 | a `isSubspanOf` b = LT
84 | b `isSubspanOf` a = GT
95 | b `isSubspanOf` a = GT
85 | otherwise = compare (srcSpanStart a) (srcSpanStart b)
96 | otherwise = compare (srcSpanStart a) (srcSpanStart b)
86
97
87 addEmptyInfo = map (\(a,b) -> (a,b,Nothing,emptySpanDoc))
98 addEmptyInfo = map (\(a,b) -> (a,b,Nothing,emptySpanDoc))
99+ constraintToInfo (sp, ty) = (SpanS sp, sp, Just ty, emptySpanDoc)
88
100
89-- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always
101-- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always
90-- points to the first match) whereas the parsed module has the correct locations.
102-- points to the first match) whereas the parsed module has the correct locations.
@@ -114,42 +126,48 @@ ieLNames _ = []
114
126
115-- | Get the name and type of a binding.
127-- | Get the name and type of a binding.
116getTypeLHsBind :: (GhcMonad m)
128getTypeLHsBind :: (GhcMonad m)
117− => [TypecheckedModule]
129+ => [ParsedModule]
118 -> OccEnv (HsBind GhcPs)
130 -> OccEnv (HsBind GhcPs)
119 -> LHsBind GhcTc
131 -> LHsBind GhcTc
120 -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
132 -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
121−getTypeLHsBind tms funBinds (L _spn FunBind{fun_id = pid})
133+getTypeLHsBind deps funBinds (L _spn FunBind{fun_id = pid})
122 | 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
123 let name = getName (unLoc pid)
135 let name = getName (unLoc pid)
124− docs <- getDocumentationTryGhc tms name
136+ docs <- getDocumentationTryGhc deps name
125 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] ]
126-- 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.
127−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
128 let name = getName (unLoc pid)
140 let name = getName (unLoc pid)
129− docs <- getDocumentationTryGhc tms name
141+ docs <- getDocumentationTryGhc deps name
130 return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)]
142 return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)]
131getTypeLHsBind _ _ _ = return []
143getTypeLHsBind _ _ _ = return []
132
144
145+-- | Get information about constraints
146+getConstraintsLHsBind :: LHsBind GhcTc
147+ -> [(SrcSpan, Type)]
148+getConstraintsLHsBind (L spn AbsBinds { abs_ev_vars = vars })
149+ = map (\v -> (spn, varType v)) vars
150+getConstraintsLHsBind _ = []
151+
133-- | Get the name and type of an expression.
152-- | Get the name and type of an expression.
134getTypeLHsExpr :: (GhcMonad m)
153getTypeLHsExpr :: (GhcMonad m)
135− => [TypecheckedModule]
154+ => [ParsedModule]
136 -> LHsExpr GhcTc
155 -> LHsExpr GhcTc
137 -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
156 -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
138−getTypeLHsExpr tms e = do
157+getTypeLHsExpr deps e = do
139 hs_env <- getSession
158 hs_env <- getSession
140 (_, mbe) <- liftIO (deSugarExpr hs_env e)
159 (_, mbe) <- liftIO (deSugarExpr hs_env e)
141 case mbe of
160 case mbe of
142 Just expr -> do
161 Just expr -> do
143 let ss = getSpanSource (unLoc e)
162 let ss = getSpanSource (unLoc e)
144 docs <- case ss of
163 docs <- case ss of
145− Named n -> getDocumentationTryGhc tms n
164+ Named n -> getDocumentationTryGhc deps n
146 _ -> return emptySpanDoc
165 _ -> return emptySpanDoc
147 return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr), docs)
166 return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr), docs)
148 Nothing -> return Nothing
167 Nothing -> return Nothing
149 where
168 where
150 getSpanSource :: HsExpr GhcTc -> SpanSource
169 getSpanSource :: HsExpr GhcTc -> SpanSource
151− getSpanSource (HsLit U lit) = Lit (showGhc lit)
170+ getSpanSource xpr | isLit xpr = Lit (showGhc xpr)
152− getSpanSource (HsOverLit U lit) = Lit (showGhc lit)
153 getSpanSource (HsVar U (L _ i)) = Named (getName i)
171 getSpanSource (HsVar U (L _ i)) = Named (getName i)
154 getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)
172 getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)
155 getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name)
173 getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name)
@@ -157,15 +175,45 @@ getTypeLHsExpr tms e = do
157 getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr)
175 getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr)
158 getSpanSource _ = NoSource
176 getSpanSource _ = NoSource
159
177
178+ isLit :: HsExpr GhcTc -> Bool
179+ isLit (HsLit U _) = True
180+ isLit (HsOverLit U _) = True
181+ isLit (ExplicitTuple U args _) = all (isTupLit . unLoc) args
182+#if MIN_GHC_API_VERSION(8,6,0)
183+ isLit (ExplicitSum U _ _ xpr) = isLitChild (unLoc xpr)
184+ isLit (ExplicitList U _ xprs) = all (isLitChild . unLoc) xprs
185+#else
186+ isLit (ExplicitSum _ _ xpr _) = isLitChild (unLoc xpr)
187+ isLit (ExplicitList _ _ xprs) = all (isLitChild . unLoc) xprs
188+#endif
189+ isLit _ = False
190+
191+ isTupLit (Present U xpr) = isLitChild (unLoc xpr)
192+ isTupLit _ = False
193+
194+ -- We need special treatment for children so things like [(1)] are still treated
195+ -- as a list literal while not treating (1) as a literal.
196+ isLitChild (HsWrap U _ xpr) = isLitChild xpr
197+ isLitChild (HsPar U xpr) = isLitChild (unLoc xpr)
198+#if MIN_GHC_API_VERSION(8,8,0)
199+ isLitChild (ExprWithTySig U xpr _) = isLitChild (unLoc xpr)
200+#elif MIN_GHC_API_VERSION(8,6,0)
201+ isLitChild (ExprWithTySig U xpr) = isLitChild (unLoc xpr)
202+#else
203+ isLitChild (ExprWithTySigOut xpr _) = isLitChild (unLoc xpr)
204+ isLitChild (ExprWithTySig xpr _) = isLitChild (unLoc xpr)
205+#endif
206+ isLitChild e = isLit e
207+
160-- | Get the name and type of a pattern.
208-- | Get the name and type of a pattern.
161getTypeLPat :: (GhcMonad m)
209getTypeLPat :: (GhcMonad m)
162− => [TypecheckedModule]
210+ => [ParsedModule]
163 -> Pat GhcTc
211 -> Pat GhcTc
164 -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
212 -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))
165−getTypeLPat tms pat = do
213+getTypeLPat deps pat = do
166 let (src, spn) = getSpanSource pat
214 let (src, spn) = getSpanSource pat
167 docs <- case src of
215 docs <- case src of
168− Named n -> getDocumentationTryGhc tms n
216+ Named n -> getDocumentationTryGhc deps n
169 _ -> return emptySpanDoc
217 _ -> return emptySpanDoc
170 return $ Just (src, spn, Just (hsPatType pat), docs)
218 return $ Just (src, spn, Just (hsPatType pat), docs)
171 where
219 where
@@ -177,12 +225,12 @@ getTypeLPat tms pat = do
177
225
178getLHsType
226getLHsType
179 :: GhcMonad m
227 :: GhcMonad m
180− => [TypecheckedModule]
228+ => [ParsedModule]
181 -> LHsType GhcRn
229 -> LHsType GhcRn
182 -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
230 -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]
183−getLHsType tms (L spn (HsTyVar U _ v)) = do
231+getLHsType deps (L spn (HsTyVar U _ v)) = do
184 let n = unLoc v
232 let n = unLoc v
185− docs <- getDocumentationTryGhc tms n
233+ docs <- getDocumentationTryGhc deps n
186#ifdef GHC_LIB
234#ifdef GHC_LIB
187 let ty = Right Nothing
235 let ty = Right Nothing
188#else
236#else
src/Development/IDE/Spans/Common.hs+15−13
@@ -12,11 +12,13 @@ module Development.IDE.Spans.Common (
12, SpanDoc(..)
12, SpanDoc(..)
13, emptySpanDoc
13, emptySpanDoc
14, spanDocToMarkdown
14, spanDocToMarkdown
15+, spanDocToMarkdownForTest
15) where
16) where
16
17
17import Data.Data
18import Data.Data
18import qualified Data.Generics
19import qualified Data.Generics
19import qualified Data.Text as T
20import qualified Data.Text as T
21+import Data.List.Extra
20
22
21import GHC
23import GHC
22import Outputable
24import Outputable
@@ -27,11 +29,8 @@ import DataCon
27import Var
29import Var
28#endif
30#endif
29
31
30−#if MIN_GHC_API_VERSION(8,6,0)
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−#endif
35
34
36showGhc :: Outputable a => a -> String
35showGhc :: Outputable a => a -> String
37showGhc = showPpr unsafeGlobalDynFlags
36showGhc = showPpr unsafeGlobalDynFlags
@@ -81,7 +80,10 @@ spanDocToMarkdown (SpanDocString _)
81#endif
80#endif
82spanDocToMarkdown (SpanDocText txt) = txt
81spanDocToMarkdown (SpanDocText txt) = txt
83
82
84−#if MIN_GHC_API_VERSION(8,6,0)
83+spanDocToMarkdownForTest :: String -> String
84+spanDocToMarkdownForTest
85+ = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing
86+
85-- Simple (and a bit hacky) conversion from Haddock markup to Markdown
87-- Simple (and a bit hacky) conversion from Haddock markup to Markdown
86haddockToMarkdown
88haddockToMarkdown
87 :: H.DocH String String -> String
89 :: H.DocH String String -> String
@@ -89,7 +91,7 @@ haddockToMarkdown
89haddockToMarkdown H.DocEmpty
91haddockToMarkdown H.DocEmpty
90 = ""
92 = ""
91haddockToMarkdown (H.DocAppend d1 d2)
93haddockToMarkdown (H.DocAppend d1 d2)
92− = haddockToMarkdown d1 Prelude.<> haddockToMarkdown d2
94+ = haddockToMarkdown d1 ++ " " ++ haddockToMarkdown d2
93haddockToMarkdown (H.DocString s)
95haddockToMarkdown (H.DocString s)
94 = s
96 = s
95haddockToMarkdown (H.DocParagraph p)
97haddockToMarkdown (H.DocParagraph p)
@@ -121,13 +123,8 @@ haddockToMarkdown (H.DocExamples es)
121 = ">>> " ++ expr ++ "\n" ++ unlines result
123 = ">>> " ++ expr ++ "\n" ++ unlines result
122haddockToMarkdown (H.DocHyperlink (H.Hyperlink url Nothing))
124haddockToMarkdown (H.DocHyperlink (H.Hyperlink url Nothing))
123 = "<" ++ url ++ ">"
125 = "<" ++ url ++ ">"
124−#if MIN_VERSION_haddock_library(1,8,0)
125haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))
126haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))
126 = "[" ++ haddockToMarkdown label ++ "](" ++ url ++ ")"
127 = "[" ++ haddockToMarkdown label ++ "](" ++ url ++ ")"
127−#else
128−haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))
129− = "[" ++ label ++ "](" ++ url ++ ")"
130−#endif
131haddockToMarkdown (H.DocPic (H.Picture url Nothing))
128haddockToMarkdown (H.DocPic (H.Picture url Nothing))
132 = "![](" ++ url ++ ")"
129 = "![](" ++ url ++ ")"
133haddockToMarkdown (H.DocPic (H.Picture url (Just label)))
130haddockToMarkdown (H.DocPic (H.Picture url (Just label)))
@@ -138,9 +135,9 @@ haddockToMarkdown (H.DocHeader (H.Header level title))
138 = replicate level '#' ++ " " ++ haddockToMarkdown title
135 = replicate level '#' ++ " " ++ haddockToMarkdown title
139
136
140haddockToMarkdown (H.DocUnorderedList things)
137haddockToMarkdown (H.DocUnorderedList things)
141− = '\n' : (unlines $ map (\thing -> "+ " ++ dropWhile isSpace (haddockToMarkdown thing)) things)
138+ = '\n' : (unlines $ map (("+ " ++) . trimStart . splitForList . haddockToMarkdown) things)
142haddockToMarkdown (H.DocOrderedList things)
139haddockToMarkdown (H.DocOrderedList things)
143− = '\n' : (unlines $ map (\thing -> "1. " ++ dropWhile isSpace (haddockToMarkdown thing)) things)
140+ = '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things)
144haddockToMarkdown (H.DocDefList things)
141haddockToMarkdown (H.DocDefList things)
145 = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things)
142 = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things)
146
143
@@ -157,4 +154,9 @@ haddockToMarkdown (H.DocTable _t)
157-- things I don't really know how to handle
154-- things I don't really know how to handle
158haddockToMarkdown (H.DocProperty _)
155haddockToMarkdown (H.DocProperty _)
159 = "" -- don't really know what to do
156 = "" -- don't really know what to do
160−#endif
157+
158+splitForList :: String -> String
159+splitForList s
160+ = case lines s of
161+ [] -> ""
162+ (first:rest) -> unlines $ first : map ((" " ++) . trimStart) rest
src/Development/IDE/Spans/Documentation.hs+25−21
@@ -14,31 +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.
30+-- See https://github.com/digital-asset/daml/issues/4152 for more details.
29−#if MIN_GHC_API_VERSION(8,6,0)
31+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
30−getDocumentationTryGhc tcs name = do
32+getDocumentationTryGhc sources name = do
31 res <- catchSrcErrors "docs" $ getDocs name
33 res <- catchSrcErrors "docs" $ getDocs name
32 case res of
34 case res of
33 Right (Right (Just docs, _)) -> return $ SpanDocString docs
35 Right (Right (Just docs, _)) -> return $ SpanDocString docs
34− _ -> return $ SpanDocText $ getDocumentation tcs name
36+ _ -> return $ SpanDocText $ getDocumentation sources name
35#else
37#else
36−getDocumentationTryGhc tcs name = do
38+getDocumentationTryGhc sources name = do
37− return $ SpanDocText $ getDocumentation tcs name
39+ return $ SpanDocText $ getDocumentation sources name
38#endif
40#endif
39
41
40getDocumentation
42getDocumentation
41− :: [TypecheckedModule] -- ^ All of the possible modules it could be defined in.
43+ :: [ParsedModule] -- ^ All of the possible modules it could be defined in.
42 -> Name -- ^ The name you want documentation for.
44 -> Name -- ^ The name you want documentation for.
43 -> [T.Text]
45 -> [T.Text]
44-- This finds any documentation between the name you want
46-- This finds any documentation between the name you want
@@ -48,16 +50,18 @@ getDocumentation
48-- may be edge cases where it is very wrong).
50-- may be edge cases where it is very wrong).
49-- TODO : Build a version of GHC exactprint to extract this information
51-- TODO : Build a version of GHC exactprint to extract this information
50-- more accurately.
52-- more accurately.
51−getDocumentation tcs targetName = fromMaybe [] $ do
53+getDocumentation sources targetName = fromMaybe [] $ do
52 -- Find the module the target is defined in.
54 -- Find the module the target is defined in.
53 targetNameSpan <- realSpan $ nameSrcSpan targetName
55 targetNameSpan <- realSpan $ nameSrcSpan targetName
54 tc <-
56 tc <-
55 find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)
57 find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)
56− $ reverse tcs -- TODO : Is reversing the list here really neccessary?
58+ $ reverse sources -- TODO : Is reversing the list here really neccessary?
59+
57− -- Names bound by the module (we want to exclude non-"top-level"
60+ -- Top level names bound by the module
58− -- bindings but unfortunately we get all here).
61+ let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc
62+ , L _ (ValD hsbind) <- hsmodDecls
59− let bs = mapMaybe name_of_bind
63+ , Just n <- [name_of_bind hsbind]
60− (listifyAllSpans (tm_typechecked_source tc) :: [LHsBind GhcTc])
64+ ]
61 -- Sort the names' source spans.
65 -- Sort the names' source spans.
62 let sortedSpans = sortedNameSpans bs
66 let sortedSpans = sortedNameSpans bs
63 -- Now go ahead and extract the docs.
67 -- Now go ahead and extract the docs.
@@ -79,16 +83,16 @@ getDocumentation tcs targetName = fromMaybe [] $ do
79 where
83 where
80 -- 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
81 -- @FunBind@ (which covers functions and variables).
85 -- @FunBind@ (which covers functions and variables).
82− name_of_bind :: LHsBind GhcTc -> Maybe Name
86+ name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)
83− name_of_bind (L _ FunBind {fun_id}) = Just (getName (unLoc fun_id))
87+ name_of_bind FunBind {fun_id} = Just fun_id
84 name_of_bind _ = Nothing
88 name_of_bind _ = Nothing
85 -- Get source spans from names, discard unhelpful spans, remove
89 -- Get source spans from names, discard unhelpful spans, remove
86 -- duplicates and sort.
90 -- duplicates and sort.
87− sortedNameSpans :: [Name] -> [RealSrcSpan]
91+ sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]
88− sortedNameSpans ls = nubSort (mapMaybe (realSpan . nameSrcSpan) ls)
92+ sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)
89 isBetween target before after = before <= target && target <= after
93 isBetween target before after = before <= target && target <= after
90− ann = snd . pm_annotations . tm_parsed_module
94+ ann = snd . pm_annotations
91− annotationFileName :: TypecheckedModule -> Maybe FastString
95+ annotationFileName :: ParsedModule -> Maybe FastString
92 annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann
96 annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann
93 realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]
97 realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]
94 realSpans =
98 realSpans =
@@ -108,4 +112,4 @@ docHeaders = mapMaybe (\(L _ x) -> wrk x)
108 AnnLineComment s -> if "-- |" `isPrefixOf` s
112 AnnLineComment s -> if "-- |" `isPrefixOf` s
109 then Just $ T.pack s
113 then Just $ T.pack s
110 else Nothing
114 else Nothing
111− _ -> Nothing
115+ _ -> Nothing
src/Development/IDE/Spans/Type.hs+10−1
@@ -6,7 +6,8 @@
6-- | Types used separate to GHCi vanilla.
6-- | Types used separate to GHCi vanilla.
7
7
8module Development.IDE.Spans.Type(
8module Development.IDE.Spans.Type(
9+ SpansInfo(..)
9− SpanInfo(..)
10+ , SpanInfo(..)
10 , SpanSource(..)
11 , SpanSource(..)
11 , getNameM
12 , getNameM
12 ) where
13 ) where
@@ -17,6 +18,14 @@ import OccName
17import Development.IDE.GHC.Util
18import Development.IDE.GHC.Util
18import Development.IDE.Spans.Common
19import Development.IDE.Spans.Common
19
20
21+data SpansInfo =
22+ SpansInfo { spansExprs :: [SpanInfo]
23+ , spansConstraints :: [SpanInfo] }
24+ deriving Show
25+
26+instance NFData SpansInfo where
27+ rnf (SpansInfo e c) = liftRnf rnf e `seq` liftRnf rnf c
28+
20-- | Type of some span of source code. Most of these fields are
29-- | Type of some span of source code. Most of these fields are
21-- unboxed but Haddock doesn't show that.
30-- unboxed but Haddock doesn't show that.
22data SpanInfo =
31data SpanInfo =
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−5
@@ -1,10 +1,11 @@
1−resolver: nightly-2020-01-03
1+resolver: nightly-2020-02-13
2packages:
2packages:
3- .
3- .
4extra-deps:
4extra-deps:
5+- haskell-lsp-0.22.0.0
6+- haskell-lsp-types-0.22.0.0
7+- lsp-test-0.11.0.1
8+- ghc-check-0.3.0.1
5−- hie-bios-0.3.2
9+- hie-bios-0.5.0
6−- fuzzy-0.1.0.0
7−- haddock-library-1.8.0
8−allow-newer: true
9nix:
10nix:
10 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+1142−283
@@ -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,51 +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
26+import Development.IDE.Spans.Common
20import Development.IDE.Test
27import Development.IDE.Test
21import Development.IDE.Test.Runfiles
28import Development.IDE.Test.Runfiles
22import Development.IDE.Types.Location
29import Development.IDE.Types.Location
23−import qualified Language.Haskell.LSP.Test as LSPTest
30+import Development.Shake (getDirectoryFilesIO)
24−import Language.Haskell.LSP.Test hiding (openDoc')
31+import Language.Haskell.LSP.Test
32+import Language.Haskell.LSP.Messages
25import Language.Haskell.LSP.Types
33import Language.Haskell.LSP.Types
26import 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
27−import System.Environment.Blank (setEnv)
38+import System.Environment.Blank (getEnv, setEnv, unsetEnv)
28import System.FilePath
39import System.FilePath
29import System.IO.Extra
40import System.IO.Extra
30import System.Directory
41import System.Directory
42+import Test.QuickCheck
43+import Test.QuickCheck.Instances ()
31import Test.Tasty
44import Test.Tasty
32−import Test.Tasty.HUnit
33import Test.Tasty.ExpectedFailure
45import Test.Tasty.ExpectedFailure
46+import Test.Tasty.Ingredients.Rerun
47+import Test.Tasty.HUnit
48+import Test.Tasty.QuickCheck
34import Data.Maybe
49import Data.Maybe
35
50
36main :: IO ()
51main :: IO ()
52+main = do
53+ -- We mess with env vars so run single-threaded.
54+ setEnv "TASTY_NUM_THREADS" "1" True
37−main = defaultMain $ testGroup "HIE"
55+ defaultMainWithRerun $ testGroup "HIE"
38− [ testSession "open close" $ do
56+ [ testSession "open close" $ do
39− doc <- openDoc' "Testing.hs" "haskell" ""
57+ doc <- createDoc "Testing.hs" "haskell" ""
40− void (message :: Session WorkDoneProgressCreateRequest)
58+ void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
41− void (message :: Session WorkDoneProgressBeginNotification)
59+ void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
42− closeDoc doc
60+ closeDoc doc
43− void (message :: Session WorkDoneProgressEndNotification)
61+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
44− , initializeResponseTests
62+ , initializeResponseTests
45− , completionTests
63+ , completionTests
46− , cppTests
64+ , cppTests
47− , diagnosticTests
65+ , diagnosticTests
48− , codeActionTests
66+ , codeActionTests
49− , codeLensesTests
67+ , codeLensesTests
50− , outlineTests
68+ , outlineTests
51− , findDefinitionAndHoverTests
69+ , findDefinitionAndHoverTests
52− , pluginTests
70+ , pluginTests
53− , preprocessorTests
71+ , preprocessorTests
54− , thTests
72+ , thTests
73+ , safeTests
55− , unitTests
74+ , unitTests
75+ , haddockTests
76+ , positionMappingTests
77+ , watchedFilesTests
78+ , cradleTests
79+ , dependentFileTest
56− ]
80+ ]
57
81
58initializeResponseTests :: TestTree
82initializeResponseTests :: TestTree
59initializeResponseTests = withResource acquire release tests where
83initializeResponseTests = withResource acquire release tests where
@@ -88,8 +112,8 @@ initializeResponseTests = withResource acquire release tests where
88 , chk "NO doc link" _documentLinkProvider Nothing
112 , chk "NO doc link" _documentLinkProvider Nothing
89 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
113 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
90 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
114 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
91− , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
115+ , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
92− , chk "NO workspace" _workspace nothingWorkspace
116+ , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
93 , chk "NO experimental" _experimental Nothing
117 , chk "NO experimental" _experimental Nothing
94 ] where
118 ] where
95
119
@@ -100,14 +124,21 @@ initializeResponseTests = withResource acquire release tests where
100 , _willSaveWaitUntil = Nothing
124 , _willSaveWaitUntil = Nothing
101 , _save = Just (SaveOptions {_includeText = Nothing})}))
125 , _save = Just (SaveOptions {_includeText = Nothing})}))
102
126
103− nothingWorkspace = Just (WorkspaceOptions {_workspaceFolders = Nothing})
104−
105 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree
127 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree
106 chk title getActual expected =
128 chk title getActual expected =
107 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
129 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
108
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+
109 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
110− innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c
141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
111 innerCaps _ = error "this test only expects inner capabilities"
142 innerCaps _ = error "this test only expects inner capabilities"
112
143
113 acquire :: IO InitializeResponse
144 acquire :: IO InitializeResponse
@@ -121,7 +152,7 @@ diagnosticTests :: TestTree
121diagnosticTests = testGroup "diagnostics"
152diagnosticTests = testGroup "diagnostics"
122 [ testSessionWait "fix syntax error" $ do
153 [ testSessionWait "fix syntax error" $ do
123 let content = T.unlines [ "module Testing wher" ]
154 let content = T.unlines [ "module Testing wher" ]
124− doc <- openDoc' "Testing.hs" "haskell" content
155+ doc <- createDoc "Testing.hs" "haskell" content
125 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
126 let change = TextDocumentContentChangeEvent
157 let change = TextDocumentContentChangeEvent
127 { _range = Just (Range (Position 0 15) (Position 0 19))
158 { _range = Just (Range (Position 0 15) (Position 0 19))
@@ -132,9 +163,9 @@ diagnosticTests = testGroup "diagnostics"
132 expectDiagnostics [("Testing.hs", [])]
163 expectDiagnostics [("Testing.hs", [])]
133 , testSessionWait "introduce syntax error" $ do
164 , testSessionWait "introduce syntax error" $ do
134 let content = T.unlines [ "module Testing where" ]
165 let content = T.unlines [ "module Testing where" ]
135− doc <- openDoc' "Testing.hs" "haskell" content
166+ doc <- createDoc "Testing.hs" "haskell" content
136− void (message :: Session WorkDoneProgressCreateRequest)
167+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
137− void (message :: Session WorkDoneProgressBeginNotification)
168+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
138 let change = TextDocumentContentChangeEvent
169 let change = TextDocumentContentChangeEvent
139 { _range = Just (Range (Position 0 15) (Position 0 18))
170 { _range = Just (Range (Position 0 15) (Position 0 18))
140 , _rangeLength = Nothing
171 , _rangeLength = Nothing
@@ -150,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"
150 , "bar :: Int -> Int -> Int"
181 , "bar :: Int -> Int -> Int"
151 , "bar a b = cd + b"
182 , "bar a b = cd + b"
152 ]
183 ]
153− _ <- openDoc' "Testing.hs" "haskell" content
184+ _ <- createDoc "Testing.hs" "haskell" content
154 expectDiagnostics
185 expectDiagnostics
155 [ ( "Testing.hs"
186 [ ( "Testing.hs"
156 , [ (DsError, (2, 14), "Variable not in scope: ab")
187 , [ (DsError, (2, 14), "Variable not in scope: ab")
@@ -164,7 +195,7 @@ diagnosticTests = testGroup "diagnostics"
164 , "foo :: Int -> String -> Int"
195 , "foo :: Int -> String -> Int"
165 , "foo a b = a + b"
196 , "foo a b = a + b"
166 ]
197 ]
167− _ <- openDoc' "Testing.hs" "haskell" content
198+ _ <- createDoc "Testing.hs" "haskell" content
168 expectDiagnostics
199 expectDiagnostics
169 [ ( "Testing.hs"
200 [ ( "Testing.hs"
170 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
@@ -176,7 +207,7 @@ diagnosticTests = testGroup "diagnostics"
176 , "foo :: Int -> String"
207 , "foo :: Int -> String"
177 , "foo a = _ a"
208 , "foo a = _ a"
178 ]
209 ]
179− _ <- openDoc' "Testing.hs" "haskell" content
210+ _ <- createDoc "Testing.hs" "haskell" content
180 expectDiagnostics
211 expectDiagnostics
181 [ ( "Testing.hs"
212 [ ( "Testing.hs"
182 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
@@ -198,24 +229,23 @@ diagnosticTests = testGroup "diagnostics"
198 [ ("A.hs", [(DsError, (2,4), aMessage)])
229 [ ("A.hs", [(DsError, (2,4), aMessage)])
199 , ("B.hs", [(DsError, (3,4), bMessage)])]
230 , ("B.hs", [(DsError, (3,4), bMessage)])]
200 deferralTest title binding msg = testSessionWait title $ do
231 deferralTest title binding msg = testSessionWait title $ do
201− _ <- openDoc' "A.hs" "haskell" $ sourceA binding
232+ _ <- createDoc "A.hs" "haskell" $ sourceA binding
202− _ <- openDoc' "B.hs" "haskell" sourceB
233+ _ <- createDoc "B.hs" "haskell" sourceB
203 expectDiagnostics $ expectedDs msg
234 expectDiagnostics $ expectedDs msg
204 in
235 in
205 [ deferralTest "type error" "True" "Couldn't match expected type"
236 [ deferralTest "type error" "True" "Couldn't match expected type"
206 , deferralTest "typed hole" "_" "Found hole"
237 , deferralTest "typed hole" "_" "Found hole"
207 , deferralTest "out of scope var" "unbound" "Variable not in scope"
238 , deferralTest "out of scope var" "unbound" "Variable not in scope"
208− , deferralTest "message shows error" "True" "A.hs:3:5: error:"
209 ]
239 ]
210
240
211 , testSessionWait "remove required module" $ do
241 , testSessionWait "remove required module" $ do
212 let contentA = T.unlines [ "module ModuleA where" ]
242 let contentA = T.unlines [ "module ModuleA where" ]
213− docA <- openDoc' "ModuleA.hs" "haskell" contentA
243+ docA <- createDoc "ModuleA.hs" "haskell" contentA
214 let contentB = T.unlines
244 let contentB = T.unlines
215 [ "module ModuleB where"
245 [ "module ModuleB where"
216 , "import ModuleA"
246 , "import ModuleA"
217 ]
247 ]
218− _ <- openDoc' "ModuleB.hs" "haskell" contentB
248+ _ <- createDoc "ModuleB.hs" "haskell" contentB
219 let change = TextDocumentContentChangeEvent
249 let change = TextDocumentContentChangeEvent
220 { _range = Just (Range (Position 0 0) (Position 0 20))
250 { _range = Just (Range (Position 0 0) (Position 0 20))
221 , _rangeLength = Nothing
251 , _rangeLength = Nothing
@@ -228,11 +258,21 @@ diagnosticTests = testGroup "diagnostics"
228 [ "module ModuleB where"
258 [ "module ModuleB where"
229 , "import ModuleA"
259 , "import ModuleA"
230 ]
260 ]
231− _ <- openDoc' "ModuleB.hs" "haskell" contentB
261+ _ <- createDoc "ModuleB.hs" "haskell" contentB
232 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
233 let contentA = T.unlines [ "module ModuleA where" ]
263 let contentA = T.unlines [ "module ModuleA where" ]
234− _ <- openDoc' "ModuleA.hs" "haskell" contentA
264+ _ <- createDoc "ModuleA.hs" "haskell" contentA
235 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", [])]
236 , testSessionWait "cyclic module dependency" $ do
276 , testSessionWait "cyclic module dependency" $ do
237 let contentA = T.unlines
277 let contentA = T.unlines
238 [ "module ModuleA where"
278 [ "module ModuleA where"
@@ -242,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"
242 [ "module ModuleB where"
282 [ "module ModuleB where"
243 , "import ModuleA"
283 , "import ModuleA"
244 ]
284 ]
245− _ <- openDoc' "ModuleA.hs" "haskell" contentA
285+ _ <- createDoc "ModuleA.hs" "haskell" contentA
246− _ <- openDoc' "ModuleB.hs" "haskell" contentB
286+ _ <- createDoc "ModuleB.hs" "haskell" contentB
247 expectDiagnostics
287 expectDiagnostics
248 [ ( "ModuleA.hs"
288 [ ( "ModuleA.hs"
249 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
@@ -264,9 +304,9 @@ diagnosticTests = testGroup "diagnostics"
264 let contentBboot = T.unlines
304 let contentBboot = T.unlines
265 [ "module ModuleB where"
305 [ "module ModuleB where"
266 ]
306 ]
267− _ <- openDoc' "ModuleA.hs" "haskell" contentA
307+ _ <- createDoc "ModuleA.hs" "haskell" contentA
268− _ <- openDoc' "ModuleB.hs" "haskell" contentB
308+ _ <- createDoc "ModuleB.hs" "haskell" contentB
269− _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
309+ _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
270 expectDiagnostics []
310 expectDiagnostics []
271 , testSessionWait "correct reference used with hs-boot" $ do
311 , testSessionWait "correct reference used with hs-boot" $ do
272 let contentB = T.unlines
312 let contentB = T.unlines
@@ -288,10 +328,10 @@ diagnosticTests = testGroup "diagnostics"
288 -- resolved to the hs-boot file
328 -- resolved to the hs-boot file
289 , "y = x"
329 , "y = x"
290 ]
330 ]
291− _ <- openDoc' "ModuleB.hs" "haskell" contentB
331+ _ <- createDoc "ModuleB.hs" "haskell" contentB
292− _ <- openDoc' "ModuleA.hs" "haskell" contentA
332+ _ <- createDoc "ModuleA.hs" "haskell" contentA
293− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
333+ _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot
294− _ <- openDoc' "ModuleC.hs" "haskell" contentC
334+ _ <- createDoc "ModuleC.hs" "haskell" contentC
295 expectDiagnostics []
335 expectDiagnostics []
296 , testSessionWait "redundant import" $ do
336 , testSessionWait "redundant import" $ do
297 let contentA = T.unlines ["module ModuleA where"]
337 let contentA = T.unlines ["module ModuleA where"]
@@ -300,8 +340,8 @@ diagnosticTests = testGroup "diagnostics"
300 , "module ModuleB where"
340 , "module ModuleB where"
301 , "import ModuleA"
341 , "import ModuleA"
302 ]
342 ]
303− _ <- openDoc' "ModuleA.hs" "haskell" contentA
343+ _ <- createDoc "ModuleA.hs" "haskell" contentA
304− _ <- openDoc' "ModuleB.hs" "haskell" contentB
344+ _ <- createDoc "ModuleB.hs" "haskell" contentB
305 expectDiagnostics
345 expectDiagnostics
306 [ ( "ModuleB.hs"
346 [ ( "ModuleB.hs"
307 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
@@ -323,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"
323 , "wrong1 = ThisList.map"
363 , "wrong1 = ThisList.map"
324 , "wrong2 = BaseList.x"
364 , "wrong2 = BaseList.x"
325 ]
365 ]
326− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent
366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
327− _ <- openDoc' "Main.hs" "haskell" mainContent
367+ _ <- createDoc "Main.hs" "haskell" mainContent
328 expectDiagnostics
368 expectDiagnostics
329 [ ( "Main.hs"
369 [ ( "Main.hs"
330 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
@@ -339,7 +379,7 @@ diagnosticTests = testGroup "diagnostics"
339 , "foo :: Ord a => a -> Int"
379 , "foo :: Ord a => a -> Int"
340 , "foo a = 1"
380 , "foo a = 1"
341 ]
381 ]
342− _ <- openDoc' "Foo.hs" "haskell" fooContent
382+ _ <- createDoc "Foo.hs" "haskell" fooContent
343 expectDiagnostics
383 expectDiagnostics
344 [ ( "Foo.hs"
384 [ ( "Foo.hs"
345 -- The test is to make sure that warnings contain unqualified names
385 -- The test is to make sure that warnings contain unqualified names
@@ -364,18 +404,18 @@ diagnosticTests = testGroup "diagnostics"
364 Just pathB <- pure $ uriToFilePath uriB
404 Just pathB <- pure $ uriToFilePath uriB
365 uriB <- pure $
405 uriB <- pure $
366 let (drive, suffix) = splitDrive pathB
406 let (drive, suffix) = splitDrive pathB
367− in filePathToUri (joinDrive (map toLower drive ) suffix)
407+ in filePathToUri (joinDrive (lower drive) suffix)
368 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
408 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
369 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
409 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
370 uriA <- getDocUri "A/A.hs"
410 uriA <- getDocUri "A/A.hs"
371 Just pathA <- pure $ uriToFilePath uriA
411 Just pathA <- pure $ uriToFilePath uriA
372 uriA <- pure $
412 uriA <- pure $
373 let (drive, suffix) = splitDrive pathA
413 let (drive, suffix) = splitDrive pathA
374− in filePathToUri (joinDrive (map toLower drive ) suffix)
414+ in filePathToUri (joinDrive (lower drive) suffix)
375 let itemA = TextDocumentItem uriA "haskell" 0 aContent
415 let itemA = TextDocumentItem uriA "haskell" 0 aContent
376 let a = TextDocumentIdentifier uriA
416 let a = TextDocumentIdentifier uriA
377 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
417 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
378− diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
418+ diagsNot <- skipManyTill anyMessage diagnostic
379 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
419 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
380 -- 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
381 -- the diagnostics for A.B will also be lower-case.
421 -- the diagnostics for A.B will also be lower-case.
@@ -384,6 +424,38 @@ diagnosticTests = testGroup "diagnostics"
384 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
424 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
385 assertFailure ("Expected redundant import but got " <> T.unpack msg)
425 assertFailure ("Expected redundant import but got " <> T.unpack msg)
386 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
387 ]
459 ]
388
460
389codeActionTests :: TestTree
461codeActionTests :: TestTree
@@ -392,6 +464,8 @@ codeActionTests = testGroup "code actions"
392 , typeWildCardActionTests
464 , typeWildCardActionTests
393 , removeImportTests
465 , removeImportTests
394 , extendImportTests
466 , extendImportTests
467+ , suggestImportTests
468+ , addExtensionTests
395 , fixConstructorImportTests
469 , fixConstructorImportTests
396 , importRenameActionTests
470 , importRenameActionTests
397 , fillTypedHoleTests
471 , fillTypedHoleTests
@@ -404,6 +478,33 @@ codeLensesTests = testGroup "code lenses"
404 [ addSigLensesTests
478 [ addSigLensesTests
405 ]
479 ]
406
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+
407renameActionTests :: TestTree
508renameActionTests :: TestTree
408renameActionTests = testGroup "rename actions"
509renameActionTests = testGroup "rename actions"
409 [ testSession "change to local variable name" $ do
510 [ testSession "change to local variable name" $ do
@@ -412,7 +513,7 @@ renameActionTests = testGroup "rename actions"
412 , "foo :: Int -> Int"
513 , "foo :: Int -> Int"
413 , "foo argName = argNme"
514 , "foo argName = argNme"
414 ]
515 ]
415− doc <- openDoc' "Testing.hs" "haskell" content
516+ doc <- createDoc "Testing.hs" "haskell" content
416 _ <- waitForDiagnostics
517 _ <- waitForDiagnostics
417 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’"
418 executeCodeAction action
519 executeCodeAction action
@@ -430,7 +531,7 @@ renameActionTests = testGroup "rename actions"
430 , "foo :: Maybe a -> [a]"
531 , "foo :: Maybe a -> [a]"
431 , "foo = maybToList"
532 , "foo = maybToList"
432 ]
533 ]
433− doc <- openDoc' "Testing.hs" "haskell" content
534+ doc <- createDoc "Testing.hs" "haskell" content
434 _ <- waitForDiagnostics
535 _ <- waitForDiagnostics
435 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’"
436 executeCodeAction action
537 executeCodeAction action
@@ -448,7 +549,7 @@ renameActionTests = testGroup "rename actions"
448 , "foo :: Char -> Char -> Char -> Char"
549 , "foo :: Char -> Char -> Char -> Char"
449 , "foo argument1 argument2 argument3 = argumentX"
550 , "foo argument1 argument2 argument3 = argumentX"
450 ]
551 ]
451− doc <- openDoc' "Testing.hs" "haskell" content
552+ doc <- createDoc "Testing.hs" "haskell" content
452 _ <- waitForDiagnostics
553 _ <- waitForDiagnostics
453 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
554 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
454 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
555 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
@@ -460,7 +561,7 @@ renameActionTests = testGroup "rename actions"
460 , "monus x y = max 0 (x - y)"
561 , "monus x y = max 0 (x - y)"
461 , "foo x y = x `monnus` y"
562 , "foo x y = x `monnus` y"
462 ]
563 ]
463− doc <- openDoc' "Testing.hs" "haskell" content
564+ doc <- createDoc "Testing.hs" "haskell" content
464 _ <- waitForDiagnostics
565 _ <- waitForDiagnostics
465 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
466 [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 ]
@@ -483,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
483 , "func :: _"
584 , "func :: _"
484 , "func x = x"
585 , "func x = x"
485 ]
586 ]
486− doc <- openDoc' "Testing.hs" "haskell" content
587+ doc <- createDoc "Testing.hs" "haskell" content
487 _ <- waitForDiagnostics
588 _ <- waitForDiagnostics
488 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
489 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -503,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
503 , "func :: _"
604 , "func :: _"
504 , "func x y = x + y"
605 , "func x y = x + y"
505 ]
606 ]
506− doc <- openDoc' "Testing.hs" "haskell" content
607+ doc <- createDoc "Testing.hs" "haskell" content
507 _ <- waitForDiagnostics
608 _ <- waitForDiagnostics
508 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
509 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -526,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
526 , " y = x * 2"
627 , " y = x * 2"
527 , " in y"
628 , " in y"
528 ]
629 ]
529− doc <- openDoc' "Testing.hs" "haskell" content
630+ doc <- createDoc "Testing.hs" "haskell" content
530 _ <- waitForDiagnostics
631 _ <- waitForDiagnostics
531 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
532 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -551,7 +652,7 @@ removeImportTests = testGroup "remove import actions"
551 let contentA = T.unlines
652 let contentA = T.unlines
552 [ "module ModuleA where"
653 [ "module ModuleA where"
553 ]
654 ]
554− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
555 let contentB = T.unlines
656 let contentB = T.unlines
556 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
557 , "module ModuleB where"
658 , "module ModuleB where"
@@ -559,7 +660,7 @@ removeImportTests = testGroup "remove import actions"
559 , "stuffB :: Integer"
660 , "stuffB :: Integer"
560 , "stuffB = 123"
661 , "stuffB = 123"
561 ]
662 ]
562− docB <- openDoc' "ModuleB.hs" "haskell" contentB
663+ docB <- createDoc "ModuleB.hs" "haskell" contentB
563 _ <- waitForDiagnostics
664 _ <- waitForDiagnostics
564 [CACodeAction action@CodeAction { _title = actionTitle }]
665 [CACodeAction action@CodeAction { _title = actionTitle }]
565 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -577,7 +678,7 @@ removeImportTests = testGroup "remove import actions"
577 let contentA = T.unlines
678 let contentA = T.unlines
578 [ "module ModuleA where"
679 [ "module ModuleA where"
579 ]
680 ]
580− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
581 let contentB = T.unlines
682 let contentB = T.unlines
582 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
583 , "module ModuleB where"
684 , "module ModuleB where"
@@ -585,7 +686,7 @@ removeImportTests = testGroup "remove import actions"
585 , "stuffB :: Integer"
686 , "stuffB :: Integer"
586 , "stuffB = 123"
687 , "stuffB = 123"
587 ]
688 ]
588− docB <- openDoc' "ModuleB.hs" "haskell" contentB
689+ docB <- createDoc "ModuleB.hs" "haskell" contentB
589 _ <- waitForDiagnostics
690 _ <- waitForDiagnostics
590 [CACodeAction action@CodeAction { _title = actionTitle }]
691 [CACodeAction action@CodeAction { _title = actionTitle }]
591 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -607,14 +708,14 @@ removeImportTests = testGroup "remove import actions"
607 , "stuffB = 123"
708 , "stuffB = 123"
608 , "stuffC = ()"
709 , "stuffC = ()"
609 ]
710 ]
610− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
611 let contentB = T.unlines
712 let contentB = T.unlines
612 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
713 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
613 , "module ModuleB where"
714 , "module ModuleB where"
614 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
715 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
615 , "main = print stuffB"
716 , "main = print stuffB"
616 ]
717 ]
617− docB <- openDoc' "ModuleB.hs" "haskell" contentB
718+ docB <- createDoc "ModuleB.hs" "haskell" contentB
618 _ <- waitForDiagnostics
719 _ <- waitForDiagnostics
619 [CACodeAction action@CodeAction { _title = actionTitle }]
720 [CACodeAction action@CodeAction { _title = actionTitle }]
620 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
721 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -628,29 +729,26 @@ removeImportTests = testGroup "remove import actions"
628 , "main = print stuffB"
729 , "main = print stuffB"
629 ]
730 ]
630 liftIO $ expectedContentAfterAction @=? contentAfterAction
731 liftIO $ expectedContentAfterAction @=? contentAfterAction
631− , testSession "redundant symbol binding" $ do
732+ , testSession "redundant operator" $ do
632 let contentA = T.unlines
733 let contentA = T.unlines
633 [ "module ModuleA where"
734 [ "module ModuleA where"
634 , "a !! b = a"
735 , "a !! b = a"
736+ , "a <?> b = a"
635 , "stuffB :: Integer"
737 , "stuffB :: Integer"
636 , "stuffB = 123"
738 , "stuffB = 123"
637 ]
739 ]
638− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
639 let contentB = T.unlines
741 let contentB = T.unlines
640 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
742 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
641 , "module ModuleB where"
743 , "module ModuleB where"
642− , "import qualified ModuleA as A ((!!), stuffB, (!!))"
744+ , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
643 , "main = print A.stuffB"
745 , "main = print A.stuffB"
644 ]
746 ]
645− docB <- openDoc' "ModuleB.hs" "haskell" contentB
747+ docB <- createDoc "ModuleB.hs" "haskell" contentB
646 _ <- waitForDiagnostics
748 _ <- waitForDiagnostics
647 [CACodeAction action@CodeAction { _title = actionTitle }]
749 [CACodeAction action@CodeAction { _title = actionTitle }]
648 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
750 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
649−#if MIN_GHC_API_VERSION(8,6,0)
650− liftIO $ "Remove !! from import" @=? actionTitle
651−#else
652− liftIO $ "Remove A.!! from import" @=? actionTitle
751+ liftIO $ "Remove !!, <?> from import" @=? actionTitle
653−#endif
654 executeCodeAction action
752 executeCodeAction action
655 contentAfterAction <- documentContents docB
753 contentAfterAction <- documentContents docB
656 let expectedContentAfterAction = T.unlines
754 let expectedContentAfterAction = T.unlines
@@ -660,21 +758,21 @@ removeImportTests = testGroup "remove import actions"
660 , "main = print A.stuffB"
758 , "main = print A.stuffB"
661 ]
759 ]
662 liftIO $ expectedContentAfterAction @=? contentAfterAction
760 liftIO $ expectedContentAfterAction @=? contentAfterAction
663− , (`xfail` "known broken (#299)") $ testSession "redundant hierarchical import" $ do
761+ , testSession "redundant all import" $ do
664 let contentA = T.unlines
762 let contentA = T.unlines
665 [ "module ModuleA where"
763 [ "module ModuleA where"
666 , "data A = A"
764 , "data A = A"
667 , "stuffB :: Integer"
765 , "stuffB :: Integer"
668 , "stuffB = 123"
766 , "stuffB = 123"
669 ]
767 ]
670− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
671 let contentB = T.unlines
769 let contentB = T.unlines
672 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
770 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
673 , "module ModuleB where"
771 , "module ModuleB where"
674 , "import ModuleA (A(..), stuffB)"
772 , "import ModuleA (A(..), stuffB)"
675 , "main = print stuffB"
773 , "main = print stuffB"
676 ]
774 ]
677− docB <- openDoc' "ModuleB.hs" "haskell" contentB
775+ docB <- createDoc "ModuleB.hs" "haskell" contentB
678 _ <- waitForDiagnostics
776 _ <- waitForDiagnostics
679 [CACodeAction action@CodeAction { _title = actionTitle }]
777 [CACodeAction action@CodeAction { _title = actionTitle }]
680 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
778 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -688,6 +786,33 @@ removeImportTests = testGroup "remove import actions"
688 , "main = print stuffB"
786 , "main = print stuffB"
689 ]
787 ]
690 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
691 ]
816 ]
692
817
693extendImportTests :: TestTree
818extendImportTests :: TestTree
@@ -712,6 +837,26 @@ extendImportTests = testGroup "extend import actions"
712 , "import ModuleA as A (stuffA, stuffB)"
837 , "import ModuleA as A (stuffA, stuffB)"
713 , "main = print (stuffA, stuffB)"
838 , "main = print (stuffA, stuffB)"
714 ])
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+ ])
715 , testSession "extend single line import with type" $ template
860 , testSession "extend single line import with type" $ template
716 (T.unlines
861 (T.unlines
717 [ "module ModuleA where"
862 [ "module ModuleA where"
@@ -795,8 +940,8 @@ extendImportTests = testGroup "extend import actions"
795 ]
940 ]
796 where
941 where
797 template contentA contentB range expectedAction expectedContentB = do
942 template contentA contentB range expectedAction expectedContentB = do
798− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
799− docB <- openDoc' "ModuleB.hs" "haskell" contentB
944+ docB <- createDoc "ModuleB.hs" "haskell" contentB
800 _ <- waitForDiagnostics
945 _ <- waitForDiagnostics
801 CACodeAction action@CodeAction { _title = actionTitle } : _
946 CACodeAction action@CodeAction { _title = actionTitle } : _
802 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
947 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -806,6 +951,117 @@ extendImportTests = testGroup "extend import actions"
806 contentAfterAction <- documentContents docB
951 contentAfterAction <- documentContents docB
807 liftIO $ expectedContentB @=? contentAfterAction
952 liftIO $ expectedContentB @=? contentAfterAction
808
953
954+suggestImportTests :: TestTree
955+suggestImportTests = testGroup "suggest import actions"
956+ [ testGroup "Dont want suggestion"
957+ [ -- extend import
958+ test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
959+ -- data constructor
960+ , test False [] "f = First" [] "import Data.Monoid (First)"
961+ -- internal module
962+ , test False [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable.Internal (Typeable)"
963+ -- package not in scope
964+ , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)"
965+ ]
966+ , testGroup "want suggestion"
967+ [ test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
968+ , test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))"
969+ , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)"
970+ , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (NonEmpty)"
971+ , test True [] "f = First" [] "import Data.Monoid (First(First))"
972+ , test True [] "f = Endo" [] "import Data.Monoid (Endo(Endo))"
973+ , test True [] "f = Version" [] "import Data.Version (Version(Version))"
974+ , test True [] "f ExitSuccess = ()" [] "import System.Exit (ExitCode(ExitSuccess))"
975+ , test True [] "f = AssertionFailed" [] "import Control.Exception (AssertionFailed(AssertionFailed))"
976+ , test True ["Prelude"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
977+ , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)"
978+ , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))"
979+ , test True [] "f = (&)" [] "import Data.Function ((&))"
980+ , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE"
981+ , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"
982+ , test True [] "f = pack" [] "import Data.Text (pack)"
983+ , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)"
984+ , test True [] "f = [] & id" [] "import Data.Function ((&))"
985+ , test True [] "f = (&) [] id" [] "import Data.Function ((&))"
986+ ]
987+ ]
988+ where
989+ test wanted imps def other newImp = testSession' (T.unpack def) $ \dir -> do
990+ let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other
991+ after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
992+ cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"
993+ liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
994+ doc <- createDoc "Test.hs" "haskell" before
995+ _diags <- waitForDiagnostics
996+ let defLine = length imps + 1
997+ range = Range (Position defLine 0) (Position defLine maxBound)
998+ actions <- getCodeActions doc range
999+ if wanted
1000+ then do
1001+ action <- liftIO $ pickActionWithTitle newImp actions
1002+ executeCodeAction action
1003+ contentAfterAction <- documentContents doc
1004+ liftIO $ after @=? contentAfterAction
1005+ else
1006+ liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
1007+
1008+
1009+addExtensionTests :: TestTree
1010+addExtensionTests = testGroup "add language extension actions"
1011+ [ testSession "add NamedFieldPuns language extension" $ template
1012+ (T.unlines
1013+ [ "module Module where"
1014+ , ""
1015+ , "data A = A { getA :: Bool }"
1016+ , ""
1017+ , "f :: A -> Bool"
1018+ , "f A { getA } = getA"
1019+ ])
1020+ (Range (Position 0 0) (Position 0 0))
1021+ "Add NamedFieldPuns extension"
1022+ (T.unlines
1023+ [ "{-# LANGUAGE NamedFieldPuns #-}"
1024+ , "module Module where"
1025+ , ""
1026+ , "data A = A { getA :: Bool }"
1027+ , ""
1028+ , "f :: A -> Bool"
1029+ , "f A { getA } = getA"
1030+ ])
1031+ , testSession "add RecordWildCards language extension" $ template
1032+ (T.unlines
1033+ [ "module Module where"
1034+ , ""
1035+ , "data A = A { getA :: Bool }"
1036+ , ""
1037+ , "f :: A -> Bool"
1038+ , "f A { .. } = getA"
1039+ ])
1040+ (Range (Position 0 0) (Position 0 0))
1041+ "Add RecordWildCards extension"
1042+ (T.unlines
1043+ [ "{-# LANGUAGE RecordWildCards #-}"
1044+ , "module Module where"
1045+ , ""
1046+ , "data A = A { getA :: Bool }"
1047+ , ""
1048+ , "f :: A -> Bool"
1049+ , "f A { .. } = getA"
1050+ ])
1051+ ]
1052+ where
1053+ template initialContent range expectedAction expectedContents = do
1054+ doc <- createDoc "Module.hs" "haskell" initialContent
1055+ _ <- waitForDiagnostics
1056+ CACodeAction action@CodeAction { _title = actionTitle } : _
1057+ <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1058+ getCodeActions doc range
1059+ liftIO $ expectedAction @=? actionTitle
1060+ executeCodeAction action
1061+ contentAfterAction <- documentContents doc
1062+ liftIO $ expectedContents @=? contentAfterAction
1063+
1064+
809insertNewDefinitionTests :: TestTree
1065insertNewDefinitionTests :: TestTree
810insertNewDefinitionTests = testGroup "insert new definition actions"
1066insertNewDefinitionTests = testGroup "insert new definition actions"
811 [ testSession "insert new function definition" $ do
1067 [ testSession "insert new function definition" $ do
@@ -818,7 +1074,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
818 [""
1074 [""
819 ,"someOtherCode = ()"
1075 ,"someOtherCode = ()"
820 ]
1076 ]
821− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
822 _ <- waitForDiagnostics
1078 _ <- waitForDiagnostics
823 CACodeAction action@CodeAction { _title = actionTitle } : _
1079 CACodeAction action@CodeAction { _title = actionTitle } : _
824 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1080 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -842,7 +1098,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
842 [""
1098 [""
843 ,"someOtherCode = ()"
1099 ,"someOtherCode = ()"
844 ]
1100 ]
845− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
846 _ <- waitForDiagnostics
1102 _ <- waitForDiagnostics
847 CACodeAction action@CodeAction { _title = actionTitle } : _
1103 CACodeAction action@CodeAction { _title = actionTitle } : _
848 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1104 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -881,8 +1137,8 @@ fixConstructorImportTests = testGroup "fix import actions"
881 ]
1137 ]
882 where
1138 where
883 template contentA contentB range expectedAction expectedContentB = do
1139 template contentA contentB range expectedAction expectedContentB = do
884− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
885− docB <- openDoc' "ModuleB.hs" "haskell" contentB
1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB
886 _diags <- waitForDiagnostics
1142 _diags <- waitForDiagnostics
887 CACodeAction action@CodeAction { _title = actionTitle } : _
1143 CACodeAction action@CodeAction { _title = actionTitle } : _
888 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1144 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -901,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"
901 [ "module Testing where"
1157 [ "module Testing where"
902 , "import Data.Mape"
1158 , "import Data.Mape"
903 ]
1159 ]
904− doc <- openDoc' "Testing.hs" "haskell" content
1160+ doc <- createDoc "Testing.hs" "haskell" content
905 _ <- waitForDiagnostics
1161 _ <- waitForDiagnostics
906 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
1162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
907 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 ]
@@ -938,10 +1194,10 @@ fillTypedHoleTests = let
938 newA newB newC = testSession (T.unpack actionTitle) $ do
1194 newA newB newC = testSession (T.unpack actionTitle) $ do
939 let originalCode = sourceCode oldA oldB oldC
1195 let originalCode = sourceCode oldA oldB oldC
940 let expectedCode = sourceCode newA newB newC
1196 let expectedCode = sourceCode newA newB newC
941− doc <- openDoc' "Testing.hs" "haskell" originalCode
1197+ doc <- createDoc "Testing.hs" "haskell" originalCode
942 _ <- waitForDiagnostics
1198 _ <- waitForDiagnostics
943 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
1199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
944− let chosenAction = pickActionWithTitle actionTitle actionsOrCommands
1200+ chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
945 executeCodeAction chosenAction
1201 executeCodeAction chosenAction
946 modifiedCode <- documentContents doc
1202 modifiedCode <- documentContents doc
947 liftIO $ expectedCode @=? modifiedCode
1203 liftIO $ expectedCode @=? modifiedCode
@@ -978,36 +1234,37 @@ fillTypedHoleTests = let
978
1234
979addSigActionTests :: TestTree
1235addSigActionTests :: TestTree
980addSigActionTests = let
1236addSigActionTests = let
981− header = "{-# OPTIONS_GHC -Wmissing-signatures #-}"
1237+ header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"
982− moduleH = "module Sigs where"
1238+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
983 before def = T.unlines [header, moduleH, def]
1239 before def = T.unlines [header, moduleH, def]
984 after' def sig = T.unlines [header, moduleH, sig, def]
1240 after' def sig = T.unlines [header, moduleH, sig, def]
985
1241
986 def >:: sig = testSession (T.unpack def) $ do
1242 def >:: sig = testSession (T.unpack def) $ do
987 let originalCode = before def
1243 let originalCode = before def
988 let expectedCode = after' def sig
1244 let expectedCode = after' def sig
989− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode
990 _ <- waitForDiagnostics
1246 _ <- waitForDiagnostics
991 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
1247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
992− let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
1248+ chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
993 executeCodeAction chosenAction
1249 executeCodeAction chosenAction
994 modifiedCode <- documentContents doc
1250 modifiedCode <- documentContents doc
995 liftIO $ expectedCode @=? modifiedCode
1251 liftIO $ expectedCode @=? modifiedCode
996 in
1252 in
997 testGroup "add signature"
1253 testGroup "add signature"
998− [ "abc = True" >:: "abc :: Bool"
1254+ [ "abc = True" >:: "abc :: Bool"
999− , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
1255+ , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"
1000− , "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"
1001− , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
1257+ , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"
1002− , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
1258+ , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"
1003− , "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"
1004 ]
1261 ]
1005
1262
1006addSigLensesTests :: TestTree
1263addSigLensesTests :: TestTree
1007addSigLensesTests = let
1264addSigLensesTests = let
1008− missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wunused-matches #-}"
1265+ missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"
1009 notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"
1266 notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"
1010− moduleH = "module Sigs where"
1267+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"
1011 other = T.unlines ["f :: Integer -> Integer", "f x = 3"]
1268 other = T.unlines ["f :: Integer -> Integer", "f x = 3"]
1012 before withMissing def
1269 before withMissing def
1013 = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]
1270 = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]
@@ -1017,49 +1274,41 @@ addSigLensesTests = let
1017 sigSession withMissing def sig = testSession (T.unpack def) $ do
1274 sigSession withMissing def sig = testSession (T.unpack def) $ do
1018 let originalCode = before withMissing def
1275 let originalCode = before withMissing def
1019 let expectedCode = after' withMissing def sig
1276 let expectedCode = after' withMissing def sig
1020− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode
1021 [CodeLens {_command = Just c}] <- getCodeLenses doc
1278 [CodeLens {_command = Just c}] <- getCodeLenses doc
1022 executeCommand c
1279 executeCommand c
1023 modifiedCode <- getDocumentEdit doc
1280 modifiedCode <- getDocumentEdit doc
1024 liftIO $ expectedCode @=? modifiedCode
1281 liftIO $ expectedCode @=? modifiedCode
1025 in
1282 in
1026 testGroup "add signature"
1283 testGroup "add signature"
1027− [ testGroup "with warnings enabled"
1284+ [ testGroup title
1028− [ sigSession True "abc = True" "abc :: Bool"
1285+ [ sigSession enableWarnings "abc = True" "abc :: Bool"
1029− , 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"
1030− , 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"
1031− , sigSession True "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
1288+ , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
1032− , sigSession True "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
1289+ , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
1033− , 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"
1034− ]
1291+ , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a"
1035− , testGroup "with warnings disabled"
1036− [ sigSession False "abc = True" "abc :: Bool"
1037− , sigSession False "foo a b = a + b" "foo :: Num a => a -> a -> a"
1038− , sigSession False "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"
1039− , sigSession False "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"
1040− , sigSession False "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"
1041− , sigSession False "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"
1042 ]
1292 ]
1293+ | (title, enableWarnings) <-
1294+ [("with warnings enabled", True)
1295+ ,("with warnings disabled", False)
1296+ ]
1043 ]
1297 ]
1044
1298
1045−findDefinitionAndHoverTests :: TestTree
1299+checkDefs :: [Location] -> Session [Expect] -> Session ()
1046−findDefinitionAndHoverTests = let
1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
1047
1301
1048− tst (get, check) pos targetRange title = testSession title $ do
1049− doc <- openTestDataDoc sourceFilePath
1050− found <- get doc pos
1051− check found targetRange
1052−
1053− checkDefs :: [Location] -> [Expect] -> Session ()
1054− checkDefs defs expectations = traverse_ check expectations where
1055−
1056− check (ExpectRange expectedRange) = do
1302+ check (ExpectRange expectedRange) = do
1057− assertNDefinitionsFound 1 defs
1303+ assertNDefinitionsFound 1 defs
1058− assertRangeCorrect (head defs) expectedRange
1304+ assertRangeCorrect (head defs) expectedRange
1305+ check (ExpectLocation expectedLocation) = do
1306+ assertNDefinitionsFound 1 defs
1307+ liftIO $ head defs @?= expectedLocation
1059− check ExpectNoDefinitions = do
1308+ check ExpectNoDefinitions = do
1060− assertNDefinitionsFound 0 defs
1309+ assertNDefinitionsFound 0 defs
1061− 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"
1062− check _ = pure () -- all other expectations not relevant to getDefinition
1311+ check _ = pure () -- all other expectations not relevant to getDefinition
1063
1312
1064 assertNDefinitionsFound :: Int -> [a] -> Session ()
1313 assertNDefinitionsFound :: Int -> [a] -> Session ()
1065 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
1314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
@@ -1067,8 +1316,19 @@ findDefinitionAndHoverTests = let
1067 assertRangeCorrect Location{_range = foundRange} expectedRange =
1316 assertRangeCorrect Location{_range = foundRange} expectedRange =
1068 liftIO $ expectedRange @=? foundRange
1317 liftIO $ expectedRange @=? foundRange
1069
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+
1070− checkHover :: Maybe Hover -> [Expect] -> Session ()
1330+ checkHover :: Maybe Hover -> Session [Expect] -> Session ()
1071− checkHover hover expectations = traverse_ check expectations where
1331+ checkHover hover expectations = traverse_ check =<< expectations where
1072
1332
1073 check expected =
1333 check expected =
1074 case hover of
1334 case hover of
@@ -1111,9 +1371,12 @@ findDefinitionAndHoverTests = let
1111
1371
1112 mkFindTests tests = testGroup "get"
1372 mkFindTests tests = testGroup "get"
1113 [ testGroup "definition" $ mapMaybe fst tests
1373 [ testGroup "definition" $ mapMaybe fst tests
1114− , testGroup "hover" $ mapMaybe snd tests ]
1374+ , testGroup "hover" $ mapMaybe snd tests
1375+ , checkFileCompiles sourceFilePath ]
1376+
1377+ test runDef runHover look expect = testM runDef runHover look (return expect)
1115
1378
1116− test runDef runHover look expect title =
1379+ testM runDef runHover look expect title =
1117 ( runDef $ tst def look expect title
1380 ( runDef $ tst def look expect title
1118 , runHover $ tst hover look expect title ) where
1381 , runHover $ tst hover look expect title ) where
1119 def = (getDefinitions, checkDefs)
1382 def = (getDefinitions, checkDefs)
@@ -1121,87 +1384,100 @@ findDefinitionAndHoverTests = let
1121 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
1384 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
1122
1385
1123 -- search locations expectations on results
1386 -- search locations expectations on results
1124− 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]
1125− fffL8 = Position 8 4 ;
1388+ fffL8 = Position 12 4 ;
1126− fffL14 = Position 14 7 ;
1389+ fffL14 = Position 18 7 ;
1127− aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]
1390+ aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]
1128− dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]
1391+ dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]
1129− dcL12 = Position 12 11 ;
1392+ dcL12 = Position 16 11 ;
1130− 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’"]]
1131− 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"]]
1132− vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]
1395+ vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6]
1133− opL16 = Position 16 15 ; op = [mkR 17 2 17 4]
1396+ opL16 = Position 20 15 ; op = [mkR 21 2 21 4]
1134− opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]
1397+ opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]
1135− aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]
1398+ aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]
1136− b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]
1399+ b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]
1137− 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"]]
1138− 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"]]
1139− clL25 = Position 25 9
1402+ clL25 = Position 29 9
1140− 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’"]]
1141− dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]
1404+ dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21]
1142− dnbL30 = Position 30 23
1405+ dnbL30 = Position 34 23
1143− 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]
1144− lclL33 = Position 33 22
1407+ lclL33 = Position 37 22
1145− mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14]
1408+ mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14]
1146− mclL37 = Position 37 1
1409+ mclL37 = Position 41 1
1147− spaceL37 = Position 37 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1410+ spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1148− docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1411+ docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1149− ; constr = [ExpectHoverText ["Monad m =>"]]
1412+ ; constr = [ExpectHoverText ["Monad m"]]
1150− eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1413+ eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1151− intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]]
1414+ intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]]
1152− tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1415+ tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1153− intL41 = Position 41 20 ; litI = [ExpectHoverText ["7518"]]
1416+ intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]]
1154− chrL36 = Position 37 24 ; litC = [ExpectHoverText ["'f'"]]
1417+ chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]]
1155− txtL8 = Position 8 14 ; litT = [ExpectHoverText ["\"dfgv\""]]
1418+ txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1156− lstL43 = Position 43 12 ; litL = [ExpectHoverText ["[ 8391 :: Int, 6268 ]"]]
1419+ lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1157− 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]
1158− 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]
1159 in
1424 in
1160 mkFindTests
1425 mkFindTests
1161− -- def hover look expect
1426+ -- def hover look expect
1162− [ test yes yes fffL4 fff "field in record definition"
1427+ [ test yes yes fffL4 fff "field in record definition"
1163− , test broken broken fffL8 fff "field in record construction #71"
1428+ , test broken broken fffL8 fff "field in record construction #71"
1164− , 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
1165− , test yes yes aaaL14 aaa "top-level name" -- 120
1430+ , test yes yes aaaL14 aaa "top-level name" -- 120
1166− , test yes yes dcL7 tcDC "data constructor record #247"
1431+ , test yes yes dcL7 tcDC "data constructor record #247"
1167− , test yes yes dcL12 tcDC "data constructor plain" -- 121
1432+ , test yes yes dcL12 tcDC "data constructor plain" -- 121
1168− , test yes yes tcL6 tcData "type constructor #248" -- 147
1433+ , test yes yes tcL6 tcData "type constructor #248" -- 147
1169− , test broken yes xtcL5 xtc "type constructor external #248,249"
1434+ , test broken yes xtcL5 xtc "type constructor external #248,249"
1170− , test broken yes xvL20 xvMsg "value external package #249" -- 120
1435+ , test broken yes xvL20 xvMsg "value external package #249" -- 120
1171− , test yes yes vvL16 vv "plain parameter" -- 120
1436+ , test yes yes vvL16 vv "plain parameter" -- 120
1172− , test yes yes aL18 apmp "pattern match name" -- 120
1437+ , test yes yes aL18 apmp "pattern match name" -- 120
1173− , test yes yes opL16 op "top-level operator" -- 120, 123
1438+ , test yes yes opL16 op "top-level operator" -- 120, 123
1174− , test yes yes opL18 opp "parameter operator" -- 120
1439+ , test yes yes opL18 opp "parameter operator" -- 120
1175− , test yes yes b'L19 bp "name in backticks" -- 120
1440+ , test yes yes b'L19 bp "name in backticks" -- 120
1176− , test yes yes clL23 cls "class in instance declaration #250"
1441+ , test yes yes clL23 cls "class in instance declaration #250"
1177− , test yes yes clL25 cls "class in signature #250" -- 147
1442+ , test yes yes clL25 cls "class in signature #250" -- 147
1178− , test broken yes eclL15 ecls "external class in signature #249,250"
1443+ , test broken yes eclL15 ecls "external class in signature #249,250"
1179− , test yes yes dnbL29 dnb "do-notation bind" -- 137
1444+ , test yes yes dnbL29 dnb "do-notation bind" -- 137
1180− , test yes yes dnbL30 dnb "do-notation lookup"
1445+ , test yes yes dnbL30 dnb "do-notation lookup"
1181− , test yes yes lcbL33 lcb "listcomp bind" -- 137
1446+ , test yes yes lcbL33 lcb "listcomp bind" -- 137
1182− , test yes yes lclL33 lcb "listcomp lookup"
1447+ , test yes yes lclL33 lcb "listcomp lookup"
1183− , test yes yes mclL36 mcl "top-level fn 1st clause"
1448+ , test yes yes mclL36 mcl "top-level fn 1st clause"
1184− , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1449+ , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1185− , test yes yes spaceL37 space "top-level fn on space #315"
1450+ , test yes yes spaceL37 space "top-level fn on space #315"
1186− , test no broken docL41 doc "documentation #7"
1451+ , test no broken docL41 doc "documentation #7"
1187− , test no yes eitL40 kindE "kind of Either #273"
1452+ , test no yes eitL40 kindE "kind of Either #273"
1188− , test no yes intL40 kindI "kind of Int #273"
1453+ , test no yes intL40 kindI "kind of Int #273"
1189− , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1454+ , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1190− , test no yes intL41 litI "literal Int in hover info #274"
1455+ , test no yes intL41 litI "literal Int in hover info #274"
1191− , test no yes chrL36 litC "literal Char in hover info #274"
1456+ , test no yes chrL36 litC "literal Char in hover info #274"
1192− , test no broken txtL8 litT "literal Text in hover info #274"
1457+ , test no yes txtL8 litT "literal Text in hover info #274"
1193− , test no broken lstL43 litL "literal List in hover info #274"
1458+ , test no yes lstL43 litL "literal List in hover info #274"
1194− , test no broken docL41 constr "type constraint in hover info #283"
1459+ , test no yes docL41 constr "type constraint in hover info #283"
1195− , test broken broken outL45 outSig "top-level signature #310"
1460+ , test broken broken outL45 outSig "top-level signature #310"
1196− , 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)"
1197 ]
1464 ]
1198 where yes, broken :: (TestTree -> Maybe TestTree)
1465 where yes, broken :: (TestTree -> Maybe TestTree)
1199 yes = Just -- test should run and pass
1466 yes = Just -- test should run and pass
1200 broken = Just . (`xfail` "known broken")
1467 broken = Just . (`xfail` "known broken")
1201 no = const Nothing -- don't run this test at all
1468 no = const Nothing -- don't run this test at all
1202
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+
1203pluginTests :: TestTree
1478pluginTests :: TestTree
1479+pluginTests = (`xfail8101` "known broken (#556)")
1204−pluginTests = testSessionWait "plugins" $ do
1480+ $ testSessionWait "plugins" $ do
1205 let content =
1481 let content =
1206 T.unlines
1482 T.unlines
1207 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
1483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
@@ -1215,7 +1491,7 @@ pluginTests = testSessionWait "plugins" $ do
1215 , "foo :: Int -> Int -> Int"
1491 , "foo :: Int -> Int -> Int"
1216 , "foo a b = a + c"
1492 , "foo a b = a + c"
1217 ]
1493 ]
1218− _ <- openDoc' "Testing.hs" "haskell" content
1494+ _ <- createDoc "Testing.hs" "haskell" content
1219 expectDiagnostics
1495 expectDiagnostics
1220 [ ( "Testing.hs",
1496 [ ( "Testing.hs",
1221 [(DsError, (8, 14), "Variable not in scope: c")]
1497 [(DsError, (8, 14), "Variable not in scope: c")]
@@ -1224,26 +1500,39 @@ pluginTests = testSessionWait "plugins" $ do
1224
1500
1225cppTests :: TestTree
1501cppTests :: TestTree
1226cppTests =
1502cppTests =
1503+ testGroup "cpp"
1227− testCase "cpp" $ do
1504+ [ testCase "cpp-error" $ do
1228− let content =
1505+ let content =
1229− T.unlines
1506+ T.unlines
1230− [ "{-# LANGUAGE CPP #-}",
1507+ [ "{-# LANGUAGE CPP #-}",
1231− "module Testing where",
1508+ "module Testing where",
1232− "#ifdef FOO",
1509+ "#ifdef FOO",
1233− "foo = 42"
1510+ "foo = 42"
1234− ]
1511+ ]
1235− -- The error locations differ depending on which C-preprocessor is used.
1512+ -- The error locations differ depending on which C-preprocessor is used.
1236− -- Some give the column number and others don't (hence -1). Assert either
1513+ -- Some give the column number and others don't (hence -1). Assert either
1237− -- of them.
1514+ -- of them.
1238− (run $ expectError content (2, -1))
1515+ (run $ expectError content (2, -1))
1239− `catch` ( \e -> do
1516+ `catch` ( \e -> do
1240− let _ = e :: HUnitFailure
1517+ let _ = e :: HUnitFailure
1241− run $ expectError content (2, 1)
1518+ run $ expectError content (2, 1)
1242− )
1519+ )
1520+ , testSessionWait "cpp-ghcide" $ do
1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines
1522+ ["{-# LANGUAGE CPP #-}"
1523+ ,"main ="
1524+ ,"#ifdef __GHCIDE__"
1525+ ," worked"
1526+ ,"#else"
1527+ ," failed"
1528+ ,"#endif"
1529+ ]
1530+ expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])]
1531+ ]
1243 where
1532 where
1244 expectError :: T.Text -> Cursor -> Session ()
1533 expectError :: T.Text -> Cursor -> Session ()
1245 expectError content cursor = do
1534 expectError content cursor = do
1246− _ <- openDoc' "Testing.hs" "haskell" content
1535+ _ <- createDoc "Testing.hs" "haskell" content
1247 expectDiagnostics
1536 expectDiagnostics
1248 [ ( "Testing.hs",
1537 [ ( "Testing.hs",
1249 [(DsError, cursor, "error: unterminated")]
1538 [(DsError, cursor, "error: unterminated")]
@@ -1259,13 +1548,43 @@ preprocessorTests = testSessionWait "preprocessor" $ do
1259 , "module Testing where"
1548 , "module Testing where"
1260 , "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
1261 ]
1550 ]
1262− _ <- openDoc' "Testing.hs" "haskell" content
1551+ _ <- createDoc "Testing.hs" "haskell" content
1263 expectDiagnostics
1552 expectDiagnostics
1264 [ ( "Testing.hs",
1553 [ ( "Testing.hs",
1265 [(DsError, (2, 8), "Variable not in scope: z")]
1554 [(DsError, (2, 8), "Variable not in scope: z")]
1266 )
1555 )
1267 ]
1556 ]
1268
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+
1269thTests :: TestTree
1588thTests :: TestTree
1270thTests =
1589thTests =
1271 testGroup
1590 testGroup
@@ -1291,9 +1610,30 @@ thTests =
1291 "b :: Integer",
1610 "b :: Integer",
1292 "b = $(litE $ IntegerL $ a) + n"
1611 "b = $(litE $ IntegerL $ a) + n"
1293 ]
1612 ]
1294− _ <- openDoc' "A.hs" "haskell" sourceA
1613+ _ <- createDoc "A.hs" "haskell" sourceA
1295− _ <- openDoc' "B.hs" "haskell" sourceB
1614+ _ <- createDoc "B.hs" "haskell" sourceB
1296 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 ()
1297 ]
1637 ]
1298
1638
1299completionTests :: TestTree
1639completionTests :: TestTree
@@ -1301,31 +1641,31 @@ completionTests
1301 = testGroup "completion"
1641 = testGroup "completion"
1302 [ testSessionWait "variable" $ do
1642 [ testSessionWait "variable" $ do
1303 let source = T.unlines ["module A where", "f = hea"]
1643 let source = T.unlines ["module A where", "f = hea"]
1304− docId <- openDoc' "A.hs" "haskell" source
1644+ docId <- createDoc "A.hs" "haskell" source
1305 compls <- getCompletions docId (Position 1 7)
1645 compls <- getCompletions docId (Position 1 7)
1306− liftIO $ map dropDocs compls @?=
1646+ liftIO $ map dropDocs compls @?=
1307 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1647 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1308 let [CompletionItem { _documentation = headDocs}] = compls
1648 let [CompletionItem { _documentation = headDocs}] = compls
1309 checkDocText "head" headDocs [ "Defined in 'Prelude'"
1649 checkDocText "head" headDocs [ "Defined in 'Prelude'"
1310−#if MIN_GHC_API_VERSION(8,6,0)
1650+#if MIN_GHC_API_VERSION(8,6,5)
1311 , "Extract the first element of a list"
1651 , "Extract the first element of a list"
1312#endif
1652#endif
1313 ]
1653 ]
1314 , testSessionWait "constructor" $ do
1654 , testSessionWait "constructor" $ do
1315 let source = T.unlines ["module A where", "f = Tru"]
1655 let source = T.unlines ["module A where", "f = Tru"]
1316− docId <- openDoc' "A.hs" "haskell" source
1656+ docId <- createDoc "A.hs" "haskell" source
1317 compls <- getCompletions docId (Position 1 7)
1657 compls <- getCompletions docId (Position 1 7)
1318− liftIO $ map dropDocs compls @?=
1658+ liftIO $ map dropDocs compls @?=
1319 [ complItem "True" (Just CiConstructor) (Just "Bool")
1659 [ complItem "True" (Just CiConstructor) (Just "Bool")
1320#if MIN_GHC_API_VERSION(8,6,0)
1660#if MIN_GHC_API_VERSION(8,6,0)
1321 , complItem "truncate" (Just CiFunction) (Just "(RealFrac a, Integral b) => a -> b")
1661 , complItem "truncate" (Just CiFunction) (Just "(RealFrac a, Integral b) => a -> b")
1322#else
1662#else
1323− , complItem "truncate" (Just CiFunction) (Just "RealFrac a => forall b. Integral b => a -> b")
1663+ , complItem "truncate" (Just CiFunction) (Just "RealFrac a => forall b. Integral b => a -> b")
1324#endif
1664#endif
1325 ]
1665 ]
1326 , testSessionWait "type" $ do
1666 , testSessionWait "type" $ do
1327 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 = ()"]
1328− docId <- openDoc' "A.hs" "haskell" source
1668+ docId <- createDoc "A.hs" "haskell" source
1329 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1669 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1330 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"]]
1331 compls <- getCompletions docId (Position 2 7)
1671 compls <- getCompletions docId (Position 2 7)
@@ -1335,25 +1675,51 @@ completionTests
1335 let [ CompletionItem { _documentation = boundedDocs},
1675 let [ CompletionItem { _documentation = boundedDocs},
1336 CompletionItem { _documentation = boolDocs } ] = compls
1676 CompletionItem { _documentation = boolDocs } ] = compls
1337 checkDocText "Bounded" boundedDocs [ "Defined in 'Prelude'"
1677 checkDocText "Bounded" boundedDocs [ "Defined in 'Prelude'"
1338−#if MIN_GHC_API_VERSION(8,6,0)
1678+#if MIN_GHC_API_VERSION(8,6,5)
1339 , "name the upper and lower limits"
1679 , "name the upper and lower limits"
1340#endif
1680#endif
1341 ]
1681 ]
1342 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1682 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1343 , testSessionWait "qualified" $ do
1683 , testSessionWait "qualified" $ do
1344 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 = ()"]
1345− docId <- openDoc' "A.hs" "haskell" source
1685+ docId <- createDoc "A.hs" "haskell" source
1346 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1686 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1347 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"]]
1348 compls <- getCompletions docId (Position 2 15)
1688 compls <- getCompletions docId (Position 2 15)
1349− liftIO $ map dropDocs compls @?=
1689+ liftIO $ map dropDocs compls @?=
1350 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1690 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1351 let [CompletionItem { _documentation = headDocs}] = compls
1691 let [CompletionItem { _documentation = headDocs}] = compls
1352 checkDocText "head" headDocs [ "Defined in 'Prelude'"
1692 checkDocText "head" headDocs [ "Defined in 'Prelude'"
1353−#if MIN_GHC_API_VERSION(8,6,0)
1693+#if MIN_GHC_API_VERSION(8,6,5)
1354 , "Extract the first element of a list"
1694 , "Extract the first element of a list"
1355#endif
1695#endif
1356 ]
1696 ]
1697+ , testSessionWait "keyword" $ do
1698+ let source = T.unlines ["module A where", "f = newty"]
1699+ docId <- createDoc "A.hs" "haskell" source
1700+ compls <- getCompletions docId (Position 1 9)
1701+ liftIO $ compls @?= [keywordItem "newtype"]
1702+ , testSessionWait "type context" $ do
1703+ let source = T.unlines
1704+ [ "{-# OPTIONS_GHC -Wunused-binds #-}"
1705+ , "module A () where"
1706+ , "f = f"
1707+ ]
1708+ docId <- createDoc "A.hs" "haskell" source
1709+ expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]
1710+ changeDoc docId
1711+ [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
1712+ [ "{-# OPTIONS_GHC -Wunused-binds #-}"
1713+ , "module A () where"
1714+ , "f = f"
1715+ , "g :: Intege"
1716+ ]
1717+ ]
1718+ -- At this point the module parses but does not typecheck.
1719+ -- This should be sufficient to detect that we are in a
1720+ -- type context and only show the completion to the type.
1721+ compls <- getCompletions docId (Position 3 11)
1722+ liftIO $ map dropDocs compls @?= [complItem "Integer"(Just CiStruct) (Just "*")]
1357 ]
1723 ]
1358 where
1724 where
1359 dropDocs :: CompletionItem -> CompletionItem
1725 dropDocs :: CompletionItem -> CompletionItem
@@ -1361,6 +1727,7 @@ completionTests
1361 complItem label kind ty = CompletionItem
1727 complItem label kind ty = CompletionItem
1362 { _label = label
1728 { _label = label
1363 , _kind = kind
1729 , _kind = kind
1730+ , _tags = List []
1364 , _detail = (":: " <>) <$> ty
1731 , _detail = (":: " <>) <$> ty
1365 , _documentation = Nothing
1732 , _documentation = Nothing
1366 , _deprecated = Nothing
1733 , _deprecated = Nothing
@@ -1375,6 +1742,24 @@ completionTests
1375 , _command = Nothing
1742 , _command = Nothing
1376 , _xdata = Nothing
1743 , _xdata = Nothing
1377 }
1744 }
1745+ keywordItem label = CompletionItem
1746+ { _label = label
1747+ , _kind = Just CiKeyword
1748+ , _tags = List []
1749+ , _detail = Nothing
1750+ , _documentation = Nothing
1751+ , _deprecated = Nothing
1752+ , _preselect = Nothing
1753+ , _sortText = Nothing
1754+ , _filterText = Nothing
1755+ , _insertText = Nothing
1756+ , _insertTextFormat = Nothing
1757+ , _textEdit = Nothing
1758+ , _additionalTextEdits = Nothing
1759+ , _commitCharacters = Nothing
1760+ , _command = Nothing
1761+ , _xdata = Nothing
1762+ }
1378 getDocText (CompletionDocString s) = s
1763 getDocText (CompletionDocString s) = s
1379 getDocText (CompletionDocMarkup (MarkupContent _ s)) = s
1764 getDocText (CompletionDocMarkup (MarkupContent _ s)) = s
1380 checkDocText thing Nothing _
1765 checkDocText thing Nothing _
@@ -1388,7 +1773,7 @@ outlineTests = testGroup
1388 "outline"
1773 "outline"
1389 [ testSessionWait "type class" $ do
1774 [ testSessionWait "type class" $ do
1390 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"]
1391− docId <- openDoc' "A.hs" "haskell" source
1776+ docId <- createDoc "A.hs" "haskell" source
1392 symbols <- getDocumentSymbols docId
1777 symbols <- getDocumentSymbols docId
1393 liftIO $ symbols @?= Left
1778 liftIO $ symbols @?= Left
1394 [ moduleSymbol
1779 [ moduleSymbol
@@ -1401,7 +1786,7 @@ outlineTests = testGroup
1401 ]
1786 ]
1402 , testSessionWait "type class instance " $ do
1787 , testSessionWait "type class instance " $ do
1403 let source = T.unlines ["class A a where", "instance A () where"]
1788 let source = T.unlines ["class A a where", "instance A () where"]
1404− docId <- openDoc' "A.hs" "haskell" source
1789+ docId <- createDoc "A.hs" "haskell" source
1405 symbols <- getDocumentSymbols docId
1790 symbols <- getDocumentSymbols docId
1406 liftIO $ symbols @?= Left
1791 liftIO $ symbols @?= Left
1407 [ classSymbol "A a" (R 0 0 0 15) []
1792 [ classSymbol "A a" (R 0 0 0 15) []
@@ -1409,7 +1794,7 @@ outlineTests = testGroup
1409 ]
1794 ]
1410 , testSessionWait "type family" $ do
1795 , testSessionWait "type family" $ do
1411 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1796 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1412− docId <- openDoc' "A.hs" "haskell" source
1797+ docId <- createDoc "A.hs" "haskell" source
1413 symbols <- getDocumentSymbols docId
1798 symbols <- getDocumentSymbols docId
1414 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)]
1415 , testSessionWait "type family instance " $ do
1800 , testSessionWait "type family instance " $ do
@@ -1418,7 +1803,7 @@ outlineTests = testGroup
1418 , "type family A a"
1803 , "type family A a"
1419 , "type instance A () = ()"
1804 , "type instance A () = ()"
1420 ]
1805 ]
1421− docId <- openDoc' "A.hs" "haskell" source
1806+ docId <- createDoc "A.hs" "haskell" source
1422 symbols <- getDocumentSymbols docId
1807 symbols <- getDocumentSymbols docId
1423 liftIO $ symbols @?= Left
1808 liftIO $ symbols @?= Left
1424 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
1809 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
@@ -1426,7 +1811,7 @@ outlineTests = testGroup
1426 ]
1811 ]
1427 , testSessionWait "data family" $ do
1812 , testSessionWait "data family" $ do
1428 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1813 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1429− docId <- openDoc' "A.hs" "haskell" source
1814+ docId <- createDoc "A.hs" "haskell" source
1430 symbols <- getDocumentSymbols docId
1815 symbols <- getDocumentSymbols docId
1431 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)]
1432 , testSessionWait "data family instance " $ do
1817 , testSessionWait "data family instance " $ do
@@ -1435,7 +1820,7 @@ outlineTests = testGroup
1435 , "data family A a"
1820 , "data family A a"
1436 , "data instance A () = A ()"
1821 , "data instance A () = A ()"
1437 ]
1822 ]
1438− docId <- openDoc' "A.hs" "haskell" source
1823+ docId <- createDoc "A.hs" "haskell" source
1439 symbols <- getDocumentSymbols docId
1824 symbols <- getDocumentSymbols docId
1440 liftIO $ symbols @?= Left
1825 liftIO $ symbols @?= Left
1441 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
1826 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
@@ -1443,36 +1828,36 @@ outlineTests = testGroup
1443 ]
1828 ]
1444 , testSessionWait "constant" $ do
1829 , testSessionWait "constant" $ do
1445 let source = T.unlines ["a = ()"]
1830 let source = T.unlines ["a = ()"]
1446− docId <- openDoc' "A.hs" "haskell" source
1831+ docId <- createDoc "A.hs" "haskell" source
1447 symbols <- getDocumentSymbols docId
1832 symbols <- getDocumentSymbols docId
1448 liftIO $ symbols @?= Left
1833 liftIO $ symbols @?= Left
1449 [docSymbol "a" SkFunction (R 0 0 0 6)]
1834 [docSymbol "a" SkFunction (R 0 0 0 6)]
1450 , testSessionWait "pattern" $ do
1835 , testSessionWait "pattern" $ do
1451 let source = T.unlines ["Just foo = Just 21"]
1836 let source = T.unlines ["Just foo = Just 21"]
1452− docId <- openDoc' "A.hs" "haskell" source
1837+ docId <- createDoc "A.hs" "haskell" source
1453 symbols <- getDocumentSymbols docId
1838 symbols <- getDocumentSymbols docId
1454 liftIO $ symbols @?= Left
1839 liftIO $ symbols @?= Left
1455 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1840 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1456 , testSessionWait "pattern with type signature" $ do
1841 , testSessionWait "pattern with type signature" $ do
1457 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1842 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1458− docId <- openDoc' "A.hs" "haskell" source
1843+ docId <- createDoc "A.hs" "haskell" source
1459 symbols <- getDocumentSymbols docId
1844 symbols <- getDocumentSymbols docId
1460 liftIO $ symbols @?= Left
1845 liftIO $ symbols @?= Left
1461 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1846 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1462 , testSessionWait "function" $ do
1847 , testSessionWait "function" $ do
1463 let source = T.unlines ["a x = ()"]
1848 let source = T.unlines ["a x = ()"]
1464− docId <- openDoc' "A.hs" "haskell" source
1849+ docId <- createDoc "A.hs" "haskell" source
1465 symbols <- getDocumentSymbols docId
1850 symbols <- getDocumentSymbols docId
1466 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1851 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1467 , testSessionWait "type synonym" $ do
1852 , testSessionWait "type synonym" $ do
1468 let source = T.unlines ["type A = Bool"]
1853 let source = T.unlines ["type A = Bool"]
1469− docId <- openDoc' "A.hs" "haskell" source
1854+ docId <- createDoc "A.hs" "haskell" source
1470 symbols <- getDocumentSymbols docId
1855 symbols <- getDocumentSymbols docId
1471 liftIO $ symbols @?= Left
1856 liftIO $ symbols @?= Left
1472 [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)]
1473 , testSessionWait "datatype" $ do
1858 , testSessionWait "datatype" $ do
1474 let source = T.unlines ["data A = C"]
1859 let source = T.unlines ["data A = C"]
1475− docId <- openDoc' "A.hs" "haskell" source
1860+ docId <- createDoc "A.hs" "haskell" source
1476 symbols <- getDocumentSymbols docId
1861 symbols <- getDocumentSymbols docId
1477 liftIO $ symbols @?= Left
1862 liftIO $ symbols @?= Left
1478 [ docSymbolWithChildren "A"
1863 [ docSymbolWithChildren "A"
@@ -1480,18 +1865,47 @@ outlineTests = testGroup
1480 (R 0 0 0 10)
1865 (R 0 0 0 10)
1481 [docSymbol "C" SkConstructor (R 0 9 0 10)]
1866 [docSymbol "C" SkConstructor (R 0 9 0 10)]
1482 ]
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+ ]
1483 , testSessionWait "import" $ do
1880 , testSessionWait "import" $ do
1484 let source = T.unlines ["import Data.Maybe"]
1881 let source = T.unlines ["import Data.Maybe"]
1882+ docId <- createDoc "A.hs" "haskell" source
1883+ symbols <- getDocumentSymbols docId
1884+ liftIO $ symbols @?= Left
1885+ [docSymbolWithChildren "imports"
1886+ SkModule
1887+ (R 0 0 0 17)
1888+ [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)
1889+ ]
1890+ ]
1891+ , testSessionWait "multiple import" $ do
1892+ let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]
1485− docId <- openDoc' "A.hs" "haskell" source
1893+ docId <- createDoc "A.hs" "haskell" source
1486 symbols <- getDocumentSymbols docId
1894 symbols <- getDocumentSymbols docId
1487 liftIO $ symbols @?= Left
1895 liftIO $ symbols @?= Left
1896+ [docSymbolWithChildren "imports"
1897+ SkModule
1898+ (R 1 0 3 24)
1488− [docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)]
1899+ [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 17)
1900+ , docSymbol "import Control.Exception" SkModule (R 3 0 3 24)
1901+ ]
1902+ ]
1489 , testSessionWait "foreign import" $ do
1903 , testSessionWait "foreign import" $ do
1490 let source = T.unlines
1904 let source = T.unlines
1491 [ "{-# language ForeignFunctionInterface #-}"
1905 [ "{-# language ForeignFunctionInterface #-}"
1492 , "foreign import ccall \"a\" a :: Int"
1906 , "foreign import ccall \"a\" a :: Int"
1493 ]
1907 ]
1494− docId <- openDoc' "A.hs" "haskell" source
1908+ docId <- createDoc "A.hs" "haskell" source
1495 symbols <- getDocumentSymbols docId
1909 symbols <- getDocumentSymbols docId
1496 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)]
1497 , testSessionWait "foreign export" $ do
1911 , testSessionWait "foreign export" $ do
@@ -1499,7 +1913,7 @@ outlineTests = testGroup
1499 [ "{-# language ForeignFunctionInterface #-}"
1913 [ "{-# language ForeignFunctionInterface #-}"
1500 , "foreign export ccall odd :: Int -> Bool"
1914 , "foreign export ccall odd :: Int -> Bool"
1501 ]
1915 ]
1502− docId <- openDoc' "A.hs" "haskell" source
1916+ docId <- createDoc "A.hs" "haskell" source
1503 symbols <- getDocumentSymbols docId
1917 symbols <- getDocumentSymbols docId
1504 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)]
1505 ]
1919 ]
@@ -1512,6 +1926,8 @@ outlineTests = testGroup
1512 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1926 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1513 docSymbolWithChildren name kind loc cc =
1927 docSymbolWithChildren name kind loc cc =
1514 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)
1515 moduleSymbol name loc cc = DocumentSymbol name
1931 moduleSymbol name loc cc = DocumentSymbol name
1516 Nothing
1932 Nothing
1517 SkFile
1933 SkFile
@@ -1533,8 +1949,16 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')
1533xfail :: TestTree -> String -> TestTree
1949xfail :: TestTree -> String -> TestTree
1534xfail = flip expectFailBecause
1950xfail = flip expectFailBecause
1535
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+
1536data Expect
1959data Expect
1537 = ExpectRange Range -- Both gotoDef and hover should report this range
1960 = ExpectRange Range -- Both gotoDef and hover should report this range
1961+ | ExpectLocation Location
1538-- | ExpectDefRange Range -- Only gotoDef should report this range
1962-- | ExpectDefRange Range -- Only gotoDef should report this range
1539 | ExpectHoverRange Range -- Only hover should report this range
1963 | ExpectHoverRange Range -- Only hover should report this range
1540 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
1964 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
@@ -1546,6 +1970,226 @@ data Expect
1546
1970
1547mkR :: Int -> Int -> Int -> Int -> Expect
1971mkR :: Int -> Int -> Int -> Int -> Expect
1548mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
1972mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
1973+
1974+mkL :: Uri -> Int -> Int -> Int -> Int -> Expect
1975+mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn
1976+
1977+haddockTests :: TestTree
1978+haddockTests
1979+ = testGroup "haddock"
1980+ [ testCase "Num" $ checkHaddock
1981+ (unlines
1982+ [ "However, '(+)' and '(*)' are"
1983+ , "customarily expected to define a ring and have the following properties:"
1984+ , ""
1985+ , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@"
1986+ , "[__Commutativity of (+)__]: @x + y@ = @y + x@"
1987+ , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@"
1988+ ]
1989+ )
1990+ (unlines
1991+ [ ""
1992+ , ""
1993+ , "However, `(+)` and `(*)` are"
1994+ , "customarily expected to define a ring and have the following properties: "
1995+ , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`"
1996+ , "+ ****Commutativity of (+)****: `x + y` = `y + x`"
1997+ , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`"
1998+ ]
1999+ )
2000+ , testCase "unsafePerformIO" $ checkHaddock
2001+ (unlines
2002+ [ "may require"
2003+ , "different precautions:"
2004+ , ""
2005+ , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"
2006+ , " that calls 'unsafePerformIO'. If the call is inlined,"
2007+ , " the I\\/O may be performed more than once."
2008+ , ""
2009+ , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression"
2010+ , " elimination being performed on the module."
2011+ , ""
2012+ ]
2013+ )
2014+ (unlines
2015+ [ ""
2016+ , ""
2017+ , "may require"
2018+ , "different precautions: "
2019+ , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` "
2020+ , " that calls `unsafePerformIO` . If the call is inlined,"
2021+ , " the I/O may be performed more than once."
2022+ , ""
2023+ , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression"
2024+ , " elimination being performed on the module."
2025+ , ""
2026+ ]
2027+ )
2028+ ]
2029+ where
2030+ checkHaddock s txt = spanDocToMarkdownForTest s @?= txt
2031+
2032+cradleTests :: TestTree
2033+cradleTests = testGroup "cradle"
2034+ [testGroup "dependencies" [sessionDepsArePickedUp]
2035+ ,testGroup "loading" [loadCradleOnlyonce]
2036+ ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]
2037+ ]
2038+
2039+loadCradleOnlyonce :: TestTree
2040+loadCradleOnlyonce = testGroup "load cradle only once"
2041+ [ testSession' "implicit" implicit
2042+ , testSession' "direct" direct
2043+ ]
2044+ where
2045+ direct dir = do
2046+ liftIO $ writeFileUTF8 (dir </> "hie.yaml")
2047+ "cradle: {direct: {arguments: []}}"
2048+ test dir
2049+ implicit dir = test dir
2050+ test _dir = do
2051+ doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"
2052+ msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2053+ liftIO $ length msgs @?= 1
2054+ changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]
2055+ msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2056+ liftIO $ length msgs @?= 0
2057+ _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"
2058+ msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2059+ liftIO $ length msgs @?= 0
2060+
2061+
2062+dependentFileTest :: TestTree
2063+dependentFileTest = testGroup "addDependentFile"
2064+ [testGroup "file-changed" [testSession' "test" test]
2065+ ]
2066+ where
2067+ test dir = do
2068+ -- If the file contains B then no type error
2069+ -- otherwise type error
2070+ liftIO $ writeFile (dir </> "dep-file.txt") "A"
2071+ let fooContent = T.unlines
2072+ [ "{-# LANGUAGE TemplateHaskell #-}"
2073+ , "module Foo where"
2074+ , "import Language.Haskell.TH.Syntax"
2075+ , "foo :: Int"
2076+ , "foo = 1 + $(do"
2077+ , " qAddDependentFile \"dep-file.txt\""
2078+ , " f <- qRunIO (readFile \"dep-file.txt\")"
2079+ , " if f == \"B\" then [| 1 |] else lift f)"
2080+ ]
2081+ let bazContent = T.unlines ["module Baz where", "import Foo"]
2082+ _ <-createDoc "Foo.hs" "haskell" fooContent
2083+ doc <- createDoc "Baz.hs" "haskell" bazContent
2084+ expectDiagnostics
2085+ [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]
2086+ -- Now modify the dependent file
2087+ liftIO $ writeFile (dir </> "dep-file.txt") "B"
2088+ let change = TextDocumentContentChangeEvent
2089+ { _range = Just (Range (Position 2 0) (Position 2 6))
2090+ , _rangeLength = Nothing
2091+ , _text = "f = ()"
2092+ }
2093+ -- Modifying Baz will now trigger Foo to be rebuilt as well
2094+ changeDoc doc [change]
2095+ expectDiagnostics [("Foo.hs", [])]
2096+
2097+
2098+cradleLoadedMessage :: Session FromServerMessage
2099+cradleLoadedMessage = satisfy $ \case
2100+ NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod
2101+ _ -> False
2102+
2103+cradleLoadedMethod :: T.Text
2104+cradleLoadedMethod = "ghcide/cradle/loaded"
2105+
2106+-- Stack sets this which trips up cabal in the multi-component tests.
2107+-- However, our plugin tests rely on those env vars so we unset it locally.
2108+withoutStackEnv :: IO a -> IO a
2109+withoutStackEnv s =
2110+ bracket
2111+ (mapM getEnv vars >>= \prevState -> mapM_ unsetEnv vars >> pure prevState)
2112+ (\prevState -> mapM_ (\(var, value) -> restore var value) (zip vars prevState))
2113+ (const s)
2114+ where vars =
2115+ [ "GHC_PACKAGE_PATH"
2116+ , "GHC_ENVIRONMENT"
2117+ , "HASKELL_DIST_DIR"
2118+ , "HASKELL_PACKAGE_SANDBOX"
2119+ , "HASKELL_PACKAGE_SANDBOXES"
2120+ ]
2121+ restore var Nothing = unsetEnv var
2122+ restore var (Just val) = setEnv var val True
2123+
2124+simpleMultiTest :: TestTree
2125+simpleMultiTest = testCase "simple-multi-test" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do
2126+ let aPath = dir </> "a/A.hs"
2127+ bPath = dir </> "b/B.hs"
2128+ aSource <- liftIO $ readFileUtf8 aPath
2129+ (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
2130+ expectNoMoreDiagnostics 0.5
2131+ bSource <- liftIO $ readFileUtf8 bPath
2132+ bdoc <- createDoc bPath "haskell" bSource
2133+ expectNoMoreDiagnostics 0.5
2134+ locs <- getDefinitions bdoc (Position 2 7)
2135+ let fooL = mkL adoc 2 0 2 3
2136+ checkDefs locs (pure [fooL])
2137+ expectNoMoreDiagnostics 0.5
2138+
2139+-- Like simpleMultiTest but open the files in the other order
2140+simpleMultiTest2 :: TestTree
2141+simpleMultiTest2 = testCase "simple-multi-test2" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do
2142+ let aPath = dir </> "a/A.hs"
2143+ bPath = dir </> "b/B.hs"
2144+ bSource <- liftIO $ readFileUtf8 bPath
2145+ bdoc <- createDoc bPath "haskell" bSource
2146+ expectNoMoreDiagnostics 5
2147+ aSource <- liftIO $ readFileUtf8 aPath
2148+ (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
2149+ -- Need to have some delay here or the test fails
2150+ expectNoMoreDiagnostics 5
2151+ locs <- getDefinitions bdoc (Position 2 7)
2152+ let fooL = mkL adoc 2 0 2 3
2153+ checkDefs locs (pure [fooL])
2154+ expectNoMoreDiagnostics 0.5
2155+
2156+sessionDepsArePickedUp :: TestTree
2157+sessionDepsArePickedUp = testSession'
2158+ "session-deps-are-picked-up"
2159+ $ \dir -> do
2160+ liftIO $
2161+ writeFileUTF8
2162+ (dir </> "hie.yaml")
2163+ "cradle: {direct: {arguments: []}}"
2164+ -- Open without OverloadedStrings and expect an error.
2165+ doc <- createDoc "Foo.hs" "haskell" fooContent
2166+ expectDiagnostics
2167+ [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
2168+ -- Update hie.yaml to enable OverloadedStrings.
2169+ liftIO $
2170+ writeFileUTF8
2171+ (dir </> "hie.yaml")
2172+ "cradle: {direct: {arguments: [-XOverloadedStrings]}}"
2173+ -- Send change event.
2174+ let change =
2175+ TextDocumentContentChangeEvent
2176+ { _range = Just (Range (Position 4 0) (Position 4 0)),
2177+ _rangeLength = Nothing,
2178+ _text = "\n"
2179+ }
2180+ changeDoc doc [change]
2181+ -- Now no errors.
2182+ expectDiagnostics [("Foo.hs", [])]
2183+ where
2184+ fooContent =
2185+ T.unlines
2186+ [ "module Foo where",
2187+ "import Data.Text",
2188+ "foo :: Text",
2189+ "foo = \"hello\""
2190+ ]
2191+
2192+
1549----------------------------------------------------------------------
2193----------------------------------------------------------------------
1550-- Utils
2194-- Utils
1551
2195
@@ -1553,6 +2197,12 @@ mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine st
1553testSession :: String -> Session () -> TestTree
2197testSession :: String -> Session () -> TestTree
1554testSession name = testCase name . run
2198testSession name = testCase name . run
1555
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+
1556testSessionWait :: String -> Session () -> TestTree
2206testSessionWait :: String -> Session () -> TestTree
1557testSessionWait name = testSession name .
2207testSessionWait name = testSession name .
1558 -- 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.
@@ -1563,24 +2213,53 @@ testSessionWait name = testSession name .
1563 -- 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.
1564 ( >> expectNoMoreDiagnostics 0.5)
2214 ( >> expectNoMoreDiagnostics 0.5)
1565
2215
1566−pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction
2216+pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction
1567−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 =
1568− [ action
2226+ [ action
1569− | CACodeAction action@CodeAction{ _title = actionTitle } <- actions
2227+ | CACodeAction action@CodeAction { _title = actionTitle } <- actions
1570− , title == actionTitle ]
2228+ , title == actionTitle
2229+ ]
1571
2230
1572mkRange :: Int -> Int -> Int -> Int -> Range
2231mkRange :: Int -> Int -> Int -> Int -> Range
1573mkRange a b c d = Range (Position a b) (Position c d)
2232mkRange a b c d = Range (Position a b) (Position c d)
1574
2233
1575run :: Session a -> IO a
2234run :: Session a -> IO a
1576−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
1577 ghcideExe <- locateGhcideExecutable
2255 ghcideExe <- locateGhcideExecutable
1578
2256
1579 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
2257 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56
1580 -- 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
1581 createDirectoryIfMissing True $ dir ++ "/Data"
2259 createDirectoryIfMissing True $ dir ++ "/Data"
1582
2260
2261+
1583− let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]
2262+ let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
1584 -- HIE calls getXgdDirectory which assumes that HOME is set.
2263 -- HIE calls getXgdDirectory which assumes that HOME is set.
1585 -- Only sets HOME if it wasn't already set.
2264 -- Only sets HOME if it wasn't already set.
1586 setEnv "HOME" "/homeless-shelter" False
2265 setEnv "HOME" "/homeless-shelter" False
@@ -1597,7 +2276,7 @@ run s = withTempDir $ \dir -> do
1597openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
2276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
1598openTestDataDoc path = do
2277openTestDataDoc path = do
1599 source <- liftIO $ readFileUtf8 $ "test/data" </> path
2278 source <- liftIO $ readFileUtf8 $ "test/data" </> path
1600− openDoc' path "haskell" source
2279+ createDoc path "haskell" source
1601
2280
1602findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
2281findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
1603findCodeActions doc range expectedTitles = do
2282findCodeActions doc range expectedTitles = do
@@ -1612,7 +2291,7 @@ findCodeActions doc range expectedTitles = do
1612 [ actionTitle
2291 [ actionTitle
1613 | CACodeAction CodeAction { _title = actionTitle } <- actions
2292 | CACodeAction CodeAction { _title = actionTitle } <- actions
1614 ]
2293 ]
1615− ++ "is not a superset of "
2294+ ++ " is not a superset of "
1616 ++ show expectedTitles
2295 ++ show expectedTitles
1617 liftIO $ case matches of
2296 liftIO $ case matches of
1618 Nothing -> assertFailure msg
2297 Nothing -> assertFailure msg
@@ -1625,13 +2304,193 @@ findCodeAction doc range t = head <$> findCodeActions doc range [t]
1625unitTests :: TestTree
2304unitTests :: TestTree
1626unitTests = do
2305unitTests = do
1627 testGroup "Unit"
2306 testGroup "Unit"
1628− [ testCase "empty file path" $
2307+ [ testCase "empty file path does NOT work with the empty String literal" $
1629− 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 ""
1630 ]
2318 ]
1631
2319
1632−-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events
2320+positionMappingTests :: TestTree
1633−openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
2321+positionMappingTests =
1634−openDoc' fp name contents = do
2322+ testGroup "position mapping"
1635− res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents
2323+ [ testGroup "toCurrent"
1636− 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)
1637− 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 '‘' = '\''