git.iko.soy/ghcide
on master help sign in
swap
5a754e149 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'))
.ghcideleted−25
@@ -1,25 +0,0 @@
1−:set -Wunused-binds -Wunused-imports -Worphans -Wunused-matches -Wincomplete-patterns
2−
3−:set -XBangPatterns
4−:set -XDeriveFunctor
5−:set -XDeriveGeneric
6−:set -XGeneralizedNewtypeDeriving
7−:set -XLambdaCase
8−:set -XNamedFieldPuns
9−:set -XOverloadedStrings
10−:set -XRecordWildCards
11−:set -XScopedTypeVariables
12−:set -XStandaloneDeriving
13−:set -XTupleSections
14−:set -XTypeApplications
15−:set -XViewPatterns
16−
17−:set -package=ghc
18−:set -ignore-package=ghc-lib-parser
19−:set -DGHC_STABLE
20−:set -Iinclude
21−:set -idist/build/autogen
22−:set -isrc
23−:set -iexe
24−
25−:load Main
.gitignore+3
@@ -5,3 +5,6 @@ cabal.project.local
5*~
5*~
6*.lock
6*.lock
7/.tasty-rerun-log
7/.tasty-rerun-log
8+.vscode
9+/.hlint-*
10+bench/example
.hlint.yaml+5−1
@@ -73,18 +73,22 @@
73 - {name: ViewPatterns, within: []}
73 - {name: ViewPatterns, within: []}
74
74
75 # Shady extensions
75 # Shady extensions
76− - {name: ImplicitParams, within: []}
77 - name: CPP
76 - name: CPP
78 within:
77 within:
78+ - Development.IDE.Compat
79 - Development.IDE.Core.FileStore
79 - Development.IDE.Core.FileStore
80 - Development.IDE.Core.Compile
80 - Development.IDE.Core.Compile
81+ - Development.IDE.Core.Rules
81 - Development.IDE.GHC.Compat
82 - Development.IDE.GHC.Compat
83+ - Development.IDE.GHC.Orphans
82 - Development.IDE.GHC.Util
84 - Development.IDE.GHC.Util
83 - Development.IDE.Import.FindImports
85 - Development.IDE.Import.FindImports
86+ - Development.IDE.LSP.Outline
84 - Development.IDE.Spans.Calculate
87 - Development.IDE.Spans.Calculate
85 - Development.IDE.Spans.Documentation
88 - Development.IDE.Spans.Documentation
86 - Development.IDE.Spans.Common
89 - Development.IDE.Spans.Common
87 - Development.IDE.Plugin.CodeAction
90 - Development.IDE.Plugin.CodeAction
91+ - Development.IDE.Plugin.Completions
88 - Development.IDE.Plugin.Completions.Logic
92 - Development.IDE.Plugin.Completions.Logic
89 - Main
93 - Main
90
94
CHANGELOG.md+20
@@ -1,5 +1,25 @@
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+
3### 0.1.0 (2020-02-04)
23### 0.1.0 (2020-02-04)
4
24
5* Code action for inserting new definitions (see #309).
25* Code action for inserting new definitions (see #309).
README.md+54−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,6 +283,20 @@ 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.,
@@ -276,8 +325,10 @@ Now opening a `.hs` file should work with `ghcide`.
276
325
277## History and relationship to other Haskell IDE's
326## History and relationship to other Haskell IDE's
278
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+
279The 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).
280
331
281−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.
282
333
283The 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+--------------------------------------------------------------------------------------------
exe/Arguments.hs+2
@@ -13,6 +13,7 @@ data Arguments = Arguments
13 ,argsVersion :: Bool
13 ,argsVersion :: Bool
14 ,argsShakeProfiling :: Maybe FilePath
14 ,argsShakeProfiling :: Maybe FilePath
15 ,argsTesting :: Bool
15 ,argsTesting :: Bool
16+ ,argsThreads :: Int
16 }
17 }
17
18
18getArguments :: IO Arguments
19getArguments :: IO Arguments
@@ -31,3 +32,4 @@ arguments = Arguments
31 <*> switch (long "version" <> help "Show ghcide and GHC versions")
32 <*> switch (long "version" <> help "Show ghcide and GHC versions")
32 <*> 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")
33 <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")
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+529−64
@@ -7,16 +7,26 @@
7
7
8module Main(main) where
8module Main(main) where
9
9
10+import Linker (initDynLinker)
11+import Data.IORef
12+import NameCache
13+import Packages
14+import Module
10import Arguments
15import Arguments
11−import Data.Maybe
16+import Control.Concurrent.Async
12−import Data.List.Extra
13−import System.FilePath
14import Control.Concurrent.Extra
17import Control.Concurrent.Extra
15import Control.Exception
18import Control.Exception
16import Control.Monad.Extra
19import Control.Monad.Extra
17import Control.Monad.IO.Class
20import Control.Monad.IO.Class
18import Data.Default
21import Data.Default
19−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
20import Development.IDE.Core.Debouncer
30import Development.IDE.Core.Debouncer
21import Development.IDE.Core.FileStore
31import Development.IDE.Core.FileStore
22import Development.IDE.Core.OfInterest
32import Development.IDE.Core.OfInterest
@@ -33,24 +43,39 @@ import Development.IDE.GHC.Util
33import Development.IDE.Plugin
43import Development.IDE.Plugin
34import Development.IDE.Plugin.Completions as Completions
44import Development.IDE.Plugin.Completions as Completions
35import Development.IDE.Plugin.CodeAction as CodeAction
45import Development.IDE.Plugin.CodeAction as CodeAction
36−import qualified Data.Text as T
46+import qualified Language.Haskell.LSP.Core as LSP
37−import qualified Data.Text.IO as T
38import Language.Haskell.LSP.Messages
47import Language.Haskell.LSP.Messages
39−import Language.Haskell.LSP.Types (LspId(IdInt))
48+import Language.Haskell.LSP.Types
40−import Data.Version
49+import Data.Aeson (ToJSON(toJSON))
41import Development.IDE.LSP.LanguageServer
50import Development.IDE.LSP.LanguageServer
42import qualified System.Directory.Extra as IO
51import qualified System.Directory.Extra as IO
43import System.Environment
52import System.Environment
44import System.IO
53import System.IO
45import 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)
46import Paths_ghcide
59import Paths_ghcide
47import Development.GitRev
60import Development.GitRev
48−import Development.Shake (Action, Rules, action)
61+import Development.Shake (Action, action)
49import qualified Data.HashSet as HashSet
62import qualified Data.HashSet as HashSet
63+import qualified Data.HashMap.Strict as HM
50import qualified Data.Map.Strict as Map
64import qualified Data.Map.Strict as Map
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)
71+import GHC hiding (def)
72+import GHC.Check ( VersionCheck(..), makeGhcVersionChecker )
73+import Data.Either.Extra
74+
51−import HIE.Bios
75+import HIE.Bios.Cradle
52−import Rules
76+import HIE.Bios.Types
77+
53−import RuleTypes
78+import Utils
54
79
55ghcideVersion :: IO String
80ghcideVersion :: IO String
56ghcideVersion = do
81ghcideVersion = do
@@ -80,25 +105,30 @@ main = do
80 whenJust argsCwd IO.setCurrentDirectory
105 whenJust argsCwd IO.setCurrentDirectory
81
106
82 dir <- IO.getCurrentDirectory
107 dir <- IO.getCurrentDirectory
108+ command <- makeLspCommandId "typesignature.add"
83
109
84 let plugins = Completions.plugin <> CodeAction.plugin
110 let plugins = Completions.plugin <> CodeAction.plugin
85 onInitialConfiguration = const $ Right ()
111 onInitialConfiguration = const $ Right ()
86 onConfigurationChange = const $ Right ()
112 onConfigurationChange = const $ Right ()
113+ options = def { LSP.executeCommandCommands = Just [command]
114+ , LSP.completionTriggerCharacters = Just "."
115+ }
87
116
88 if argLSP then do
117 if argLSP then do
89 t <- offsetTime
118 t <- offsetTime
90 hPutStrLn stderr "Starting LSP server..."
119 hPutStrLn stderr "Starting LSP server..."
91 hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
120 hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
92− runLanguageServer def (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do
121+ runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do
93 t <- t
122 t <- t
94 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
123 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
95− let options = (defaultIdeOptions $ loadSession dir)
124+ let options = (defaultIdeOptions $ loadSessionShake dir)
96 { optReportProgress = clientSupportsProgress caps
125 { optReportProgress = clientSupportsProgress caps
97 , optShakeProfiling = argsShakeProfiling
126 , optShakeProfiling = argsShakeProfiling
98 , optTesting = argsTesting
127 , optTesting = argsTesting
128+ , optThreads = argsThreads
99 }
129 }
100 debouncer <- newAsyncDebouncer
130 debouncer <- newAsyncDebouncer
101− initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick)
131+ initialise caps (mainRule >> pluginRules plugins >> action kick)
102 getLspId event (logger minBound) debouncer options vfs
132 getLspId event (logger minBound) debouncer options vfs
103 else do
133 else do
104 -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
134 -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
@@ -108,55 +138,32 @@ main = do
108 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
138 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
109 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
139 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
110
140
111− putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir
141+ putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir
112 files <- expandFiles (argFiles ++ ["." | null argFiles])
142 files <- expandFiles (argFiles ++ ["." | null argFiles])
113 -- LSP works with absolute file paths, so try and behave similarly
143 -- LSP works with absolute file paths, so try and behave similarly
114 files <- nubOrd <$> mapM IO.canonicalizePath files
144 files <- nubOrd <$> mapM IO.canonicalizePath files
115 putStrLn $ "Found " ++ show (length files) ++ " files"
145 putStrLn $ "Found " ++ show (length files) ++ " files"
116
146
117− 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"
118 cradles <- mapM findCradle files
148 cradles <- mapM findCradle files
119 let ucradles = nubOrd cradles
149 let ucradles = nubOrd cradles
120 let n = length ucradles
150 let n = length ucradles
121 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
151 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
122− sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do
123− let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x
124− putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg
125− cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x
126− when (isNothing x) $ print cradle
127− putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"
128− opts <- getComponentOptions cradle
129− createSession opts
130−
131− putStrLn "\nStep 5/6: Initializing the IDE"
152+ putStrLn "\nStep 3/4: Initializing the IDE"
132 vfs <- makeVFSHandle
153 vfs <- makeVFSHandle
133− let cradlesToSessions = Map.fromList $ zip ucradles sessions
154+ debouncer <- newAsyncDebouncer
134− let filesToCradles = Map.fromList $ zip files cradles
135− let grab file = fromMaybe (head sessions) $ do
136− cradle <- Map.lookup file filesToCradles
137− Map.lookup cradle cradlesToSessions
138−
139− let options =
140− (defaultIdeOptions $ return $ return . grab)
141− { optShakeProfiling = argsShakeProfiling }
142− ide <- initialise def (cradleRules >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs
155+ ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs
143−
156+
144− putStrLn "\nStep 6/6: Type checking the files"
157+ putStrLn "\nStep 4/4: Type checking the files"
145− setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath files
158+ setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
146− results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files
159+ results <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath' files)
147 let (worked, failed) = partition fst $ zip (map isJust results) files
160 let (worked, failed) = partition fst $ zip (map isJust results) files
148 when (failed /= []) $
161 when (failed /= []) $
149 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
162 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
150
163
151 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"
152 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
165 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
153−
166+ return ()
154− unless (null failed) exitFailure
155−
156−cradleRules :: Rules ()
157−cradleRules = do
158− loadGhcSession
159− cradleToSession
160
167
161expandFiles :: [FilePath] -> IO [FilePath]
168expandFiles :: [FilePath] -> IO [FilePath]
162expandFiles = concatMapM $ \x -> do
169expandFiles = concatMapM $ \x -> do
@@ -179,27 +186,409 @@ kick = do
179-- | Print an LSP event.
186-- | Print an LSP event.
180showEvent :: Lock -> FromServerMessage -> IO ()
187showEvent :: Lock -> FromServerMessage -> IO ()
181showEvent _ (EventFileDiagnostics _ []) = return ()
188showEvent _ (EventFileDiagnostics _ []) = return ()
182−showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =
189+showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =
183 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
190 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags
184showEvent lock e = withLock lock $ print e
191showEvent lock e = withLock lock $ print e
185
192
193+
194+-- | Run the specific cradle on a specific FilePath via hie-bios.
195+cradleToSessionOpts :: Cradle a -> FilePath -> IO (Either [CradleError] ComponentOptions)
196+cradleToSessionOpts cradle file = do
197+ let showLine s = putStrLn ("> " ++ s)
198+ cradleRes <- runCradle (cradleOptsProg cradle) showLine file
199+ case cradleRes of
200+ CradleSuccess r -> pure (Right r)
201+ CradleFail err -> return (Left [err])
202+ -- For the None cradle perhaps we still want to report an Info
203+ -- message about the fact that the file is being ignored.
204+ CradleNone -> return (Left [])
205+
206+emptyHscEnv :: IO HscEnv
207+emptyHscEnv = do
208+ libdir <- getLibdir
209+ env <- runGhc (Just libdir) getSession
210+ initDynLinker 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+
186−loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)
230+loadSessionShake :: FilePath -> Action (FilePath -> Action (IdeResult HscEnvEq))
187−loadSession dir = liftIO $ do
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
188− cradleLoc <- memoIO $ \v -> do
248+ cradleLoc <- memoIO $ \v -> do
189− res <- findCradle v
249+ res <- findCradle v
190− -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
250+ -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
191− -- try and normalise that
251+ -- try and normalise that
192− -- e.g. see https://github.com/digital-asset/ghcide/issues/126
252+ -- e.g. see https://github.com/digital-asset/ghcide/issues/126
193− res' <- traverse IO.makeAbsolute res
253+ res' <- traverse IO.makeAbsolute res
194− return $ normalise <$> res'
254+ return $ normalise <$> res'
195− let session :: Maybe FilePath -> Action HscEnvEq
255+
196− session file = do
256+ -- Create a new HscEnv from a hieYaml root and a set of options
197− -- In the absence of a cradle file, just pass the directory from where to calculate an implicit cradle
257+ -- If the hieYaml file already has an HscEnv, the new component is
198− let cradle = toNormalizedFilePath $ fromMaybe dir file
258+ -- combined with the components in the old HscEnv into a new HscEnv
199− use_ LoadCradle cradle
259+ -- which contains the union.
260+ let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions)
261+ -> IO (HscEnv, ComponentInfo, [ComponentInfo])
262+ packageSetup (hieYaml, cfp, opts) = do
263+ -- Parse DynFlags for the newly discovered component
264+ hscEnv <- emptyHscEnv
265+ (df, targets) <- evalGhcEnv hscEnv $
266+ setOptions opts (hsc_dflags hscEnv)
267+ dep_info <- getDependencyInfo (componentDependencies opts ++ maybeToList hieYaml)
268+ -- Now lookup to see whether we are combining with an existing HscEnv
269+ -- or making a new one. The lookup returns the HscEnv and a list of
270+ -- information about other components loaded into the HscEnv
271+ -- (unitId, DynFlag, Targets)
272+ modifyVar hscEnvs $ \m -> do
273+ -- Just deps if there's already an HscEnv
274+ -- Nothing is it's the first time we are making an HscEnv
275+ let oldDeps = Map.lookup hieYaml m
276+ let -- Add the raw information about this component to the list
277+ -- We will modify the unitId and DynFlags used for
278+ -- compilation but these are the true source of
279+ -- information.
280+ new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info
281+ : maybe [] snd oldDeps
282+ -- Get all the unit-ids for things in this component
283+ inplace = map rawComponentUnitId new_deps
284+
285+ new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do
286+ -- Remove all inplace dependencies from package flags for
287+ -- components in this HscEnv
288+ let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags
289+ let prefix = show rawComponentUnitId
290+ -- See Note [Avoiding bad interface files]
291+ processed_df <- setCacheDir logger prefix (sort $ map show uids) opts df2
292+ -- The final component information, mostly the same but the DynFlags don't
293+ -- contain any packages which are also loaded
294+ -- into the same component.
295+ pure $ ComponentInfo rawComponentUnitId
296+ processed_df
297+ uids
298+ rawComponentTargets
299+ rawComponentFP
300+ rawComponentCOptions
301+ rawComponentDependencyInfo
302+ -- Make a new HscEnv, we have to recompile everything from
303+ -- scratch again (for now)
304+ -- It's important to keep the same NameCache though for reasons
305+ -- that I do not fully understand
306+ logInfo logger (T.pack ("Making new HscEnv" ++ show inplace))
307+ hscEnv <- case oldDeps of
308+ Nothing -> emptyHscEnv
309+ Just (old_hsc, _) -> setNameCache (hsc_NC old_hsc) <$> emptyHscEnv
310+ newHscEnv <-
311+ -- Add the options for the current component to the HscEnv
312+ evalGhcEnv hscEnv $ do
313+ _ <- setSessionDynFlags df
314+ getSession
315+ -- Modify the map so the hieYaml now maps to the newly created
316+ -- HscEnv
317+ -- Returns
318+ -- . the new HscEnv so it can be used to modify the
319+ -- FilePath -> HscEnv map (fileToFlags)
320+ -- . The information for the new component which caused this cache miss
321+ -- . The modified information (without -inplace flags) for
322+ -- existing packages
323+ pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps'))
324+
325+ let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> IO (IdeResult HscEnvEq)
326+ session (hieYaml, cfp, opts) = do
327+ (hscEnv, new, old_deps) <- packageSetup (hieYaml, cfp, opts)
328+ -- Make a map from unit-id to DynFlags, this is used when trying to
329+ -- resolve imports. (especially PackageImports)
330+ let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps)
331+
332+ -- For each component, now make a new HscEnvEq which contains the
333+ -- HscEnv for the hie.yaml file but the DynFlags for that component
334+
335+ -- New HscEnv for the component in question, returns the new HscEnvEq and
336+ -- a mapping from FilePath to the newly created HscEnvEq.
337+ let new_cache = newComponentCache logger hscEnv uids
338+ (cs, res) <- new_cache new
339+ -- Modified cache targets for everything else in the hie.yaml file
340+ -- which now uses the same EPS and so on
341+ cached_targets <- concatMapM (fmap fst . new_cache) old_deps
342+ modifyVar_ fileToFlags $ \var -> do
343+ pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var
344+
345+ return (fst res)
346+
347+ let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq)
348+ consultCradle hieYaml cfp = do
349+ when optTesting $ eventer $ notifyCradleLoaded cfp
350+ logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp)
351+ cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml
352+ eopts <- cradleToSessionOpts cradle cfp
353+ logDebug logger $ T.pack ("Session loading result: " <> show eopts)
354+ case eopts of
355+ -- The cradle gave us some options so get to work turning them
356+ -- into and HscEnv.
357+ Right opts -> do
358+ session (hieYaml, toNormalizedFilePath' cfp, opts)
359+ -- Failure case, either a cradle error or the none cradle
360+ Left err -> do
361+ dep_info <- getDependencyInfo (maybeToList hieYaml)
362+ let ncfp = toNormalizedFilePath' cfp
363+ let res = (map (renderCradleError ncfp) err, Nothing)
364+ modifyVar_ fileToFlags $ \var -> do
365+ pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var
366+ return res
367+
368+ -- This caches the mapping from hie.yaml + Mod.hs -> [String]
369+ let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq)
370+ sessionOpts (hieYaml, file) = do
371+ v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags
372+ cfp <- canonicalizePath file
373+ case HM.lookup (toNormalizedFilePath' cfp) v of
374+ Just (opts, old_di) -> do
375+ deps_ok <- checkDependencyInfo old_di
376+ if not deps_ok
377+ then do
378+ -- If the dependencies are out of date then clear both caches and start
379+ -- again.
380+ modifyVar_ fileToFlags (const (return Map.empty))
381+ -- Keep the same name cache
382+ modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml )
383+ consultCradle hieYaml cfp
384+ else return opts
385+ Nothing -> consultCradle hieYaml cfp
386+
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)
200− return $ \file -> session =<< liftIO (cradleLoc 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)
201
403
202
404
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+
203-- | Memoize an IO function, with the characteristics:
592-- | Memoize an IO function, with the characteristics:
204--
593--
205-- * 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.
@@ -216,3 +605,79 @@ memoIO op = do
216 res <- onceFork $ op k
605 res <- onceFork $ op k
217 return (Map.insert k res mp, res)
606 return (Map.insert k res mp, res)
218 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/RuleTypes.hsdeleted−33
@@ -1,33 +0,0 @@
1−{-# LANGUAGE TypeFamilies #-}
2−module RuleTypes (GetHscEnv(..), LoadCradle(..)) where
3−
4−import Control.DeepSeq
5−import Data.Binary
6−import Data.Hashable (Hashable)
7−import Development.Shake
8−import Development.IDE.GHC.Util
9−import Data.Typeable (Typeable)
10−import GHC.Generics (Generic)
11−
12−-- Rule type for caching GHC sessions.
13−type instance RuleResult GetHscEnv = HscEnvEq
14−
15−data GetHscEnv = GetHscEnv
16− { hscenvOptions :: [String] -- componentOptions from hie-bios
17− , hscenvDependencies :: [FilePath] -- componentDependencies from hie-bios
18− }
19− deriving (Eq, Show, Typeable, Generic)
20−
21−instance Hashable GetHscEnv
22−instance NFData GetHscEnv
23−instance Binary GetHscEnv
24−
25−-- Rule type for caching cradle loading
26−type instance RuleResult LoadCradle = HscEnvEq
27−
28−data LoadCradle = LoadCradle
29− deriving (Eq, Show, Typeable, Generic)
30−
31−instance Hashable LoadCradle
32−instance NFData LoadCradle
33−instance Binary LoadCradle
exe/Rules.hsdeleted−161
@@ -1,161 +0,0 @@
1−module Rules
2− ( loadGhcSession
3− , cradleToSession
4− , cradleLoadedMethod
5− , createSession
6− , getComponentOptions
7− )
8−where
9−
10−import Control.Exception
11−import Control.Monad (filterM, when)
12−import qualified Crypto.Hash.SHA1 as H
13−import Data.ByteString.Base16 (encode)
14−import qualified Data.ByteString.Char8 as B
15−import Data.Functor ((<&>))
16−import Data.Maybe (fromMaybe)
17−import Data.Text (pack, Text)
18−import Development.IDE.Core.Rules (defineNoFile)
19−import Development.IDE.Core.Service (getIdeOptions)
20−import Development.IDE.Core.Shake (actionLogger, sendEvent, define, useNoFile_)
21−import Development.IDE.GHC.Util
22−import Development.IDE.Types.Location (fromNormalizedFilePath)
23−import Development.IDE.Types.Options (IdeOptions(IdeOptions, optTesting))
24−import Development.Shake
25−import DynFlags (gopt_set, gopt_unset,
26− updOptLevel)
27−import GHC
28−import qualified GHC.Paths
29−import HIE.Bios
30−import HIE.Bios.Cradle
31−import HIE.Bios.Environment (addCmdOpts)
32−import HIE.Bios.Types
33−import Linker (initDynLinker)
34−import RuleTypes
35−import qualified System.Directory.Extra as IO
36−import System.Environment (lookupEnv)
37−import System.FilePath.Posix (addTrailingPathSeparator,
38− (</>))
39−import Language.Haskell.LSP.Messages as LSP
40−import Language.Haskell.LSP.Types as LSP
41−import Data.Aeson (ToJSON(toJSON))
42−import Development.IDE.Types.Logger (logDebug)
43−
44−-- Prefix for the cache path
45−cacheDir :: String
46−cacheDir = "ghcide"
47−
48−notifyCradleLoaded :: FilePath -> LSP.FromServerMessage
49−notifyCradleLoaded fp =
50− LSP.NotCustomServer $
51− LSP.NotificationMessage "2.0" (LSP.CustomServerMethod cradleLoadedMethod) $
52− toJSON fp
53−
54−loadGhcSession :: Rules ()
55−loadGhcSession =
56− -- This rule is for caching the GHC session. E.g., even when the cabal file
57− -- changed, if the resulting flags did not change, we would continue to use
58− -- the existing session.
59− defineNoFile $ \(GetHscEnv opts deps) ->
60− liftIO $ createSession $ ComponentOptions opts deps
61−
62−cradleToSession :: Rules ()
63−cradleToSession = define $ \LoadCradle nfp -> do
64−
65− let f = fromNormalizedFilePath nfp
66−
67− IdeOptions{optTesting} <- getIdeOptions
68−
69− logger <- actionLogger
70− liftIO $ logDebug logger $ "Running cradle " <> pack (fromNormalizedFilePath nfp)
71−
72− -- If the path points to a directory, load the implicit cradle
73− mbYaml <- doesDirectoryExist f <&> \isDir -> if isDir then Nothing else Just f
74− cradle <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator f) loadCradle mbYaml
75−
76− when optTesting $
77− sendEvent $ notifyCradleLoaded f
78−
79− -- Avoid interrupting `getComponentOptions` since it calls external processes
80− cmpOpts <- liftIO $ mask $ \_ -> getComponentOptions cradle
81− let opts = componentOptions cmpOpts
82− deps = componentDependencies cmpOpts
83− deps' = case mbYaml of
84− -- For direct cradles, the hie.yaml file itself must be watched.
85− Just yaml | isDirectCradle cradle -> yaml : deps
86− _ -> deps
87− existingDeps <- filterM doesFileExist deps'
88− need existingDeps
89− ([],) . pure <$> useNoFile_ (GetHscEnv opts deps)
90−
91−cradleLoadedMethod :: Text
92−cradleLoadedMethod = "ghcide/cradle/loaded"
93−
94−getComponentOptions :: Cradle a -> IO ComponentOptions
95−getComponentOptions cradle = do
96− let showLine s = putStrLn ("> " ++ s)
97− -- WARNING 'runCradle is very expensive and must be called as few times as possible
98− cradleRes <- runCradle (cradleOptsProg cradle) showLine ""
99− case cradleRes of
100− CradleSuccess r -> pure r
101− CradleFail err -> throwIO err
102− -- TODO Rather than failing here, we should ignore any files that use this cradle.
103− -- That will require some more changes.
104− CradleNone -> fail "'none' cradle is not yet supported"
105−
106−createSession :: ComponentOptions -> IO HscEnvEq
107−createSession (ComponentOptions theOpts _) = do
108− libdir <- getLibdir
109−
110− cacheDir <- getCacheDir theOpts
111−
112− env <- runGhc (Just libdir) $ do
113− dflags <- getSessionDynFlags
114− (dflags', _targets) <- addCmdOpts theOpts dflags
115− _ <- setSessionDynFlags $
116− -- disabled, generated directly by ghcide instead
117− flip gopt_unset Opt_WriteInterface $
118− -- disabled, generated directly by ghcide instead
119− -- also, it can confuse the interface stale check
120− dontWriteHieFiles $
121− setHiDir cacheDir $
122− setDefaultHieDir cacheDir $
123− setIgnoreInterfacePragmas $
124− setLinkerOptions $
125− disableOptimisation dflags'
126− getSession
127− initDynLinker env
128− newHscEnvEq env
129−
130−-- Set the GHC libdir to the nix libdir if it's present.
131−getLibdir :: IO FilePath
132−getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"
133−
134−-- we don't want to generate object code so we compile to bytecode
135−-- (HscInterpreted) which implies LinkInMemory
136−-- HscInterpreted
137−setLinkerOptions :: DynFlags -> DynFlags
138−setLinkerOptions df = df {
139− ghcLink = LinkInMemory
140− , hscTarget = HscNothing
141− , ghcMode = CompManager
142− }
143−
144−setIgnoreInterfacePragmas :: DynFlags -> DynFlags
145−setIgnoreInterfacePragmas df =
146− gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges
147−
148−disableOptimisation :: DynFlags -> DynFlags
149−disableOptimisation df = updOptLevel 0 df
150−
151−setHiDir :: FilePath -> DynFlags -> DynFlags
152−setHiDir f d =
153− -- override user settings to avoid conflicts leading to recompilation
154− d { hiDir = Just f}
155−
156−getCacheDir :: [String] -> IO FilePath
157−getCacheDir opts = IO.getXdgDirectory IO.XdgCache (cacheDir </> opts_hash)
158− where
159− -- Create a unique folder per set of different GHC options, assuming that each different set of
160− -- GHC options will create incompatible interface files.
161− opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts)
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"
ghcide.cabal+76−12
@@ -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.1.0
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,
@@ -43,8 +50,8 @@ library
43 filepath,
50 filepath,
44 haddock-library >= 1.8,
51 haddock-library >= 1.8,
45 hashable,
52 hashable,
46− haskell-lsp-types == 0.20.*,
53+ haskell-lsp-types == 0.22.*,
47− haskell-lsp == 0.20.*,
54+ haskell-lsp == 0.22.*,
48 mtl,
55 mtl,
49 network-uri,
56 network-uri,
50 prettyprinter-ansi-terminal,
57 prettyprinter-ansi-terminal,
@@ -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,6 +109,7 @@ library
99 include-dirs:
109 include-dirs:
100 include
110 include
101 exposed-modules:
111 exposed-modules:
112+ Development.IDE.Compat
102 Development.IDE.Core.Debouncer
113 Development.IDE.Core.Debouncer
103 Development.IDE.Core.FileStore
114 Development.IDE.Core.FileStore
104 Development.IDE.Core.IdeConfiguration
115 Development.IDE.Core.IdeConfiguration
@@ -111,7 +122,9 @@ library
111 Development.IDE.GHC.Error
122 Development.IDE.GHC.Error
112 Development.IDE.GHC.Util
123 Development.IDE.GHC.Util
113 Development.IDE.Import.DependencyInformation
124 Development.IDE.Import.DependencyInformation
125+ Development.IDE.LSP.HoverDefinition
114 Development.IDE.LSP.LanguageServer
126 Development.IDE.LSP.LanguageServer
127+ Development.IDE.LSP.Outline
115 Development.IDE.LSP.Protocol
128 Development.IDE.LSP.Protocol
116 Development.IDE.LSP.Server
129 Development.IDE.LSP.Server
117 Development.IDE.Spans.Common
130 Development.IDE.Spans.Common
@@ -130,10 +143,9 @@ library
130 Development.IDE.GHC.CPP
143 Development.IDE.GHC.CPP
131 Development.IDE.GHC.Orphans
144 Development.IDE.GHC.Orphans
132 Development.IDE.GHC.Warnings
145 Development.IDE.GHC.Warnings
146+ Development.IDE.GHC.WithDynFlags
133 Development.IDE.Import.FindImports
147 Development.IDE.Import.FindImports
134− Development.IDE.LSP.HoverDefinition
135 Development.IDE.LSP.Notifications
148 Development.IDE.LSP.Notifications
136− Development.IDE.LSP.Outline
137 Development.IDE.Spans.AtPoint
149 Development.IDE.Spans.AtPoint
138 Development.IDE.Spans.Calculate
150 Development.IDE.Spans.Calculate
139 Development.IDE.Spans.Documentation
151 Development.IDE.Spans.Documentation
@@ -143,6 +155,14 @@ library
143 Development.IDE.Plugin.CodeAction.RuleTypes
155 Development.IDE.Plugin.CodeAction.RuleTypes
144 Development.IDE.Plugin.Completions.Logic
156 Development.IDE.Plugin.Completions.Logic
145 Development.IDE.Plugin.Completions.Types
157 Development.IDE.Plugin.Completions.Types
158+ if (impl(ghc > 8.7) && impl(ghc < 8.10)) || flag(ghc-lib)
159+ hs-source-dirs: src-ghc88
160+ other-modules:
161+ Development.IDE.GHC.HieAst
162+ if (impl(ghc > 8.9))
163+ hs-source-dirs: src-ghc810
164+ other-modules:
165+ Development.IDE.GHC.HieAst
146 ghc-options: -Wall -Wno-name-shadowing
166 ghc-options: -Wall -Wno-name-shadowing
147
167
148executable ghcide-test-preprocessor
168executable ghcide-test-preprocessor
@@ -170,6 +190,8 @@ executable ghcide
170 "-with-rtsopts=-I0 -qg -A128M"
190 "-with-rtsopts=-I0 -qg -A128M"
171 main-is: Main.hs
191 main-is: Main.hs
172 build-depends:
192 build-depends:
193+ time,
194+ async,
173 hslogger,
195 hslogger,
174 aeson,
196 aeson,
175 base == 4.*,
197 base == 4.*,
@@ -183,23 +205,23 @@ executable ghcide
183 directory,
205 directory,
184 extra,
206 extra,
185 filepath,
207 filepath,
208+ ghc-check >= 0.3.0.1 && < 0.4,
186 ghc-paths,
209 ghc-paths,
187 ghc,
210 ghc,
188 gitrev,
211 gitrev,
189 hashable,
212 hashable,
190 haskell-lsp,
213 haskell-lsp,
191 haskell-lsp-types,
214 haskell-lsp-types,
192− hie-bios >= 0.4.0 && < 0.5,
215+ hie-bios >= 0.5.0 && < 0.6,
193 ghcide,
216 ghcide,
194 optparse-applicative,
217 optparse-applicative,
195 shake,
218 shake,
196 text,
219 text,
197 unordered-containers
220 unordered-containers
198 other-modules:
221 other-modules:
222+ Utils
199 Arguments
223 Arguments
200 Paths_ghcide
224 Paths_ghcide
201− Rules
202− RuleTypes
203
225
204 default-extensions:
226 default-extensions:
205 BangPatterns
227 BangPatterns
@@ -245,12 +267,14 @@ test-suite ghcide-tests
245 haddock-library,
267 haddock-library,
246 haskell-lsp,
268 haskell-lsp,
247 haskell-lsp-types,
269 haskell-lsp-types,
270+ network-uri,
248 lens,
271 lens,
249− lsp-test >= 0.8,
272+ lsp-test >= 0.11.0.1 && < 0.12,
250 parser-combinators,
273 parser-combinators,
251 QuickCheck,
274 QuickCheck,
252 quickcheck-instances,
275 quickcheck-instances,
253 rope-utf16-splay,
276 rope-utf16-splay,
277+ shake,
254 tasty,
278 tasty,
255 tasty-expected-failure,
279 tasty-expected-failure,
256 tasty-hunit,
280 tasty-hunit,
@@ -278,3 +302,43 @@ test-suite ghcide-tests
278 TupleSections
302 TupleSections
279 TypeApplications
303 TypeApplications
280 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+260−78
@@ -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,7 +17,13 @@ module Development.IDE.Core.Compile
16 , addRelativeImport
17 , addRelativeImport
17 , mkTcModuleResult
18 , mkTcModuleResult
18 , generateByteCode
19 , generateByteCode
20+ , generateAndWriteHieFile
21+ , generateAndWriteHiFile
22+ , getModSummaryFromImports
19 , loadHieFile
23 , loadHieFile
24+ , loadInterface
25+ , loadDepModule
26+ , loadModuleHome
20 ) where
27 ) where
21
28
22import Development.IDE.Core.RuleTypes
29import Development.IDE.Core.RuleTypes
@@ -30,6 +37,7 @@ import Development.IDE.GHC.Util
30import qualified GHC.LanguageExtensions.Type as GHC
37import qualified GHC.LanguageExtensions.Type as GHC
31import Development.IDE.Types.Options
38import Development.IDE.Types.Options
32import Development.IDE.Types.Location
39import Development.IDE.Types.Location
40+import Outputable
33
41
34#if MIN_GHC_API_VERSION(8,6,0)
42#if MIN_GHC_API_VERSION(8,6,0)
35import DynamicLoading (initializePlugins)
43import DynamicLoading (initializePlugins)
@@ -45,42 +53,52 @@ import ErrUtils
45
53
46import Finder
54import Finder
47import qualified Development.IDE.GHC.Compat as GHC
55import qualified Development.IDE.GHC.Compat as GHC
56+import qualified Development.IDE.GHC.Compat as Compat
48import GhcMonad
57import GhcMonad
49import GhcPlugins as GHC hiding (fst3, (<>))
58import GhcPlugins as GHC hiding (fst3, (<>))
50import qualified HeaderInfo as Hdr
59import qualified HeaderInfo as Hdr
51import HscMain (hscInteractive, hscSimplify)
60import HscMain (hscInteractive, hscSimplify)
61+import LoadIface (readIface)
62+import qualified Maybes
52import MkIface
63import MkIface
53import NameCache
64import NameCache
54import StringBuffer as SB
65import StringBuffer as SB
55−import TcRnMonad (tcg_th_coreplugins)
66+import TcRnMonad (initIfaceLoad, tcg_th_coreplugins)
67+import TcIface (typecheckIface)
56import TidyPgm
68import TidyPgm
57
69
70+import Control.Exception.Safe
58import Control.Monad.Extra
71import Control.Monad.Extra
59import Control.Monad.Except
72import Control.Monad.Except
60import Control.Monad.Trans.Except
73import Control.Monad.Trans.Except
61−import Data.Function
74+import Data.Bifunctor (first, second)
62−import Data.Ord
63import qualified Data.Text as T
75import qualified Data.Text as T
64import Data.IORef
76import Data.IORef
65import Data.List.Extra
77import Data.List.Extra
66import Data.Maybe
78import Data.Maybe
67−import Data.Tuple.Extra
68import qualified Data.Map.Strict as Map
79import qualified Data.Map.Strict as Map
69import 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)
70
87
71
88
72-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
89-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
73parseModule
90parseModule
74 :: IdeOptions
91 :: IdeOptions
75 -> HscEnv
92 -> HscEnv
93+ -> [PackageName]
76 -> FilePath
94 -> FilePath
77 -> Maybe SB.StringBuffer
95 -> Maybe SB.StringBuffer
78 -> IO (IdeResult (StringBuffer, ParsedModule))
96 -> IO (IdeResult (StringBuffer, ParsedModule))
79−parseModule IdeOptions{..} env filename mbContents =
97+parseModule IdeOptions{..} env comp_pkgs filename mbContents =
80 fmap (either (, Nothing) id) $
98 fmap (either (, Nothing) id) $
81− runGhcEnv env $ runExceptT $ do
99+ evalGhcEnv env $ runExceptT $ do
82 (contents, dflags) <- preprocessor filename mbContents
100 (contents, dflags) <- preprocessor filename mbContents
83− (diag, modu) <- parseFileContents optPreprocessor dflags filename contents
101+ (diag, modu) <- parseFileContents optPreprocessor dflags comp_pkgs filename contents
84 return (diag, Just (contents, modu))
102 return (diag, Just (contents, modu))
85
103
86
104
@@ -92,34 +110,39 @@ computePackageDeps
92computePackageDeps env pkg = do
110computePackageDeps env pkg = do
93 let dflags = hsc_dflags env
111 let dflags = hsc_dflags env
94 case lookupInstalledPackage dflags pkg of
112 case lookupInstalledPackage dflags pkg of
95− Nothing -> return $ Left [ideErrorText (toNormalizedFilePath noFilePath) $
113+ Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $
96 T.pack $ "unknown package: " ++ show pkg]
114 T.pack $ "unknown package: " ++ show pkg]
97 Just pkgInfo -> return $ Right $ depends pkgInfo
115 Just pkgInfo -> return $ Right $ depends pkgInfo
98
116
99−
100−-- | Typecheck a single module using the supplied dependencies and packages.
101−typecheckModule
102− :: IdeDefer
117+typecheckModule :: IdeDefer
103− -> HscEnv
118+ -> HscEnv
104− -> [TcModuleResult]
119+ -> [(ModSummary, (ModIface, Maybe Linkable))]
105− -> ParsedModule
120+ -> ParsedModule
106− -> IO (IdeResult TcModuleResult)
121+ -> IO (IdeResult (HscEnv, TcModuleResult))
107−typecheckModule (IdeDefer defer) packageState deps pm =
122+typecheckModule (IdeDefer defer) hsc depsIn pm = do
108− let demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
109− in
110− fmap (either (, Nothing) (second Just)) $
123+ fmap (either (, Nothing) (second Just . sequence) . sequence) $
111− runGhcEnv packageState $
124+ runGhcEnv hsc $
112− catchSrcErrors "typecheck" $ do
125+ catchSrcErrors "typecheck" $ do
113− 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+
114− let modSummary = pm_mod_summary pm
133+ let modSummary = pm_mod_summary pm
115− dflags = ms_hspp_opts modSummary
134+ dflags = ms_hspp_opts modSummary
135+
136+ mapM_ (uncurry loadDepModule . snd) deps
116− modSummary' <- initPlugins modSummary
137+ modSummary' <- initPlugins modSummary
117− (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
138+ (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
118− GHC.typecheckModule $ enableTopLevelWarnings
139+ GHC.typecheckModule $ enableTopLevelWarnings
119− $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
140+ $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
120− tcm2 <- mkTcModuleResult tcm
141+ tcm2 <- mkTcModuleResult tcm
121− let errorPipeline = unDefer . hideDiag dflags
142+ let errorPipeline = unDefer . hideDiag dflags
122− return (map errorPipeline warnings, tcm2)
143+ return (map errorPipeline warnings, tcm2)
144+ where
145+ demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
123
146
124initPlugins :: GhcMonad m => ModSummary -> m ModSummary
147initPlugins :: GhcMonad m => ModSummary -> m ModSummary
125initPlugins modSummary = do
148initPlugins modSummary = do
@@ -131,18 +154,25 @@ initPlugins modSummary = do
131 return modSummary
154 return modSummary
132#endif
155#endif
133
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+
134-- | Compile a single type-checked module to a 'CoreModule' value, or
163-- | Compile a single type-checked module to a 'CoreModule' value, or
135-- provide errors.
164-- provide errors.
136compileModule
165compileModule
166+ :: RunSimplifier
137− :: HscEnv
167+ -> HscEnv
138− -> [TcModuleResult]
168+ -> [(ModSummary, HomeModInfo)]
139 -> TcModuleResult
169 -> TcModuleResult
140 -> IO (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
170 -> IO (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
141−compileModule packageState deps tmr =
171+compileModule (RunSimplifier simplify) packageState deps tmr =
142 fmap (either (, Nothing) (second Just)) $
172 fmap (either (, Nothing) (second Just)) $
143− runGhcEnv packageState $
173+ evalGhcEnv packageState $
144 catchSrcErrors "compile" $ do
174 catchSrcErrors "compile" $ do
145− setupEnv (deps ++ [tmr])
175+ setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])
146
176
147 let tm = tmrModule tmr
177 let tm = tmrModule tmr
148 session <- getSession
178 session <- getSession
@@ -152,21 +182,22 @@ compileModule packageState deps tmr =
152 let tm' = tm{tm_parsed_module = pm'}
182 let tm' = tm{tm_parsed_module = pm'}
153 GHC.dm_core_module <$> GHC.desugarModule tm'
183 GHC.dm_core_module <$> GHC.desugarModule tm'
154 let tc_result = fst (tm_internals_ (tmrModule tmr))
184 let tc_result = fst (tm_internals_ (tmrModule tmr))
155− -- Have to call the simplifier on the code even if we are at
185+ desugared_guts <-
156− -- -O0 as otherwise the code generation fails which leads to
186+ if simplify
157− -- errors like #256
187+ then do
158− plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
188+ plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
159− desugared_guts <- liftIO $ hscSimplify session plugins desugar
189+ liftIO $ hscSimplify session plugins desugar
190+ else pure desugar
160 -- give variables unique OccNames
191 -- give variables unique OccNames
161 (guts, details) <- liftIO $ tidyProgram session desugared_guts
192 (guts, details) <- liftIO $ tidyProgram session desugared_guts
162 return (map snd warnings, (mg_safe_haskell desugar, guts, details))
193 return (map snd warnings, (mg_safe_haskell desugar, guts, details))
163
194
164−generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable)
195+generateByteCode :: HscEnv -> [(ModSummary, HomeModInfo)] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable)
165generateByteCode hscEnv deps tmr guts =
196generateByteCode hscEnv deps tmr guts =
166 fmap (either (, Nothing) (second Just)) $
197 fmap (either (, Nothing) (second Just)) $
167− runGhcEnv hscEnv $
198+ evalGhcEnv hscEnv $
168 catchSrcErrors "bytecode" $ do
199 catchSrcErrors "bytecode" $ do
169− setupEnv (deps ++ [tmr])
200+ setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])
170 session <- getSession
201 session <- getSession
171 (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->
202 (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->
172#if MIN_GHC_API_VERSION(8,10,0)
203#if MIN_GHC_API_VERSION(8,10,0)
@@ -224,7 +255,7 @@ hideDiag originalFlags (Reason warning, (nfp, _sh, fd))
224 | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))
255 | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))
225hideDiag _originalFlags t = t
256hideDiag _originalFlags t = t
226
257
227−addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags
258+addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags
228addRelativeImport fp modu dflags = dflags
259addRelativeImport fp modu dflags = dflags
229 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
260 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
230
261
@@ -234,29 +265,81 @@ mkTcModuleResult
234 -> m TcModuleResult
265 -> m TcModuleResult
235mkTcModuleResult tcm = do
266mkTcModuleResult tcm = do
236 session <- getSession
267 session <- getSession
268+ let sf = modInfoSafe (tm_checked_module_info tcm)
237#if MIN_GHC_API_VERSION(8,10,0)
269#if MIN_GHC_API_VERSION(8,10,0)
238− iface <- liftIO $ mkIfaceTc session Sf_None details tcGblEnv
270+ iface <- liftIO $ mkIfaceTc session sf details tcGblEnv
239#else
271#else
240− (iface, _) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv
272+ (iface, _) <- liftIO $ mkIfaceTc session Nothing sf details tcGblEnv
241#endif
273#endif
242 let mod_info = HomeModInfo iface details Nothing
274 let mod_info = HomeModInfo iface details Nothing
243 return $ TcModuleResult tcm mod_info
275 return $ TcModuleResult tcm mod_info
244 where
276 where
245 (tcGblEnv, details) = tm_internals_ tcm
277 (tcGblEnv, details) = tm_internals_ tcm
246
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+
247-- | Setup the environment that GHC needs according to our
325-- | Setup the environment that GHC needs according to our
248-- best understanding (!)
326-- best understanding (!)
327+--
328+-- This involves setting up the finder cache and populating the
329+-- HPT.
249−setupEnv :: GhcMonad m => [TcModuleResult] -> m ()
330+setupEnv :: GhcMonad m => [(ModSummary, HomeModInfo)] -> m ()
250−setupEnv tmsIn = do
331+setupEnv tms = do
251− -- 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)
252− -- takes precedence, so put the .hs-boot file earlier in the list
333+ -- load dependent modules, which must be in topological order.
253− let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule
334+ modifySession $ \e ->
254− tms = sortBy (compare `on` Down . isSourceFile) tmsIn
335+ foldl' (\e (_, hmi) -> loadModuleHome hmi e) e tms
255
336
337+-- | Initialise the finder cache, dependencies should be topologically
338+-- sorted.
339+setupFinderCache :: GhcMonad m => [ModSummary] -> m ()
340+setupFinderCache mss = do
256 session <- getSession
341 session <- getSession
257
342
258− let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms
259−
260 -- set the target and module graph in the session
343 -- set the target and module graph in the session
261 let graph = mkModuleGraph mss
344 let graph = mkModuleGraph mss
262 setSession session { hsc_mod_graph = graph }
345 setSession session { hsc_mod_graph = graph }
@@ -275,26 +358,40 @@ setupEnv tmsIn = do
275 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache
358 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache
276 modifySession $ \s -> s { hsc_FC = newFinderCacheVar }
359 modifySession $ \s -> s { hsc_FC = newFinderCacheVar }
277
360
278− -- load dependent modules, which must be in topological order.
279− mapM_ loadModuleHome tms
280−
281
361
282-- | Load a module, quickly. Input doesn't need to be desugared.
362-- | Load a module, quickly. Input doesn't need to be desugared.
283-- A module must be loaded before dependent modules can be typechecked.
363-- A module must be loaded before dependent modules can be typechecked.
284-- This variant of loadModuleHome will *never* cause recompilation, it just
364-- This variant of loadModuleHome will *never* cause recompilation, it just
285-- 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.
286loadModuleHome
370loadModuleHome
287− :: (GhcMonad m)
371+ :: HomeModInfo
288− => TcModuleResult
372+ -> HscEnv
289− -> m ()
373+ -> HscEnv
290−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
291− 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) }
292− where
384+ initIfaceLoad hsc' (typecheckIface iface)
293− ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr
385+ let mod_info = HomeModInfo iface details linkable
294− mod_info = tmrModInfo tmr
386+ return $ loadModuleHome mod_info hsc
295− mod = ms_mod_name ms
387+ where
296−
388+ mod = moduleName $ mi_module iface
297
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'
298
395
299-- | 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
300-- name and its imports.
397-- name and its imports.
@@ -315,16 +412,14 @@ getImportsParsed dflags (L loc parsed) = do
315 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
412 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
316 ])
413 ])
317
414
318−
319-- | Produce a module summary from a StringBuffer.
415-- | Produce a module summary from a StringBuffer.
320getModSummaryFromBuffer
416getModSummaryFromBuffer
321 :: GhcMonad m
417 :: GhcMonad m
322 => FilePath
418 => FilePath
323− -> SB.StringBuffer
324 -> DynFlags
419 -> DynFlags
325 -> GHC.ParsedSource
420 -> GHC.ParsedSource
326 -> ExceptT [FileDiagnostic] m ModSummary
421 -> ExceptT [FileDiagnostic] m ModSummary
327−getModSummaryFromBuffer fp contents dflags parsed = do
422+getModSummaryFromBuffer fp dflags parsed = do
328 (modName, imports) <- liftEither $ getImportsParsed dflags parsed
423 (modName, imports) <- liftEither $ getImportsParsed dflags parsed
329
424
330 modLoc <- liftIO $ mkHomeModLocation dflags modName fp
425 modLoc <- liftIO $ mkHomeModLocation dflags modName fp
@@ -340,7 +435,7 @@ getModSummaryFromBuffer fp contents dflags parsed = do
340 , ms_textual_imps = [imp | (False, imp) <- imports]
435 , ms_textual_imps = [imp | (False, imp) <- imports]
341 , ms_hspp_file = fp
436 , ms_hspp_file = fp
342 , ms_hspp_opts = dflags
437 , ms_hspp_opts = dflags
343− , ms_hspp_buf = Just contents
438+ , ms_hspp_buf = Nothing
344
439
345 -- defaults:
440 -- defaults:
346 , ms_hsc_src = sourceType
441 , ms_hsc_src = sourceType
@@ -355,17 +450,61 @@ getModSummaryFromBuffer fp contents dflags parsed = do
355 where
450 where
356 sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile
451 sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile
357
452
358−
453+-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports.
454+-- Runs preprocessors as needed.
455+getModSummaryFromImports
456+ :: (HasDynFlags m, ExceptionMonad m, MonadIO m)
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+
359−-- | Given a buffer, flags, file path and module summary, produce a
497+-- | Given a buffer, flags, and file path, produce a
360-- parsed module (or errors) and any parse warnings. Does not run any preprocessors
498-- parsed module (or errors) and any parse warnings. Does not run any preprocessors
361parseFileContents
499parseFileContents
362 :: GhcMonad m
500 :: GhcMonad m
363 => (GHC.ParsedSource -> IdePreprocessedSource)
501 => (GHC.ParsedSource -> IdePreprocessedSource)
364 -> DynFlags -- ^ flags to use
502 -> DynFlags -- ^ flags to use
503+ -> [PackageName] -- ^ The package imports to ignore
365 -> FilePath -- ^ the filename (for source locations)
504 -> FilePath -- ^ the filename (for source locations)
366 -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
505 -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
367 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
506 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)
368−parseFileContents customPreprocessor dflags filename contents = do
507+parseFileContents customPreprocessor dflags comp_pkgs filename contents = do
369 let loc = mkRealSrcLoc (mkFastString filename) 1 1
508 let loc = mkRealSrcLoc (mkFastString filename) 1 1
370 case unP Parser.parseModule (mkPState dflags contents loc) of
509 case unP Parser.parseModule (mkPState dflags contents loc) of
371#if MIN_GHC_API_VERSION(8,10,0)
510#if MIN_GHC_API_VERSION(8,10,0)
@@ -397,20 +536,63 @@ parseFileContents customPreprocessor dflags filename contents = do
397 -- Ok, we got here. It's safe to continue.
536 -- Ok, we got here. It's safe to continue.
398 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
537 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
399 unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs
538 unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs
539+ let parsed' = removePackageImports comp_pkgs parsed
400 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
540 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
401− ms <- getModSummaryFromBuffer filename contents dflags parsed
541+ ms <- getModSummaryFromBuffer filename dflags parsed'
402 let pm =
542 let pm =
403 ParsedModule {
543 ParsedModule {
404 pm_mod_summary = ms
544 pm_mod_summary = ms
405− , pm_parsed_source = parsed
545+ , pm_parsed_source = parsed'
406 , pm_extra_src_files=[] -- src imports not allowed
546 , pm_extra_src_files=[] -- src imports not allowed
407 , pm_annotations = hpm_annotations
547 , pm_annotations = hpm_annotations
408 }
548 }
409 warnings = diagFromErrMsgs "parser" dflags warns
549 warnings = diagFromErrMsgs "parser" dflags warns
410 pure (warnings ++ preproc_warnings, pm)
550 pure (warnings ++ preproc_warnings, pm)
411
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+
412loadHieFile :: FilePath -> IO GHC.HieFile
567loadHieFile :: FilePath -> IO GHC.HieFile
413loadHieFile f = do
568loadHieFile f = do
414 u <- mkSplitUniqSupply 'a'
569 u <- mkSplitUniqSupply 'a'
415 let nameCache = initNameCache u []
570 let nameCache = initNameCache u []
416 fmap (GHC.hie_file_result . fst) $ GHC.readHieFile nameCache f
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/FileExists.hs+19−40
@@ -91,20 +91,24 @@ getFileExists fp = use_ GetFileExists fp
91-- Provides a fast implementation if client supports dynamic watched files.
91-- Provides a fast implementation if client supports dynamic watched files.
92-- Creates a global state as a side effect in that case.
92-- Creates a global state as a side effect in that case.
93fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules ()
93fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules ()
94−fileExistsRules getLspId ClientCapabilities{_workspace} vfs
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
95− | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
100+ _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
96− , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
101+ , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
97− , Just True <- _dynamicRegistration
102+ , Just True <- _dynamicRegistration
98− = fileExistsRulesFast getLspId vfs
103+ -> fileExistsRulesFast getLspId vfs
99− | otherwise = do
104+ | otherwise -> do
100− logger <- logger <$> getShakeExtrasRules
105+ logger <- logger <$> getShakeExtrasRules
101− liftIO $ logDebug logger "Warning: Client does not support watched files. Falling back to OS polling"
106+ liftIO $ logDebug logger "Warning: Client does not support watched files. Falling back to OS polling"
102− fileExistsRulesSlow vfs
107+ fileExistsRulesSlow vfs
103
108
104-- Requires an lsp client that provides WatchedFiles notifications.
109-- Requires an lsp client that provides WatchedFiles notifications.
105fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()
110fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()
106−fileExistsRulesFast getLspId vfs = do
111+fileExistsRulesFast getLspId vfs =
107− addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])
108 defineEarlyCutoff $ \GetFileExists file -> do
112 defineEarlyCutoff $ \GetFileExists file -> do
109 isWf <- isWorkspaceFile file
113 isWf <- isWorkspaceFile file
110 if isWf
114 if isWf
@@ -146,9 +150,10 @@ fileExistsFast getLspId vfs file = do
146 WorkspaceDidChangeWatchedFiles
150 WorkspaceDidChangeWatchedFiles
147 (Just (A.toJSON regOptions))
151 (Just (A.toJSON regOptions))
148 regOptions =
152 regOptions =
149− DidChangeWatchedFilesRegistrationOptions { watchers = List [watcher] }
153+ DidChangeWatchedFilesRegistrationOptions { _watchers = List [watcher] }
154+ watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True}
150− watcher = FileSystemWatcher { globPattern = fromNormalizedFilePath fp
155+ watcher = FileSystemWatcher { _globPattern = fromNormalizedFilePath fp
151− , kind = Just 5 -- Create and Delete events only
156+ , _kind = Just watchKind
152 }
157 }
153
158
154 eventer $ ReqRegisterCapability req
159 eventer $ ReqRegisterCapability req
@@ -174,29 +179,3 @@ getFileExistsVFS vfs file = do
174 handle (\(_ :: IOException) -> return False) $
179 handle (\(_ :: IOException) -> return False) $
175 (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
180 (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
176 Dir.doesFileExist (fromNormalizedFilePath file)
181 Dir.doesFileExist (fromNormalizedFilePath file)
177−
178−--------------------------------------------------------------------------------------------------
179−-- The message definitions below probably belong in haskell-lsp-types
180−
181−data DidChangeWatchedFilesRegistrationOptions = DidChangeWatchedFilesRegistrationOptions
182− { watchers :: List FileSystemWatcher
183− }
184−
185−instance A.ToJSON DidChangeWatchedFilesRegistrationOptions where
186− toJSON DidChangeWatchedFilesRegistrationOptions {..} =
187− A.object ["watchers" A..= watchers]
188−
189−data FileSystemWatcher = FileSystemWatcher
190− { -- | The glob pattern to watch.
191− -- For details on glob pattern syntax, check the spec: https://microsoft.github.io/language-server-protocol/specifications/specification-3-14/#workspace_didChangeWatchedFiles
192− globPattern :: String
193− -- | The kind of event to subscribe to. Defaults to all.
194− -- Defined as a bitmap of Create(1), Change(2), and Delete(4)
195− , kind :: Maybe Int
196− }
197−
198−instance A.ToJSON FileSystemWatcher where
199− toJSON FileSystemWatcher {..} =
200− A.object
201− $ ["globPattern" A..= globPattern]
202− ++ [ "kind" A..= x | Just x <- [kind] ]
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+14−5
@@ -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
src/Development/IDE/Core/RuleTypes.hs+52
@@ -57,6 +57,22 @@ instance Show TcModuleResult where
57instance NFData TcModuleResult where
57instance NFData TcModuleResult where
58 rnf = rwhnf
58 rnf = rwhnf
59
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+
60-- | The type checked version of this file, requires TypeCheck+
76-- | The type checked version of this file, requires TypeCheck+
61type instance RuleResult TypeCheck = TcModuleResult
77type instance RuleResult TypeCheck = TcModuleResult
62
78
@@ -81,6 +97,18 @@ type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe Artifa
81-- we can only report diagnostics for the current file.
97-- we can only report diagnostics for the current file.
82type instance RuleResult ReportImportCycles = ()
98type instance RuleResult ReportImportCycles = ()
83
99
100+-- | Read the module interface file
101+type instance RuleResult GetHiFile = HiFileResult
102+
103+-- | Get a module interface, either from an interface file or a typechecked module
104+type instance RuleResult GetModIface = HiFileResult
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
111+
84data GetParsedModule = GetParsedModule
112data GetParsedModule = GetParsedModule
85 deriving (Eq, Show, Typeable, Generic)
113 deriving (Eq, Show, Typeable, Generic)
86instance Hashable GetParsedModule
114instance Hashable GetParsedModule
@@ -140,3 +168,27 @@ data GhcSession = GhcSession
140instance Hashable GhcSession
168instance Hashable GhcSession
141instance NFData GhcSession
169instance NFData GhcSession
142instance Binary GhcSession
170instance Binary GhcSession
171+
172+data GetHiFile = GetHiFile
173+ deriving (Eq, Show, Typeable, Generic)
174+instance Hashable GetHiFile
175+instance NFData GetHiFile
176+instance Binary GetHiFile
177+
178+data GetModIface = GetModIface
179+ deriving (Eq, Show, Typeable, Generic)
180+instance Hashable GetModIface
181+instance NFData GetModIface
182+instance Binary GetModIface
183+
184+data IsFileOfInterest = IsFileOfInterest
185+ deriving (Eq, Show, Typeable, Generic)
186+instance Hashable IsFileOfInterest
187+instance NFData IsFileOfInterest
188+instance Binary IsFileOfInterest
189+
190+data GetModSummary = GetModSummary
191+ deriving (Eq, Show, Typeable, Generic)
192+instance Hashable GetModSummary
193+instance NFData GetModSummary
194+instance Binary GetModSummary
src/Development/IDE/Core/Rules.hs+367−109
@@ -1,10 +1,11 @@
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 #-}
7−{-# LANGUAGE PatternSynonyms #-}
8+#include "ghc-api-version.h"
8
9
9-- | A Shake implementation of the compiler service, built
10-- | A Shake implementation of the compiler service, built
10-- using the "Shaker" abstraction layer for in-memory use.
11-- using the "Shaker" abstraction layer for in-memory use.
@@ -27,12 +28,13 @@ module Development.IDE.Core.Rules(
27
28
28import Fingerprint
29import Fingerprint
29
30
30−import Data.Binary
31+import Data.Binary hiding (get, put)
31−import Data.Bifunctor (second)
32+import Data.Bifunctor (first, second)
32import Control.Monad.Extra
33import Control.Monad.Extra
33import Control.Monad.Trans.Class
34import Control.Monad.Trans.Class
34import Control.Monad.Trans.Maybe
35import Control.Monad.Trans.Maybe
35import Development.IDE.Core.Compile
36import Development.IDE.Core.Compile
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
@@ -43,12 +45,12 @@ import Development.IDE.Types.Diagnostics
43import Development.IDE.Types.Location
45import Development.IDE.Types.Location
44import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)
46import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)
45import Development.IDE.GHC.Util
47import Development.IDE.GHC.Util
46−import Data.Coerce
48+import Development.IDE.GHC.WithDynFlags
47import Data.Either.Extra
49import Data.Either.Extra
48import Data.Maybe
50import Data.Maybe
49import Data.Foldable
51import Data.Foldable
50import qualified Data.IntMap.Strict as IntMap
52import qualified Data.IntMap.Strict as IntMap
51−import qualified Data.IntSet as IntSet
53+import Data.IntMap.Strict (IntMap)
52import Data.List
54import Data.List
53import Data.Ord
55import Data.Ord
54import qualified Data.Set as Set
56import qualified Data.Set as Set
@@ -57,16 +59,23 @@ import Development.IDE.GHC.Error
57import Development.Shake hiding (Diagnostic)
59import Development.Shake hiding (Diagnostic)
58import Development.IDE.Core.RuleTypes
60import Development.IDE.Core.RuleTypes
59import Development.IDE.Spans.Type
61import Development.IDE.Spans.Type
62+import qualified Data.ByteString.Char8 as BS
60
63
61import qualified GHC.LanguageExtensions as LangExt
64import qualified GHC.LanguageExtensions as LangExt
62import HscTypes
65import HscTypes
66+import PackageConfig
63−import DynFlags (xopt)
67+import DynFlags (gopt_set, xopt)
64import GHC.Generics(Generic)
68import GHC.Generics(Generic)
65
69
66import qualified Development.IDE.Spans.AtPoint as AtPoint
70import qualified Development.IDE.Spans.AtPoint as AtPoint
67import Development.IDE.Core.Service
71import Development.IDE.Core.Service
68import Development.IDE.Core.Shake
72import Development.IDE.Core.Shake
69−import Development.Shake.Classes
73+import Development.Shake.Classes hiding (get, put)
74+import Control.Monad.Trans.Except (runExceptT)
75+import Data.ByteString (ByteString)
76+import Control.Concurrent.Async (concurrently)
77+
78+import Control.Monad.State
70
79
71-- | This is useful for rules to convert rules that can only produce errors or
80-- | This is useful for rules to convert rules that can only produce errors or
72-- a result into the more general IdeResult type that supports producing
81-- a result into the more general IdeResult type that supports producing
@@ -80,14 +89,14 @@ useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v
80useE k = MaybeT . use k
89useE k = MaybeT . use k
81
90
82useNoFileE :: IdeRule k v => k -> MaybeT Action v
91useNoFileE :: IdeRule k v => k -> MaybeT Action v
83−useNoFileE k = useE k ""
92+useNoFileE k = useE k emptyFilePath
84
93
85usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
94usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
86usesE k = MaybeT . fmap sequence . uses k
95usesE k = MaybeT . fmap sequence . uses k
87
96
88defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
97defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
89defineNoFile f = define $ \k file -> do
98defineNoFile f = define $ \k file -> do
90− if file == "" then do res <- f k; return ([], Just res) else
99+ if file == emptyFilePath then do res <- f k; return ([], Just res) else
91 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
100 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"
92
101
93
102
@@ -129,21 +138,19 @@ getHieFile file mod = do
129
138
130getHomeHieFile :: NormalizedFilePath -> Action ([a], Maybe HieFile)
139getHomeHieFile :: NormalizedFilePath -> Action ([a], Maybe HieFile)
131getHomeHieFile f = do
140getHomeHieFile f = do
132− pm <- use_ GetParsedModule f
141+ ms <- use_ GetModSummary f
133− let normal_hie_f = toNormalizedFilePath hie_f
142+ let normal_hie_f = toNormalizedFilePath' hie_f
134− hie_f = ml_hie_file $ ms_location $ pm_mod_summary pm
143+ hie_f = ml_hie_file $ ms_location ms
135 mbHieTimestamp <- use GetModificationTime normal_hie_f
144 mbHieTimestamp <- use GetModificationTime normal_hie_f
136 srcTimestamp <- use_ GetModificationTime f
145 srcTimestamp <- use_ GetModificationTime f
137−
138 let isUpToDate
146 let isUpToDate
139 | Just d <- mbHieTimestamp = comparing modificationTime d srcTimestamp == GT
147 | Just d <- mbHieTimestamp = comparing modificationTime d srcTimestamp == GT
140 | otherwise = False
148 | otherwise = False
141
149
142−-- In the future, TypeCheck will emit .hie files as a side effect
143−-- unless isUpToDate $
150+ unless isUpToDate $
144−-- void $ use_ TypeCheck f
151+ void $ use_ TypeCheck f
145
152
146− hf <- liftIO $ if isUpToDate then Just <$> loadHieFile hie_f else pure Nothing
153+ hf <- liftIO $ whenMaybe isUpToDate (loadHieFile hie_f)
147 return ([], hf)
154 return ([], hf)
148
155
149getPackageHieFile :: Module -- ^ Package Module to load .hie file for
156getPackageHieFile :: Module -- ^ Package Module to load .hie file for
@@ -184,31 +191,60 @@ priorityFilesOfInterest :: Priority
184priorityFilesOfInterest = Priority (-2)
191priorityFilesOfInterest = Priority (-2)
185
192
186getParsedModuleRule :: Rules ()
193getParsedModuleRule :: Rules ()
187−getParsedModuleRule =
188− defineEarlyCutoff $ \GetParsedModule file -> do
194+getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
189− (_, contents) <- getFileContents file
190− 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)
191− 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
192− (diag, res) <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) (fmap textToStringBuffer contents)
227+ (diag, res) <- parseModule opt packageState comp_pkgs (fromNormalizedFilePath file) (fmap textToStringBuffer contents)
193− case res of
228+ case res of
194− Nothing -> pure (Nothing, (diag, Nothing))
229+ Nothing -> pure (Nothing, (diag, Nothing))
195− Just (contents, modu) -> do
230+ Just (contents, modu) -> do
196− mbFingerprint <- if isNothing $ optShakeFiles opt
231+ mbFingerprint <- if isNothing $ optShakeFiles opt
197− then pure Nothing
232+ then pure Nothing
198− else liftIO $ Just . fingerprintToBS <$> fingerprintFromStringBuffer contents
233+ else Just . fingerprintToBS <$> fingerprintFromStringBuffer contents
199− pure (mbFingerprint, (diag, Just modu))
234+ pure (mbFingerprint, (diag, Just modu))
200
235
201getLocatedImportsRule :: Rules ()
236getLocatedImportsRule :: Rules ()
202getLocatedImportsRule =
237getLocatedImportsRule =
203 define $ \GetLocatedImports file -> do
238 define $ \GetLocatedImports file -> do
204− pm <- use_ GetParsedModule file
239+ ms <- use_ GetModSummary file
205− let ms = pm_mod_summary pm
206 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]
207− env <- hscEnv <$> use_ GhcSession file
241+ env_eq <- use_ GhcSession file
242+ let env = hscEnv env_eq
243+ let import_dirs = deps env_eq
208− let dflags = addRelativeImport file pm $ hsc_dflags env
244+ let dflags = addRelativeImport file (moduleName $ ms_mod ms) $ hsc_dflags env
209 opt <- getIdeOptions
245 opt <- getIdeOptions
210 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
246 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
211− diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource
247+ diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getFileExists modName mbPkgName isSource
212 case diagOrImp of
248 case diagOrImp of
213 Left diags -> pure (diags, Left (modName, Nothing))
249 Left diags -> pure (diags, Left (modName, Nothing))
214 Right (FileImport path) -> pure ([], Left (modName, Just path))
250 Right (FileImport path) -> pure ([], Left (modName, Just path))
@@ -222,49 +258,109 @@ getLocatedImportsRule =
222 Nothing -> pure (concat diags, Nothing)
258 Nothing -> pure (concat diags, Nothing)
223 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))
259 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))
224
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+ )
225
269
226-- | 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
227-- imports recursively.
271-- imports recursively.
228−rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation
272+rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation
229−rawDependencyInformation f = do
273+rawDependencyInformation fs = do
230− let initialArtifact = ArtifactsLocation f (ModLocation (Just $ fromNormalizedFilePath f) "" "")
274+ (rdi, ss) <- execRawDepM (mapM_ go fs)
231− (initialId, initialMap) = getPathId initialArtifact emptyPathIdMap
275+ let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss
232− go (IntSet.singleton $ getFilePathId initialId)
276+ return (rdi { rawBootMap = bm })
233− (RawDependencyInformation IntMap.empty initialMap)
234 where
277 where
235− go fs rawDepInfo =
278+ go :: NormalizedFilePath -- ^ Current module being processed
236− case IntSet.minView fs of
279+ -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId
237− -- Queue is empty
280+ go f = do
238− Nothing -> pure rawDepInfo
281+ -- First check to see if we have already processed the FilePath
239− -- Pop f from the queue and process it
282+ -- If we have, just return its Id but don't update any of the state.
240− Just (f, fs) -> do
283+ -- Otherwise, we need to process its imports.
241− 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
242− importsOrErr <- use GetLocatedImports $ idToPath (rawPathIdMap rawDepInfo) fId
292+ importsOrErr <- lift $ use GetLocatedImports f
243− case importsOrErr of
293+ case importsOrErr of
244− Nothing ->
294+ Nothing -> do
245− -- 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
246− let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo
298+ modifyRawDepInfo (insertImport fId (Left ModuleParseError))
247− in go fs rawDepInfo'
299+ return fId
248− Just (modImports, pkgImports) -> do
300+ Just (modImports, pkgImports) -> do
249− let f :: PathIdMap -> (a, Maybe ArtifactsLocation) -> (PathIdMap, (a, Maybe FilePathId))
301+ -- Get NFPs of the imports which have corresponding files
250− f pathMap (imp, mbPath) = case mbPath of
302+ -- Imports either come locally from a file or from a package.
251− Nothing -> (pathMap, (imp, Nothing))
303+ let (no_file, with_file) = splitImports modImports
252− Just path ->
304+ (mns, ls) = unzip with_file
253− let (pathId, pathMap') = getPathId path pathMap
305+ -- Recursively process all the imports we just learnt about
254− in (pathMap', (imp, Just pathId))
306+ -- and get back a list of their FilePathIds
255− -- Convert paths in imports to ids and update the path map
307+ fids <- mapM (go . artifactFilePath) ls
256− let (pathIdMap, modImports') = mapAccumL f (rawPathIdMap rawDepInfo) modImports
308+ -- Associate together the ModuleName with the FilePathId
257− -- Files that we haven’t seen before are added to the queue.
309+ let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids)
258− let newFiles =
310+ -- Insert into the map the information about this modules
259− IntSet.fromList (coerce $ mapMaybe snd modImports')
311+ -- imports.
260− IntSet.\\ IntMap.keysSet (rawImports rawDepInfo)
261− let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo
312+ modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports' pkgImports)
262− 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"
263
359
264getDependencyInformationRule :: Rules ()
360getDependencyInformationRule :: Rules ()
265getDependencyInformationRule =
361getDependencyInformationRule =
266 define $ \GetDependencyInformation file -> do
362 define $ \GetDependencyInformation file -> do
267− rawDepInfo <- rawDependencyInformation file
363+ rawDepInfo <- rawDependencyInformation [file]
268 pure ([], Just $ processDependencyInformation rawDepInfo)
364 pure ([], Just $ processDependencyInformation rawDepInfo)
269
365
270reportImportCyclesRule :: Rules ()
366reportImportCyclesRule :: Rules ()
@@ -292,12 +388,13 @@ reportImportCyclesRule =
292 , _message = "Cyclic module dependency between " <> showCycle mods
388 , _message = "Cyclic module dependency between " <> showCycle mods
293 , _code = Nothing
389 , _code = Nothing
294 , _relatedInformation = Nothing
390 , _relatedInformation = Nothing
391+ , _tags = Nothing
295 }
392 }
296 where loc = srcSpanToLocation (getLoc imp)
393 where loc = srcSpanToLocation (getLoc imp)
297− fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)
394+ fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp)
298 getModuleName file = do
395 getModuleName file = do
299− pm <- use_ GetParsedModule file
396+ ms <- use_ GetModSummary file
300− pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)
397+ pure (moduleNameString . moduleName . ms_mod $ ms)
301 showCycle mods = T.intercalate ", " (map T.pack mods)
398 showCycle mods = T.intercalate ", " (map T.pack mods)
302
399
303-- returns all transitive dependencies in topological order.
400-- returns all transitive dependencies in topological order.
@@ -317,51 +414,101 @@ getSpanInfoRule :: Rules ()
317getSpanInfoRule =
414getSpanInfoRule =
318 define $ \GetSpanInfo file -> do
415 define $ \GetSpanInfo file -> do
319 tc <- use_ TypeCheck file
416 tc <- use_ TypeCheck file
417+ packageState <- hscEnv <$> use_ GhcSession file
320 deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
418 deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
321− parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)
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
322 (fileImports, _) <- use_ GetLocatedImports file
430 (fileImports, _) <- use_ GetLocatedImports file
323− packageState <- hscEnv <$> use_ GhcSession file
324 let imports = second (fmap artifactFilePath) <$> fileImports
431 let imports = second (fmap artifactFilePath) <$> fileImports
325− x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps
432+ x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps (map hirModIface ifaces)
326 return ([], Just x)
433 return ([], Just x)
327
434
328-- Typechecks a module.
435-- Typechecks a module.
329typeCheckRule :: Rules ()
436typeCheckRule :: Rules ()
330−typeCheckRule =
331− define $ \TypeCheck file -> do
437+typeCheckRule = define $ \TypeCheck file -> do
332− 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
333− deps <- use_ GetDependencies file
458+ deps <- use_ GetDependencies file
334− packageState <- hscEnv <$> use_ GhcSession file
459+ hsc <- hscEnv <$> use_ GhcSession file
335− -- Figure out whether we need TemplateHaskell or QuasiQuotes support
460+ -- Figure out whether we need TemplateHaskell or QuasiQuotes support
336− let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph packageState
461+ let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc
337− 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)
338− 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)
339− tms <- if any_uses_th_qq
465+ bytecodes <- if any_uses_th_qq
340− -- If we use TH or QQ, we must obtain the bytecode
466+ then -- If we use TH or QQ, we must obtain the bytecode
341− then do
342− bytecodes <- uses_ GenerateByteCode (transitiveModuleDeps deps)
467+ fmap Just <$> uses_ GenerateByteCode (transitiveModuleDeps deps)
343− tmrs <- uses_ TypeCheck (transitiveModuleDeps deps)
468+ else
344− pure (zipWith addByteCode bytecodes tmrs)
469+ pure $ repeat Nothing
345− else uses_ TypeCheck (transitiveModuleDeps deps)
470+
346− setPriority priorityTypeCheck
471+ setPriority priorityTypeCheck
347− IdeOptions{ optDefer = defer} <- getIdeOptions
472+ IdeOptions { optDefer = defer } <- getIdeOptions
473+
474+ addUsageDependencies $ liftIO $ do
348− 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)
349− where
483+ where
484+ unpack HiFileResult{..} bc = (hirModSummary, (hirModIface, bc))
485+ uses_th_qq dflags =
350− uses_th_qq dflags = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
486+ xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
487+
351− addByteCode :: Linkable -> TcModuleResult -> TcModuleResult
488+ addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)
352− addByteCode lm tmr = tmr { tmrModInfo = (tmrModInfo tmr) { hm_linkable = Just lm } }
489+ addUsageDependencies a = do
353−
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+
354−generateCore :: NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
501+generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))
355−generateCore file = do
502+generateCore runSimplifier file = do
356 deps <- use_ GetDependencies file
503 deps <- use_ GetDependencies file
357 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
504 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)
358 setPriority priorityGenerateCore
505 setPriority priorityGenerateCore
359 packageState <- hscEnv <$> use_ GhcSession file
506 packageState <- hscEnv <$> use_ GhcSession file
360− liftIO $ compileModule packageState tms tm
507+ liftIO $ compileModule runSimplifier packageState [(tmrModSummary x, tmrModInfo x) | x <- tms] tm
361
508
362generateCoreRule :: Rules ()
509generateCoreRule :: Rules ()
363generateCoreRule =
510generateCoreRule =
364− define $ \GenerateCore -> generateCore
511+ define $ \GenerateCore -> generateCore (RunSimplifier True)
365
512
366generateByteCodeRule :: Rules ()
513generateByteCodeRule :: Rules ()
367generateByteCodeRule =
514generateByteCodeRule =
@@ -370,7 +517,7 @@ generateByteCodeRule =
370 (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)
517 (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)
371 session <- hscEnv <$> use_ GhcSession file
518 session <- hscEnv <$> use_ GhcSession file
372 (_, guts, _) <- use_ GenerateCore file
519 (_, guts, _) <- use_ GenerateCore file
373− liftIO $ generateByteCode session tms tm guts
520+ liftIO $ generateByteCode session [(tmrModSummary x, tmrModInfo x) | x <- tms] tm guts
374
521
375-- 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
376-- 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.
@@ -382,7 +529,7 @@ instance Hashable GhcSessionIO
382instance NFData GhcSessionIO
529instance NFData GhcSessionIO
383instance Binary GhcSessionIO
530instance Binary GhcSessionIO
384
531
385−newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq)
532+newtype GhcSessionFun = GhcSessionFun (FilePath -> Action (IdeResult HscEnvEq))
386instance Show GhcSessionFun where show _ = "GhcSessionFun"
533instance Show GhcSessionFun where show _ = "GhcSessionFun"
387instance NFData GhcSessionFun where rnf !_ = ()
534instance NFData GhcSessionFun where rnf !_ = ()
388
535
@@ -392,11 +539,118 @@ loadGhcSession = do
392 defineNoFile $ \GhcSessionIO -> do
539 defineNoFile $ \GhcSessionIO -> do
393 opts <- getIdeOptions
540 opts <- getIdeOptions
394 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
395 defineEarlyCutoff $ \GhcSession file -> do
546 defineEarlyCutoff $ \GhcSession file -> do
396 GhcSessionFun fun <- useNoFile_ GhcSessionIO
547 GhcSessionFun fun <- useNoFile_ GhcSessionIO
548+ alwaysRerun
397 val <- fun $ fromNormalizedFilePath file
549 val <- fun $ fromNormalizedFilePath file
550+
551+ -- TODO: What was this doing before?
398 opts <- getIdeOptions
552 opts <- getIdeOptions
553+ let cutoffHash =
399− return ("" <$ optShakeFiles opts, ([], Just val))
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)
648+
649+isFileOfInterestRule :: Rules ()
650+isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do
651+ filesOfInterest <- getFilesOfInterest
652+ let res = f `elem` filesOfInterest
653+ return (Just (if res then "1" else ""), ([], Just res))
400
654
401-- | A rule that wires per-file rules together
655-- | A rule that wires per-file rules together
402mainRule :: Rules ()
656mainRule :: Rules ()
@@ -411,3 +665,7 @@ mainRule = do
411 generateCoreRule
665 generateCoreRule
412 generateByteCodeRule
666 generateByteCodeRule
413 loadGhcSession
667 loadGhcSession
668+ getHiFileRule
669+ getModIfaceRule
670+ isFileOfInterestRule
671+ getModSummaryRule
src/Development/IDE/Core/Shake.hs+48−38
@@ -53,7 +53,7 @@ import qualified Data.ByteString.Char8 as BS
53import Data.Dynamic
53import Data.Dynamic
54import Data.Maybe
54import Data.Maybe
55import Data.Map.Strict (Map)
55import Data.Map.Strict (Map)
56−import Data.List.Extra (foldl', partition, takeEnd)
56+import Data.List.Extra (partition, takeEnd)
57import qualified Data.Set as Set
57import qualified Data.Set as Set
58import qualified Data.Text as T
58import qualified Data.Text as T
59import Data.Traversable (for)
59import Data.Traversable (for)
@@ -69,7 +69,7 @@ import Development.IDE.Types.Location
69import Development.IDE.Types.Options
69import Development.IDE.Types.Options
70import Control.Concurrent.Async
70import Control.Concurrent.Async
71import Control.Concurrent.Extra
71import Control.Concurrent.Extra
72−import Control.Exception
72+import Control.Exception.Extra
73import Control.DeepSeq
73import Control.DeepSeq
74import System.Time.Extra
74import System.Time.Extra
75import Data.Typeable
75import Data.Typeable
@@ -97,9 +97,11 @@ data ShakeExtras = ShakeExtras
97 ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])
97 ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])
98 -- ^ This represents the set of diagnostics that we have published.
98 -- ^ This represents the set of diagnostics that we have published.
99 -- Due to debouncing not every change might get published.
99 -- Due to debouncing not every change might get published.
100− ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion PositionMapping))
100+ ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))
101 -- ^ 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
102 -- 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.
103 ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int)
105 ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int)
104 -- ^ How many rules are running for each file
106 -- ^ How many rules are running for each file
105 }
107 }
@@ -124,14 +126,19 @@ addIdeGlobal x = do
124addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()
126addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()
125addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =
127addIdeGlobalExtras 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,12 +205,12 @@ valueVersion = \case
201 Failed -> Nothing
205 Failed -> Nothing
202
206
203mappingForVersion
207mappingForVersion
204− :: HMap.HashMap 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 HMap.lookup (filePathToUri' file) allMappings
215 HMap.lookup (filePathToUri' file) allMappings
212
216
@@ -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
@@ -414,7 +417,7 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =
414 Right _ -> "completed"
417 Right _ -> "completed"
415 profile = case res of
418 profile = case res of
416 Right (_, Just fp) ->
419 Right (_, Just fp) ->
417− let link = case filePathToUri' $ toNormalizedFilePath fp of
420+ let link = case filePathToUri' $ toNormalizedFilePath' fp of
418 NormalizedUri _ x -> x
421 NormalizedUri _ x -> x
419 in ", profile saved at " <> T.unpack link
422 in ", profile saved at " <> T.unpack link
420 _ -> ""
423 _ -> ""
@@ -473,13 +476,13 @@ useWithStale :: IdeRule k v
473useWithStale key file = head <$> usesWithStale key [file]
476useWithStale key file = head <$> usesWithStale key [file]
474
477
475useNoFile :: IdeRule k v => k -> Action (Maybe v)
478useNoFile :: IdeRule k v => k -> Action (Maybe v)
476−useNoFile key = use key ""
479+useNoFile key = use key emptyFilePath
477
480
478use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
481use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
479use_ key file = head <$> uses_ key [file]
482use_ key file = head <$> uses_ key [file]
480
483
481useNoFile_ :: IdeRule k v => k -> Action v
484useNoFile_ :: IdeRule k v => k -> Action v
482−useNoFile_ key = use_ key ""
485+useNoFile_ key = use_ key emptyFilePath
483
486
484uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
487uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
485uses_ key files = do
488uses_ key files = do
@@ -510,12 +513,10 @@ instance Show k => Show (Q k) where
510
513
511-- | Invariant: the 'v' must be in normal form (fully evaluated).
514-- | Invariant: the 'v' must be in normal form (fully evaluated).
512-- 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
513−-- Note (MK) I am not sure why we need the ShakeValue here, maybe we
514−-- can just remove it?
515−data A v = A (Value v) ShakeValue
516+newtype A v = A (Value v)
516 deriving Show
517 deriving Show
517
518
518−instance NFData (A v) where rnf (A v x) = v `seq` rnf x
519+instance NFData (A v) where rnf (A v) = v `seq` ()
519
520
520-- 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,
521-- namely Q (question) / A (answer).
522-- namely Q (question) / A (answer).
@@ -525,19 +526,22 @@ type instance RuleResult (Q k) = A (RuleResult k)
525-- | Return up2date results. Stale results will be ignored.
526-- | Return up2date results. Stale results will be ignored.
526uses :: IdeRule k v
527uses :: IdeRule k v
527 => k -> [NormalizedFilePath] -> Action [Maybe v]
528 => k -> [NormalizedFilePath] -> Action [Maybe v]
528−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)
529
530
530-- | Return the last computed result which might be stale.
531-- | Return the last computed result which might be stale.
531usesWithStale :: IdeRule k v
532usesWithStale :: IdeRule k v
532 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
533 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
533usesWithStale key files = do
534usesWithStale key files = do
534− values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
535+ values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files)
535− mapM (uncurry lastValue) (zip files values)
536+ zipWithM lastValue files values
536
537
537
538
538withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b
539withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b
539withProgress var file = actionBracket (f succ) (const $ f pred) . const
540withProgress 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.
540− where f shift = modifyVar_ var $ return . HMap.alter (Just . shift . fromMaybe 0) file
544+ where f shift = modifyVar_ var $ \x -> evaluate $ HMap.alter (\x -> Just $! shift (fromMaybe 0 x)) file x
541
545
542
546
543defineEarlyCutoff
547defineEarlyCutoff
@@ -554,16 +558,16 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old
554 case v of
558 case v of
555 -- No changes in the dependencies and we have
559 -- No changes in the dependencies and we have
556 -- an existing result.
560 -- an existing result.
557− Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)
561+ Just v -> return $ Just $ RunResult ChangedNothing old $ A v
558 _ -> return Nothing
562 _ -> return Nothing
559 _ -> return Nothing
563 _ -> return Nothing
560 case val of
564 case val of
561 Just res -> return res
565 Just res -> return res
562 Nothing -> do
566 Nothing -> do
563 (bs, (diags, res)) <- actionCatch
567 (bs, (diags, res)) <- actionCatch
564− (do v <- op key file; liftIO $ evaluate $ force $ v) $
568+ (do v <- op key file; liftIO $ evaluate $ force v) $
565 \(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))
566− modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file
570+ modTime <- liftIO $ (currentValue =<<) <$> getValues state GetModificationTime file
567 (bs, res) <- case res of
571 (bs, res) <- case res of
568 Nothing -> do
572 Nothing -> do
569 staleV <- liftIO $ getValues state key file
573 staleV <- liftIO $ getValues state key file
@@ -573,7 +577,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old
573 Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
577 Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
574 Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
578 Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
575 Failed -> (toShakeValue ShakeResult bs, Failed)
579 Failed -> (toShakeValue ShakeResult bs, Failed)
576− Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
580+ Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
577 liftIO $ setValues state key file res
581 liftIO $ setValues state key file res
578 updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
582 updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags
579 let eq = case (bs, fmap decodeShakeValue old) of
583 let eq = case (bs, fmap decodeShakeValue old) of
@@ -585,7 +589,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old
585 return $ RunResult
589 return $ RunResult
586 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
590 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
587 (encodeShakeValue bs) $
591 (encodeShakeValue bs) $
588− A res bs
592+ A res
589
593
590
594
591-- | Rule type, input file
595-- | Rule type, input file
@@ -700,7 +704,7 @@ updateFileDiagnostics ::
700 -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
704 -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
701 -> Action ()
705 -> Action ()
702updateFileDiagnostics 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
703− modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp
707+ modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp
704 let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
708 let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
705 mask_ $ do
709 mask_ $ do
706 -- Mask async exceptions to ensure that updated diagnostics are always
710 -- Mask async exceptions to ensure that updated diagnostics are always
@@ -713,7 +717,7 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, published
713 let newDiags = getFileDiagnostics fp newDiagsStore
717 let newDiags = getFileDiagnostics fp newDiagsStore
714 _ <- evaluate newDiagsStore
718 _ <- evaluate newDiagsStore
715 _ <- evaluate newDiags
719 _ <- evaluate newDiags
716− pure $! (newDiagsStore, newDiags)
720+ pure (newDiagsStore, newDiags)
717 modifyVar_ hiddenDiagnostics $ \old -> do
721 modifyVar_ hiddenDiagnostics $ \old -> do
718 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
722 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
719 (T.pack $ show k) (map snd currentHidden) old
723 (T.pack $ show k) (map snd currentHidden) old
@@ -739,7 +743,7 @@ publishDiagnosticsNotification uri diags =
739newtype Priority = Priority Double
743newtype Priority = Priority Double
740
744
741setPriority :: Priority -> Action ()
745setPriority :: Priority -> Action ()
742−setPriority (Priority p) = deprioritize p
746+setPriority (Priority p) = reschedule p
743
747
744sendEvent :: LSP.FromServerMessage -> Action ()
748sendEvent :: LSP.FromServerMessage -> Action ()
745sendEvent e = do
749sendEvent e = do
@@ -765,7 +769,7 @@ instance Binary GetModificationTime
765type instance RuleResult GetModificationTime = FileVersion
769type instance RuleResult GetModificationTime = FileVersion
766
770
767data FileVersion
771data FileVersion
768− = VFSVersion Int
772+ = VFSVersion !Int
769 | ModificationTime
773 | ModificationTime
770 !Int -- ^ Large unit (platform dependent, do not make assumptions)
774 !Int -- ^ Large unit (platform dependent, do not make assumptions)
771 !Int -- ^ Small unit (platform dependent, do not make assumptions)
775 !Int -- ^ Small unit (platform dependent, do not make assumptions)
@@ -819,7 +823,7 @@ filterDiagnostics ::
819 DiagnosticStore ->
823 DiagnosticStore ->
820 DiagnosticStore
824 DiagnosticStore
821filterDiagnostics keep =
825filterDiagnostics keep =
822− HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)
826+ HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri)
823
827
824filterVersionMap
828filterVersionMap
825 :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)
829 :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)
@@ -829,11 +833,17 @@ filterVersionMap =
829 HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
833 HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
830
834
831updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
835updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
832−updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do
836+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do
833 modifyVar_ positionMapping $ \allMappings -> do
837 modifyVar_ positionMapping $ \allMappings -> do
834 let uri = toNormalizedUri _uri
838 let uri = toNormalizedUri _uri
835 let mappingForUri = HMap.lookupDefault Map.empty uri allMappings
839 let mappingForUri = HMap.lookupDefault Map.empty uri allMappings
836− let updatedMapping =
840+ let (_, updatedMapping) =
841+ -- Very important to use mapAccum here so that the tails of
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
837− Map.insert _version idMapping $
846+ (Map.insert _version (shared_change, zeroMapping) mappingForUri)
838− Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri
839 pure $! HMap.insert uri updatedMapping allMappings
847 pure $! HMap.insert uri updatedMapping allMappings
848+ where
849+ shared_change = mkDelta changes
src/Development/IDE/GHC/Compat.hs+148−19
@@ -7,11 +7,15 @@
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,
15 setDefaultHieDir,
19 setDefaultHieDir,
16 dontWriteHieFiles,
20 dontWriteHieFiles,
17#if !MIN_GHC_API_VERSION(8,8,0)
21#if !MIN_GHC_API_VERSION(8,8,0)
@@ -21,6 +25,8 @@ module Development.IDE.GHC.Compat(
21 includePathsGlobal,
25 includePathsGlobal,
22 includePathsQuote,
26 includePathsQuote,
23 addIncludePathsQuote,
27 addIncludePathsQuote,
28+ getModuleHash,
29+ getPackageName,
24 pattern DerivD,
30 pattern DerivD,
25 pattern ForD,
31 pattern ForD,
26 pattern InstD,
32 pattern InstD,
@@ -30,7 +36,9 @@ module Development.IDE.GHC.Compat(
30 pattern IEThingAll,
36 pattern IEThingAll,
31 pattern IEThingWith,
37 pattern IEThingWith,
32 GHC.ModLocation,
38 GHC.ModLocation,
39+ Module.addBootSuffix,
33 pattern ModLocation,
40 pattern ModLocation,
41+ getConArgs,
34
42
35 module GHC
43 module GHC
36 ) where
44 ) where
@@ -38,21 +46,55 @@ module Development.IDE.GHC.Compat(
38import StringBuffer
46import StringBuffer
39import DynFlags
47import DynFlags
40import FieldLabel
48import FieldLabel
49+import Fingerprint (Fingerprint)
50+import qualified Module
51+import Packages
41
52
42import qualified GHC
53import qualified GHC
54+import GHC hiding (
43−import GHC hiding (ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation)
55+ ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation
56+#if MIN_GHC_API_VERSION(8,6,0)
57+ , getConArgs
58+#endif
59+ )
60+import qualified HeaderInfo as Hdr
61+import Avail
62+import ErrUtils (ErrorMessages)
63+import FastString (FastString)
64+
65+#if MIN_GHC_API_VERSION(8,10,0)
66+import HscTypes (mi_mod_hash)
67+#endif
44
68
45#if MIN_GHC_API_VERSION(8,8,0)
69#if MIN_GHC_API_VERSION(8,8,0)
46−import HieAst
70+import Control.Applicative ((<|>))
71+import Development.IDE.GHC.HieAst (mkHieFile)
47import HieBin
72import HieBin
48import HieTypes
73import HieTypes
74+
75+supportsHieFiles :: Bool
76+supportsHieFiles = True
77+
78+hieExportNames :: HieFile -> [(SrcSpan, Name)]
79+hieExportNames = nameListFromAvails . hie_exports
80+
49#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)
50import GhcPlugins hiding (ModLocation)
92import GhcPlugins hiding (ModLocation)
51import NameCache
93import NameCache
52−import Avail
53import TcRnTypes
94import TcRnTypes
54import System.IO
95import System.IO
55import Foreign.ForeignPtr
96import Foreign.ForeignPtr
97+import MkIface
56
98
57
99
58hPutStringBuffer :: Handle -> StringBuffer -> IO ()
100hPutStringBuffer :: Handle -> StringBuffer -> IO ()
@@ -60,20 +102,6 @@ hPutStringBuffer hdl (StringBuffer buf len cur)
60 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->
102 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->
61 hPutBuf hdl ptr len
103 hPutBuf hdl ptr len
62
104
63−mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile
64−mkHieFile _ _ _ = return (HieFile () [])
65−
66−writeHieFile :: FilePath -> HieFile -> IO ()
67−writeHieFile _ _ = return ()
68−
69−readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())
70−readHieFile _ _ = return (HieFileResult (HieFile () []), ())
71−
72−ml_hie_file :: GHC.ModLocation -> FilePath
73−ml_hie_file _ = ""
74−
75−data HieFile = HieFile {hie_module :: (), hie_exports :: [AvailInfo]}
76−data HieFileResult = HieFileResult { hie_file_result :: HieFile }
77#endif
105#endif
78
106
79#if !MIN_GHC_API_VERSION(8,6,0)
107#if !MIN_GHC_API_VERSION(8,6,0)
@@ -166,7 +194,7 @@ pattern IEThingAll a <-
166setDefaultHieDir :: FilePath -> DynFlags -> DynFlags
194setDefaultHieDir :: FilePath -> DynFlags -> DynFlags
167setDefaultHieDir _f d =
195setDefaultHieDir _f d =
168#if MIN_GHC_API_VERSION(8,8,0)
196#if MIN_GHC_API_VERSION(8,8,0)
169− d { hieDir = hieDir d `mappend` Just _f}
197+ d { hieDir = hieDir d <|> Just _f}
170#else
198#else
171 d
199 d
172#endif
200#endif
@@ -178,3 +206,104 @@ dontWriteHieFiles d =
178#else
206#else
179 d
207 d
180#endif
208#endif
209+
210+nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)]
211+nameListFromAvails as =
212+ map (\n -> (nameSrcSpan n, n)) (concatMap availNames as)
213+
214+#if !MIN_GHC_API_VERSION(8,8,0)
215+-- Reimplementations of functions for HIE files for GHC 8.6
216+
217+mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> ByteString -> Hsc HieFile
218+mkHieFile ms ts _ _ = return (HieFile (ms_mod ms) es)
219+ where
220+ es = nameListFromAvails (mkIfaceExports (tcg_exports ts))
221+
222+ml_hie_file :: GHC.ModLocation -> FilePath
223+ml_hie_file ml = ml_hi_file ml ++ ".hie"
224+
225+data HieFile = HieFile {hie_module :: Module, hie_exports :: [(SrcSpan, Name)]}
226+
227+hieExportNames :: HieFile -> [(SrcSpan, Name)]
228+hieExportNames = hie_exports
229+
230+instance Binary HieFile where
231+ put_ bh (HieFile m es) = do
232+ put_ bh m
233+ put_ bh es
234+
235+ get bh = do
236+ mod <- get bh
237+ es <- get bh
238+ return (HieFile mod es)
239+
240+data HieFileResult = HieFileResult { hie_file_result :: HieFile }
241+
242+writeHieFile :: FilePath -> HieFile -> IO ()
243+readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())
244+supportsHieFiles :: Bool
245+
246+#if MIN_GHC_API_VERSION(8,6,0)
247+
248+writeHieFile fp hie = do
249+ bh <- openBinMem (1024 * 1024)
250+ putWithUserData (const $ return ()) bh hie
251+ writeBinMem bh fp
252+
253+readHieFile nc fp = do
254+ bh <- readBinMem fp
255+ nc' <- newIORef nc
256+ hie_file <- getWithUserData (NCU (atomicModifyIORef' nc')) bh
257+ return (HieFileResult hie_file, ())
258+
259+supportsHieFiles = True
260+
261+#else
262+
263+supportsHieFiles = False
264+
265+writeHieFile _ _ = return ()
266+
267+readHieFile _ _ = return undefined
268+
269+#endif
270+
271+#endif
272+
273+getHeaderImports
274+ :: DynFlags
275+ -> StringBuffer
276+ -> FilePath
277+ -> FilePath
278+ -> IO
279+ ( Either
280+ ErrorMessages
281+ ( [(Maybe FastString, Located ModuleName)]
282+ , [(Maybe FastString, Located ModuleName)]
283+ , Located ModuleName
284+ )
285+ )
286+#if MIN_GHC_API_VERSION(8,8,0)
287+getHeaderImports = Hdr.getImports
288+#else
289+getHeaderImports a b c d =
290+ catch (Right <$> Hdr.getImports a b c d)
291+ (return . Left . srcErrorMessages)
292+#endif
293+
294+getModuleHash :: ModIface -> Fingerprint
295+#if MIN_GHC_API_VERSION(8,10,0)
296+getModuleHash = mi_mod_hash . mi_final_exts
297+#else
298+getModuleHash = mi_mod_hash
299+#endif
300+
301+getConArgs :: ConDecl pass -> HsConDeclDetails pass
302+#if MIN_GHC_API_VERSION(8,6,0)
303+getConArgs = GHC.getConArgs
304+#else
305+getConArgs = GHC.getConDetails
306+#endif
307+
308+getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName
309+getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i))
src/Development/IDE/GHC/Error.hs+27−4
@@ -9,6 +9,7 @@ module Development.IDE.GHC.Error
9 , diagFromStrings
9 , diagFromStrings
10 , diagFromGhcException
10 , diagFromGhcException
11 , catchSrcErrors
11 , catchSrcErrors
12+ , mergeDiagnostics
12
13
13 -- * utilities working with spans
14 -- * utilities working with spans
14 , srcSpanToLocation
15 , srcSpanToLocation
@@ -36,11 +37,12 @@ import Panic
36import ErrUtils
37import ErrUtils
37import SrcLoc
38import SrcLoc
38import qualified Outputable as Out
39import qualified Outputable as Out
40+import Exception (ExceptionMonad)
39
41
40
42
41
43
42diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
44diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic
43−diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,ShowDiag,)
45+diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename loc,ShowDiag,)
44 Diagnostic
46 Diagnostic
45 { _range = srcSpanToRange loc
47 { _range = srcSpanToRange loc
46 , _severity = Just sev
48 , _severity = Just sev
@@ -48,18 +50,39 @@ diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename
48 , _message = msg
50 , _message = msg
49 , _code = Nothing
51 , _code = Nothing
50 , _relatedInformation = Nothing
52 , _relatedInformation = Nothing
53+ , _tags = Nothing
51 }
54 }
52
55
53-- | Produce a GHC-style error from a source span and a message.
56-- | Produce a GHC-style error from a source span and a message.
54diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]
57diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]
55diagFromErrMsg diagSource dflags e =
58diagFromErrMsg diagSource dflags e =
56− [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $ ErrUtils.pprLocErrMsg e
59+ [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $
60+ ErrUtils.formatErrDoc dflags $ ErrUtils.errMsgDoc e
57 | Just sev <- [toDSeverity $ errMsgSeverity e]]
61 | Just sev <- [toDSeverity $ errMsgSeverity e]]
58
62
59
63
60diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
64diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
61diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList
65diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList
62
66
67+-- | Merges two sorted lists of diagnostics, removing duplicates.
68+-- Assumes all the diagnostics are for the same file.
69+mergeDiagnostics :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
70+mergeDiagnostics aa [] = aa
71+mergeDiagnostics [] bb = bb
72+mergeDiagnostics (a@(_,_,ad@Diagnostic{_range = ar}):aa) (b@(_,_,bd@Diagnostic{_range=br}):bb)
73+ | ar < br
74+ = a : mergeDiagnostics aa (b:bb)
75+ | br < ar
76+ = b : mergeDiagnostics (a:aa) bb
77+ | _severity ad == _severity bd
78+ && _source ad == _source bd
79+ && _message ad == _message bd
80+ && _code ad == _code bd
81+ && _relatedInformation ad == _relatedInformation bd
82+ && _tags ad == _tags bd
83+ = a : mergeDiagnostics aa bb
84+ | otherwise
85+ = a : b : mergeDiagnostics aa bb
63
86
64-- | Convert a GHC SrcSpan to a DAML compiler Range
87-- | Convert a GHC SrcSpan to a DAML compiler Range
65srcSpanToRange :: SrcSpan -> Range
88srcSpanToRange :: SrcSpan -> Range
@@ -80,7 +103,7 @@ srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real
80srcSpanToLocation :: SrcSpan -> Location
103srcSpanToLocation :: SrcSpan -> Location
81srcSpanToLocation src =
104srcSpanToLocation src =
82 -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code
105 -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code
83− Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath $ srcSpanToFilename src) (srcSpanToRange src)
106+ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ srcSpanToFilename src) (srcSpanToRange src)
84
107
85isInsideSrcSpan :: Position -> SrcSpan -> Bool
108isInsideSrcSpan :: Position -> SrcSpan -> Bool
86p `isInsideSrcSpan` r = sp <= p && p <= ep
109p `isInsideSrcSpan` r = sp <= p && p <= ep
@@ -127,7 +150,7 @@ realSpan = \case
127
150
128-- | Run something in a Ghc monad and catch the errors (SourceErrors and
151-- | Run something in a Ghc monad and catch the errors (SourceErrors and
129-- compiler-internal exceptions like Panic or InstallationError).
152-- compiler-internal exceptions like Panic or InstallationError).
130−catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)
153+catchSrcErrors :: (HasDynFlags m, ExceptionMonad m) => T.Text -> m a -> m (Either [FileDiagnostic] a)
131catchSrcErrors fromWhere ghcM = do
154catchSrcErrors fromWhere ghcM = do
132 dflags <- getDynFlags
155 dflags <- getDynFlags
133 handleGhcException (ghcExceptionToDiagnostics dflags) $
156 handleGhcException (ghcExceptionToDiagnostics dflags) $
src/Development/IDE/GHC/Orphans.hs+10−3
@@ -1,8 +1,10 @@
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
2-- SPDX-License-Identifier: Apache-2.0
3
3
4+{-# LANGUAGE CPP #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
5{-# OPTIONS_GHC -Wno-orphans #-}
6{-# OPTIONS_GHC -Wno-orphans #-}
7+#include "ghc-api-version.h"
6
8
7-- | Orphan instances for GHC.
9-- | Orphan instances for GHC.
8-- Note that the 'NFData' instances may not be law abiding.
10-- Note that the 'NFData' instances may not be law abiding.
@@ -31,7 +33,7 @@ instance NFData Linkable where rnf = rwhnf
31instance Show InstalledUnitId where
33instance Show InstalledUnitId where
32 show = installedUnitIdString
34 show = installedUnitIdString
33
35
34−instance NFData InstalledUnitId where rnf = rwhnf
36+instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS
35
37
36instance NFData SB.StringBuffer where rnf = rwhnf
38instance NFData SB.StringBuffer where rnf = rwhnf
37
39
@@ -40,8 +42,8 @@ instance Show Module where
40
42
41instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint
43instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint
42
44
43−instance NFData (GenLocated SrcSpan ModuleName) where
45+instance (NFData l, NFData e) => NFData (GenLocated l e) where
44− rnf = rwhnf
46+ rnf (L l e) = rnf l `seq` rnf e
45
47
46instance Show ModSummary where
48instance Show ModSummary where
47 show = show . ms_mod
49 show = show . ms_mod
@@ -52,6 +54,11 @@ instance Show ParsedModule where
52instance NFData ModSummary where
54instance NFData ModSummary where
53 rnf = rwhnf
55 rnf = rwhnf
54
56
57+#if !MIN_GHC_API_VERSION(8,10,0)
58+instance NFData FastString where
59+ rnf = rwhnf
60+#endif
61+
55instance NFData ParsedModule where
62instance NFData ParsedModule where
56 rnf = rwhnf
63 rnf = rwhnf
57
64
src/Development/IDE/GHC/Util.hs+68−20
@@ -4,21 +4,24 @@
4-- | General utility functions, mostly focused around GHC operations.
4-- | General utility functions, mostly focused around GHC operations.
5module Development.IDE.GHC.Util(
5module Development.IDE.GHC.Util(
6 -- * HcsEnv and environment
6 -- * HcsEnv and environment
7− HscEnvEq, hscEnv, newHscEnvEq,
7+ HscEnvEq(GhcVersionMismatch, compileTime, runTime), hscEnv, newHscEnvEq,
8 modifyDynFlags,
8 modifyDynFlags,
9+ evalGhcEnv,
9 runGhcEnv,
10 runGhcEnv,
11+ deps,
10 -- * GHC wrappers
12 -- * GHC wrappers
11 prettyPrint,
13 prettyPrint,
12 printRdrName,
14 printRdrName,
13 printName,
15 printName,
14 ParseResult(..), runParser,
16 ParseResult(..), runParser,
15 lookupPackageConfig,
17 lookupPackageConfig,
18+ textToStringBuffer,
19+ stringBufferToByteString,
16 moduleImportPath,
20 moduleImportPath,
17 cgGutsToCoreModule,
21 cgGutsToCoreModule,
18 fingerprintToBS,
22 fingerprintToBS,
19 fingerprintFromStringBuffer,
23 fingerprintFromStringBuffer,
20 -- * General utilities
24 -- * General utilities
21− textToStringBuffer,
22 readFileUtf8,
25 readFileUtf8,
23 hDuplicateTo',
26 hDuplicateTo',
24 setDefaultHieDir,
27 setDefaultHieDir,
@@ -27,14 +30,15 @@ module Development.IDE.GHC.Util(
27
30
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
32import qualified Data.ByteString.Internal as BS
36import qualified Data.ByteString.Internal as BS
33import Fingerprint
37import Fingerprint
34import GhcMonad
38import GhcMonad
35−import GhcPlugins hiding (Unique)
36−import Data.IORef
37import Control.Exception
39import Control.Exception
40+import Data.IORef
41+import Data.Version (showVersion, Version)
38import FileCleanup
42import FileCleanup
39import Foreign.Ptr
43import Foreign.Ptr
40import Foreign.ForeignPtr
44import Foreign.ForeignPtr
@@ -54,6 +58,16 @@ import qualified Data.ByteString as BS
54import Lexer
58import Lexer
55import StringBuffer
59import StringBuffer
56import 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)
57
71
58import Development.IDE.GHC.Compat as GHC
72import Development.IDE.GHC.Compat as GHC
59import Development.IDE.Types.Location
73import Development.IDE.Types.Location
@@ -96,6 +110,9 @@ runParser flags str parser = unP parser parseState
96 buffer = stringToStringBuffer str
110 buffer = stringToStringBuffer str
97 parseState = mkPState flags buffer location
111 parseState = mkPState flags buffer location
98
112
113+stringBufferToByteString :: StringBuffer -> ByteString
114+stringBufferToByteString StringBuffer{..} = PS buf cur len
115+
99-- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.
116-- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.
100prettyPrint :: Outputable a => a -> String
117prettyPrint :: Outputable a => a -> String
101prettyPrint = showSDoc unsafeGlobalDynFlags . ppr
118prettyPrint = showSDoc unsafeGlobalDynFlags . ppr
@@ -112,59 +129,90 @@ printName = printRdrName . nameRdrName
112
129
113-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required
130-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required
114-- pieces, but designed to be more efficient than a standard 'runGhc'.
131-- pieces, but designed to be more efficient than a standard 'runGhc'.
132+evalGhcEnv :: HscEnv -> Ghc b -> IO b
133+evalGhcEnv env act = snd <$> runGhcEnv env act
134+
135+-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required
136+-- pieces, but designed to be more efficient than a standard 'runGhc'.
115−runGhcEnv :: HscEnv -> Ghc a -> IO a
137+runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a)
116runGhcEnv env act = do
138runGhcEnv env act = do
117 filesToClean <- newIORef emptyFilesToClean
139 filesToClean <- newIORef emptyFilesToClean
118 dirsToClean <- newIORef mempty
140 dirsToClean <- newIORef mempty
119 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}
141 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}
120 ref <- newIORef env{hsc_dflags=dflags}
142 ref <- newIORef env{hsc_dflags=dflags}
121− unGhc act (Session ref) `finally` do
143+ res <- unGhc act (Session ref) `finally` do
122 cleanTempFiles dflags
144 cleanTempFiles dflags
123 cleanTempDirs dflags
145 cleanTempDirs dflags
146+ (,res) <$> readIORef ref
124
147
125-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.
148-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.
126-- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory
149-- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory
127-- @\/usr\/Test@ should be on the include path to find sibling modules.
150-- @\/usr\/Test@ should be on the include path to find sibling modules.
128−moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath
151+moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath
129-- 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
130-- the file name matches the module name in the last component.
153-- the file name matches the module name in the last component.
131-- Once that has changed we can get rid of this.
154-- Once that has changed we can get rid of this.
132−moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm
155+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn
133 -- This happens for single-component modules since takeDirectory "A" == "."
156 -- This happens for single-component modules since takeDirectory "A" == "."
134 | modDir == "." = Just pathDir
157 | modDir == "." = Just pathDir
135 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir
158 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir
136 where
159 where
137− ms = GHC.pm_mod_summary pm
138− mod' = GHC.ms_mod ms
139 -- A for module A.B
160 -- A for module A.B
140 modDir =
161 modDir =
141 takeDirectory $
162 takeDirectory $
142− fromNormalizedFilePath $ toNormalizedFilePath $
163+ fromNormalizedFilePath $ toNormalizedFilePath' $
143− moduleNameSlashes $ GHC.moduleName mod'
164+ moduleNameSlashes mn
144
165
145-- | An 'HscEnv' with equality. Two values are considered equal
166-- | An 'HscEnv' with equality. Two values are considered equal
146-- if they are created with the same call to 'newHscEnvEq'.
167-- if they are created with the same call to 'newHscEnvEq'.
168+data HscEnvEq
147−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+ }
148
176
149-- | Unwrap an 'HsEnvEq'.
177-- | Unwrap an 'HsEnvEq'.
150hscEnv :: HscEnvEq -> HscEnv
178hscEnv :: HscEnvEq -> HscEnv
179+hscEnv = either error id . hscEnv'
180+
181+hscEnv' :: HscEnvEq -> Either String HscEnv
151−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{} = []
152
195
153-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
196-- | Wrap an 'HscEnv' into an 'HscEnvEq'.
154−newHscEnvEq :: HscEnv -> IO HscEnvEq
197+newHscEnvEq :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
155−newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e
198+newHscEnvEq e uids = do u <- newUnique; return $ HscEnvEq u e uids
156
199
157instance Show HscEnvEq where
200instance Show HscEnvEq where
158− show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)
201+ show (HscEnvEq a _ _) = "HscEnvEq " ++ show (hashUnique a)
202+ show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)
159
203
160instance Eq HscEnvEq where
204instance Eq HscEnvEq where
161− 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
162
208
163instance NFData HscEnvEq where
209instance NFData HscEnvEq where
164− 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
165
212
166instance Hashable HscEnvEq where
213instance Hashable HscEnvEq where
167− hashWithSalt salt (HscEnvEq u _) = hashWithSalt salt u
214+ hashWithSalt s (HscEnvEq a _b _c) = hashWithSalt s a
215+ hashWithSalt salt GhcVersionMismatch{..} = hashWithSalt salt (compileTime, runTime)
168
216
169-- Fake instance needed to persuade Shake to accept this type as a key.
217-- Fake instance needed to persuade Shake to accept this type as a key.
170-- No harm done as ghcide never persists these keys currently
218-- No harm done as ghcide never persists these keys currently
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+55−18
@@ -14,18 +14,23 @@ module Development.IDE.Import.DependencyInformation
14 , PathIdMap
14 , PathIdMap
15 , emptyPathIdMap
15 , emptyPathIdMap
16 , getPathId
16 , getPathId
17+ , lookupPathToId
17 , insertImport
18 , insertImport
18 , pathToId
19 , pathToId
19 , idToPath
20 , idToPath
20 , reachableModules
21 , reachableModules
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
@@ -41,7 +46,6 @@ import qualified Data.IntSet as IntSet
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
@@ -58,17 +62,22 @@ data ModuleImports = ModuleImports
58 -- that module on disk (if we found it)
62 -- that module on disk (if we found it)
59 , packageImports :: !(Set InstalledUnitId)
63 , packageImports :: !(Set InstalledUnitId)
60 -- ^ Transitive package dependencies unioned for all imports.
64 -- ^ Transitive package dependencies unioned for all imports.
61− }
65+ } deriving Show
62
66
63−-- | For processing dependency information, we need lots of maps and sets
67+-- | For processing dependency information, we need lots of maps and sets of
64−-- 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
65−-- instead and only convert at the edges
69+-- instead and only convert at the edges.
66−-- and
67newtype FilePathId = FilePathId { getFilePathId :: Int }
70newtype FilePathId = FilePathId { getFilePathId :: Int }
68 deriving (Show, NFData, Eq, Ord)
71 deriving (Show, NFData, Eq, Ord)
69
72
73+-- | Map from 'FilePathId'
74+type FilePathIdMap = IntMap
75+
76+-- | Set of 'FilePathId's
77+type FilePathIdSet = IntSet
78+
70data PathIdMap = PathIdMap
79data PathIdMap = PathIdMap
71− { idToPathMap :: !(IntMap ArtifactsLocation)
80+ { idToPathMap :: !(FilePathIdMap ArtifactsLocation)
72 , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)
81 , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)
73 }
82 }
74 deriving (Show, Generic)
83 deriving (Show, Generic)
@@ -96,34 +105,49 @@ insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.inse
96pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId
105pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId
97pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path
106pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path
98
107
108+lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId
109+lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap
110+
99idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath
111idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath
100idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId
112idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId
101
113
102idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation
114idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation
103idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id
115idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id
104
116
117+type BootIdMap = FilePathIdMap FilePathId
118+
119+insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap
120+insertBootId k = IntMap.insert (getFilePathId k)
105
121
106-- | Unprocessed results that we find by following imports recursively.
122-- | Unprocessed results that we find by following imports recursively.
107data RawDependencyInformation = RawDependencyInformation
123data RawDependencyInformation = RawDependencyInformation
108− { rawImports :: !(IntMap (Either ModuleParseError ModuleImports))
124+ { rawImports :: !(FilePathIdMap (Either ModuleParseError ModuleImports))
109 , rawPathIdMap :: !PathIdMap
125 , rawPathIdMap :: !PathIdMap
110− }
126+ -- The rawBootMap maps the FilePathId of a hs-boot file to its
111−
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+
112−pkgDependencies :: RawDependencyInformation -> IntMap (Set InstalledUnitId)
133+pkgDependencies :: RawDependencyInformation -> FilePathIdMap (Set InstalledUnitId)
113pkgDependencies RawDependencyInformation{..} =
134pkgDependencies RawDependencyInformation{..} =
114 IntMap.map (either (const Set.empty) packageImports) rawImports
135 IntMap.map (either (const Set.empty) packageImports) rawImports
115
136
116data DependencyInformation =
137data DependencyInformation =
117 DependencyInformation
138 DependencyInformation
118− { depErrorNodes :: !(IntMap (NonEmpty NodeError))
139+ { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError))
119 -- ^ Nodes that cannot be processed correctly.
140 -- ^ Nodes that cannot be processed correctly.
120− , depModuleNames :: !(IntMap ShowableModuleName)
141+ , depModuleNames :: !(FilePathIdMap ShowableModuleName)
121− , depModuleDeps :: !(IntMap IntSet)
142+ , depModuleDeps :: !(FilePathIdMap FilePathIdSet)
122 -- ^ 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
123 -- in the same package.
144 -- in the same package.
124− , depPkgDeps :: !(IntMap (Set InstalledUnitId))
145+ , depPkgDeps :: !(FilePathIdMap (Set InstalledUnitId))
125 -- ^ 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.
126 , 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
127 } deriving (Show, Generic)
151 } deriving (Show, Generic)
128
152
129newtype ShowableModuleName =
153newtype ShowableModuleName =
@@ -201,6 +225,7 @@ processDependencyInformation rawDepInfo@RawDependencyInformation{..} =
201 , depModuleNames = IntMap.fromList $ coerce moduleNames
225 , depModuleNames = IntMap.fromList $ coerce moduleNames
202 , depPkgDeps = pkgDependencies rawDepInfo
226 , depPkgDeps = pkgDependencies rawDepInfo
203 , depPathIdMap = rawPathIdMap
227 , depPathIdMap = rawPathIdMap
228+ , depBootMap = rawBootMap
204 }
229 }
205 where resultGraph = buildResultGraph rawImports
230 where resultGraph = buildResultGraph rawImports
206 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph
231 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph
@@ -222,7 +247,7 @@ processDependencyInformation rawDepInfo@RawDependencyInformation{..} =
222-- 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.
223-- 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.
224-- 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.
225−buildResultGraph :: IntMap (Either ModuleParseError ModuleImports) -> IntMap NodeResult
250+buildResultGraph :: FilePathIdMap (Either ModuleParseError ModuleImports) -> FilePathIdMap NodeResult
226buildResultGraph g = propagatedErrors
251buildResultGraph g = propagatedErrors
227 where
252 where
228 sccs = stronglyConnComp (graphEdges g)
253 sccs = stronglyConnComp (graphEdges g)
@@ -269,7 +294,7 @@ buildResultGraph g = propagatedErrors
269 Right ModuleImports{moduleImports} ->
294 Right ModuleImports{moduleImports} ->
270 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports
295 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports
271
296
272−graphEdges :: IntMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]
297+graphEdges :: FilePathIdMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]
273graphEdges g =
298graphEdges g =
274 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
275 where deps :: Either e ModuleImports -> [FilePathId]
300 where deps :: Either e ModuleImports -> [FilePathId]
@@ -281,10 +306,12 @@ partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest
281partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest
306partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest
282partitionSCC [] = ([], [])
307partitionSCC [] = ([], [])
283
308
309+
284transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
310transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
285transitiveDeps DependencyInformation{..} file = do
311transitiveDeps DependencyInformation{..} file = do
286 let !fileId = pathToId depPathIdMap file
312 let !fileId = pathToId depPathIdMap file
287 reachableVs <-
313 reachableVs <-
314+ -- Delete the starting node
288 IntSet.delete (getFilePathId fileId) .
315 IntSet.delete (getFilePathId fileId) .
289 IntSet.fromList . map (fst3 . fromVertex) .
316 IntSet.fromList . map (fst3 . fromVertex) .
290 reachable g <$> toVertex (getFilePathId fileId)
317 reachable g <$> toVertex (getFilePathId fileId)
@@ -303,11 +330,21 @@ transitiveDeps DependencyInformation{..} file = do
303 ]
330 ]
304 pure TransitiveDependencies {..}
331 pure TransitiveDependencies {..}
305 where
332 where
333+ (g, fromVertex, toVertex) = graphFromEdges edges
306− (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+
307 vs = topSort g
342 vs = topSort g
308
343
309data TransitiveDependencies = TransitiveDependencies
344data TransitiveDependencies = TransitiveDependencies
310 { transitiveModuleDeps :: [NormalizedFilePath]
345 { transitiveModuleDeps :: [NormalizedFilePath]
346+ -- ^ Transitive module dependencies in topological order.
347+ -- The module itself is not included.
311 , transitiveNamedModuleDeps :: [NamedModuleDep]
348 , transitiveNamedModuleDeps :: [NamedModuleDep]
312 -- ^ Transitive module dependencies in topological order.
349 -- ^ Transitive module dependencies in topological order.
313 -- The module itself is not included.
350 -- The module itself is not included.
src/Development/IDE/Import/FindImports.hs+49−18
@@ -8,16 +8,18 @@ module Development.IDE.Import.FindImports
8 ( locateModule
8 ( locateModule
9 , Import(..)
9 , Import(..)
10 , ArtifactsLocation(..)
10 , ArtifactsLocation(..)
11+ , modSummaryToArtifactsLocation
12+ , isBootLocation
13+ , mkImportDirs
11 ) where
14 ) where
12
15
13import Development.IDE.GHC.Error as ErrUtils
16import Development.IDE.GHC.Error as ErrUtils
14import Development.IDE.GHC.Orphans()
17import Development.IDE.GHC.Orphans()
15import Development.IDE.Types.Diagnostics
18import Development.IDE.Types.Diagnostics
16import Development.IDE.Types.Location
19import Development.IDE.Types.Location
20+import Development.IDE.GHC.Compat
17-- GHC imports
21-- GHC imports
18−import DynFlags
19import FastString
22import FastString
20−import GHC
21import qualified Module as M
23import qualified Module as M
22import Packages
24import Packages
23import Outputable (showSDoc, ppr, pprPanic)
25import Outputable (showSDoc, ppr, pprPanic)
@@ -28,6 +30,8 @@ import Control.DeepSeq
28import Control.Monad.Extra
30import Control.Monad.Extra
29import Control.Monad.IO.Class
31import Control.Monad.IO.Class
30import System.FilePath
32import System.FilePath
33+import DriverPhases
34+import Data.Maybe
31
35
32data Import
36data Import
33 = FileImport !ArtifactsLocation
37 = FileImport !ArtifactsLocation
@@ -35,70 +39,97 @@ data Import
35 deriving (Show)
39 deriving (Show)
36
40
37data ArtifactsLocation = ArtifactsLocation
41data ArtifactsLocation = ArtifactsLocation
38− { artifactFilePath :: !NormalizedFilePath
42+ { artifactFilePath :: !NormalizedFilePath
39 , artifactModLocation :: !ModLocation
43 , artifactModLocation :: !ModLocation
44+ , artifactIsSource :: !Bool -- ^ True if a module is a source input
40 }
45 }
41 deriving (Show)
46 deriving (Show)
42
47
43instance NFData ArtifactsLocation where
48instance NFData ArtifactsLocation where
44− rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation
49+ rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource
50+
51+isBootLocation :: ArtifactsLocation -> Bool
52+isBootLocation = not . artifactIsSource
45
53
46instance NFData Import where
54instance NFData Import where
47 rnf (FileImport x) = rnf x
55 rnf (FileImport x) = rnf x
48 rnf (PackageImport x) = rnf x
56 rnf (PackageImport x) = rnf x
49
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+
50
64
51-- | 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
52locateModuleFile :: MonadIO m
66locateModuleFile :: MonadIO m
53− => DynFlags
67+ => [[FilePath]]
54 -> [String]
68 -> [String]
55 -> (NormalizedFilePath -> m Bool)
69 -> (NormalizedFilePath -> m Bool)
56 -> Bool
70 -> Bool
57 -> ModuleName
71 -> ModuleName
58 -> m (Maybe NormalizedFilePath)
72 -> m (Maybe NormalizedFilePath)
59−locateModuleFile dflags exts doesExist isSource modName = do
73+locateModuleFile import_dirss exts doesExist isSource modName = do
60− let candidates =
74+ let candidates import_dirs =
61− [ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)
75+ [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)
62− | prefix <- importPaths dflags, ext <- exts]
76+ | prefix <- import_dirs , ext <- exts]
63− findM doesExist candidates
77+ findM doesExist (concatMap candidates import_dirss)
64 where
78 where
65 maybeBoot ext
79 maybeBoot ext
66 | isSource = ext ++ "-boot"
80 | isSource = ext ++ "-boot"
67 | otherwise = ext
81 | otherwise = ext
68
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+
69-- | 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
70-- Haskell
91-- Haskell
71locateModule
92locateModule
72 :: MonadIO m
93 :: MonadIO m
73 => DynFlags
94 => DynFlags
95+ -> [(M.InstalledUnitId, DynFlags)] -- Sets import directories to look in
74 -> [String]
96 -> [String]
75 -> (NormalizedFilePath -> m Bool)
97 -> (NormalizedFilePath -> m Bool)
76 -> Located ModuleName
98 -> Located ModuleName
77 -> Maybe FastString
99 -> Maybe FastString
78 -> Bool
100 -> Bool
79 -> m (Either [FileDiagnostic] Import)
101 -> m (Either [FileDiagnostic] Import)
80−locateModule dflags exts doesExist modName mbPkgName isSource = do
102+locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do
81 case mbPkgName of
103 case mbPkgName of
82 -- "this" means that we should only look in the current package
104 -- "this" means that we should only look in the current package
83 Just "this" -> do
105 Just "this" -> do
84− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName
106+ lookupLocal [importPaths dflags]
85− case mbFile of
86− Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []
87− Just file -> toModLocation file
88 -- 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]
89− Just _pkgName -> lookupInPackageDB dflags
111+ | otherwise -> lookupInPackageDB dflags
90 Nothing -> do
112 Nothing -> do
91 -- 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
92 -- 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.
93− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName
118+ mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts doesExist isSource $ unLoc modName
94 case mbFile of
119 case mbFile of
95 Nothing -> lookupInPackageDB dflags
120 Nothing -> lookupInPackageDB dflags
96 Just file -> toModLocation file
121 Just file -> toModLocation file
97 where
122 where
123+ import_paths = mapMaybe (mkImportDirs dflags) comp_info
98 toModLocation file = liftIO $ do
124 toModLocation file = liftIO $ do
99 loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)
125 loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)
100− return $ Right $ FileImport $ ArtifactsLocation file loc
126+ return $ Right $ FileImport $ ArtifactsLocation file loc (not isSource)
101
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
102
133
103 lookupInPackageDB dfs =
134 lookupInPackageDB dfs =
104 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of
135 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of
src/Development/IDE/LSP/HoverDefinition.hs+4−1
@@ -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
@@ -52,7 +55,7 @@ request label getResults notFound found ide (TextDocumentPositionParams (TextDoc
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+11−13
@@ -144,15 +144,15 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
144 Response x@RequestMessage{_id, _params} wrap act ->
144 Response x@RequestMessage{_id, _params} wrap act ->
145 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
145 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
146 \case
146 \case
147− Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing (Just e)
147+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)
148− Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just r) Nothing
148+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)
149 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->
149 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->
150 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
150 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $
151 \(res, newReq) -> do
151 \(res, newReq) -> do
152− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing
152+ case res of
153− case newReq of
153+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)
154− Nothing -> return ()
154+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)
155− Just (rm, newReqParams) -> do
155+ whenJust newReq $ \(rm, newReqParams) -> do
156 reqId <- getNextReqId
156 reqId <- getNextReqId
157 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
158 InitialParams x@RequestMessage{_id, _params} act -> do
@@ -175,16 +175,16 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
175 Left () -> do
175 Left () -> do
176 logDebug (ideLogger ide) $ T.pack $
176 logDebug (ideLogger ide) $ T.pack $
177 "Cancelled request " <> show _id
177 "Cancelled request " <> show _id
178− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
178+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left
179− Just $ ResponseError RequestCancelled "" Nothing
179+ $ ResponseError RequestCancelled "" Nothing
180 Right res -> k res
180 Right res -> k res
181 ) $ \(e :: SomeException) -> do
181 ) $ \(e :: SomeException) -> do
182 logError (ideLogger ide) $ T.pack $
182 logError (ideLogger ide) $ T.pack $
183 "Unexpected exception on request, please report!\n" ++
183 "Unexpected exception on request, please report!\n" ++
184 "Message: " ++ show msg ++ "\n" ++
184 "Message: " ++ show msg ++ "\n" ++
185 "Exception: " ++ show e
185 "Exception: " ++ show e
186− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $
186+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left
187− Just $ ResponseError InternalError (T.pack $ show e) Nothing
187+ $ ResponseError InternalError (T.pack $ show e) Nothing
188
188
189initializeRequestHandler :: PartialHandlers config
189initializeRequestHandler :: PartialHandlers config
190initializeRequestHandler = PartialHandlers $ \WithMessage{..} x -> return x{
190initializeRequestHandler = PartialHandlers $ \WithMessage{..} x -> return x{
@@ -222,15 +222,13 @@ data Message c
222 -- | 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,
223 -- but also an additional request to the client.
223 -- but also an additional request to the client.
224 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
224 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.
225− | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (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)))
226 | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())
226 | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())
227 -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler.
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 ())
228 | InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
229
229
230modifyOptions :: LSP.Options -> LSP.Options
230modifyOptions :: LSP.Options -> LSP.Options
231modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS
231modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS
232− , LSP.executeCommandCommands = Just ["typesignature.add"]
233− , LSP.completionTriggerCharacters = Just "."
234 }
232 }
235 where
233 where
236 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+2−2
@@ -30,7 +30,7 @@ import Development.IDE.Core.OfInterest
30
30
31
31
32whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
32whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
33−whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath
33+whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'
34
34
35setHandlersNotifications :: PartialHandlers c
35setHandlersNotifications :: PartialHandlers c
36setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
36setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
@@ -62,7 +62,7 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
62 let events =
62 let events =
63 mapMaybe
63 mapMaybe
64 (\(FileEvent uri ev) ->
64 (\(FileEvent uri ev) ->
65− (, ev /= FcDeleted) . toNormalizedFilePath
65+ (, ev /= FcDeleted) . toNormalizedFilePath'
66 <$> LSP.uriToFilePath uri
66 <$> LSP.uriToFilePath uri
67 )
67 )
68 ( F.toList fileEvents )
68 ( F.toList fileEvents )
src/Development/IDE/LSP/Outline.hs+19−5
@@ -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
@@ -37,11 +39,11 @@ moduleOutline
37 :: LSP.LspFuncs c -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError 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 $ Right $ 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) ->
@@ -106,27 +108,39 @@ documentSymbolForDecl (L l (TyClD DataDecl { tcdLName = L _ name, tcdDataDefn =
106 { _name = showRdrName n
108 { _name = showRdrName n
107 , _kind = SkConstructor
109 , _kind = SkConstructor
108 , _selectionRange = srcSpanToRange l'
110 , _selectionRange = srcSpanToRange l'
111+ , _children = conArgRecordFields (getConArgs x)
109 }
112 }
110 | L l x <- dd_cons
113 | L l x <- dd_cons
111 , L l' n <- getConNames x
114 , L l' n <- getConNames x
112 ]
115 ]
113 }
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
114documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just
128documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just
115 (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n
129 (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n
116 , _kind = SkTypeParameter
130 , _kind = SkTypeParameter
117 , _selectionRange = srcSpanToRange l'
131 , _selectionRange = srcSpanToRange l'
118 }
132 }
119−documentSymbolForDecl (L l (InstD (ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })))
133+documentSymbolForDecl (L l (InstD ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))
120 = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty
134 = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty
121 , _kind = SkInterface
135 , _kind = SkInterface
122 }
136 }
123−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 } } }))
124 = Just (defDocumentSymbol l :: DocumentSymbol)
138 = Just (defDocumentSymbol l :: DocumentSymbol)
125 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords
139 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords
126 (map pprText feqn_pats)
140 (map pprText feqn_pats)
127 , _kind = SkInterface
141 , _kind = SkInterface
128 }
142 }
129−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 } } }))
130 = Just (defDocumentSymbol l :: DocumentSymbol)
144 = Just (defDocumentSymbol l :: DocumentSymbol)
131 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords
145 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords
132 (map pprText feqn_pats)
146 (map pprText feqn_pats)
src/Development/IDE/LSP/Server.hs+1−1
@@ -29,7 +29,7 @@ data WithMessage c = WithMessage
29 (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
29 (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>
30 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
30 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response
31 (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
32− (LSP.LspFuncs c -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work
32+ (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work
33 Maybe (LSP.Handler (RequestMessage m req resp))
33 Maybe (LSP.Handler (RequestMessage m req resp))
34 , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
34 , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())
35 -> Maybe (LSP.Handler InitializeRequest)
35 -> Maybe (LSP.Handler InitializeRequest)
src/Development/IDE/Plugin.hs+24−1
@@ -1,11 +1,13 @@
1
1
2−module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules) where
2+module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules,makeLspCommandId,getPid) where
3
3
4import Data.Default
4import Data.Default
5+import qualified Data.Text as T
5import Development.Shake
6import Development.Shake
6import Development.IDE.LSP.Server
7import Development.IDE.LSP.Server
7
8
8import Language.Haskell.LSP.Types
9import Language.Haskell.LSP.Types
10+import Development.IDE.Compat
9import Development.IDE.Core.Rules
11import Development.IDE.Core.Rules
10import qualified Language.Haskell.LSP.Core as LSP
12import qualified Language.Haskell.LSP.Core as LSP
11import Language.Haskell.LSP.Messages
13import Language.Haskell.LSP.Messages
@@ -35,3 +37,24 @@ codeActionPluginWithRules rr f = Plugin rr $ PartialHandlers $ \WithMessage{..}
35 }
37 }
36 where
38 where
37 g lsp state (CodeActionParams a b c _) = fmap List <$> f lsp state a b c
39 g lsp state (CodeActionParams a b c _) = fmap List <$> f lsp state a b c
40+
41+-- | Prefix to uniquely identify commands sent to the client. This
42+-- has two parts
43+--
44+-- - A representation of the process id to make sure that a client has
45+-- unique commands if it is running multiple servers, since some
46+-- clients have a global command table and get confused otherwise.
47+--
48+-- - A string to identify ghcide, to ease integration into
49+-- haskell-language-server, which routes commands to plugins based
50+-- on that.
51+makeLspCommandId :: T.Text -> IO T.Text
52+makeLspCommandId command = do
53+ pid <- getPid
54+ return $ pid <> ":ghcide:" <> command
55+
56+-- | Get the operating system process id for the running server
57+-- instance. This should be the same for the lifetime of the instance,
58+-- and different from that of any other currently running instance.
59+getPid :: IO T.Text
60+getPid = T.pack . show <$> getProcessID
src/Development/IDE/Plugin/CodeAction.hs+24−8
@@ -6,7 +6,16 @@
6#include "ghc-api-version.h"
6#include "ghc-api-version.h"
7
7
8-- | Go to the definition of a variable.
8-- | Go to the definition of a variable.
9−module Development.IDE.Plugin.CodeAction(plugin) where
9+module Development.IDE.Plugin.CodeAction
10+ (
11+ plugin
12+
13+ -- * For haskell-language-server
14+ , codeAction
15+ , codeLens
16+ , rulePackageExports
17+ , executeAddSignatureCommand
18+ ) where
10
19
11import Language.Haskell.LSP.Types
20import Language.Haskell.LSP.Types
12import Control.Monad (join)
21import Control.Monad (join)
@@ -64,7 +73,7 @@ codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diag
64 -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg
73 -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg
65 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
74 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
66 let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
75 let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
67− mbFile = toNormalizedFilePath <$> uriToFilePath uri
76+ mbFile = toNormalizedFilePath' <$> uriToFilePath uri
68 (ideOptions, parsedModule, join -> env) <- runAction state $
77 (ideOptions, parsedModule, join -> env) <- runAction state $
69 (,,) <$> getIdeOptions
78 (,,) <$> getIdeOptions
70 <*> getParsedModule `traverse` mbFile
79 <*> getParsedModule `traverse` mbFile
@@ -84,13 +93,14 @@ codeLens
84 -> CodeLensParams
93 -> CodeLensParams
85 -> IO (Either ResponseError (List CodeLens))
94 -> IO (Either ResponseError (List CodeLens))
86codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
95codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
96+ commandId <- makeLspCommandId "typesignature.add"
87 fmap (Right . List) $ case uriToFilePath' uri of
97 fmap (Right . List) $ case uriToFilePath' uri of
88− Just (toNormalizedFilePath -> filePath) -> do
98+ Just (toNormalizedFilePath' -> filePath) -> do
89 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
99 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
90 diag <- getDiagnostics ideState
100 diag <- getDiagnostics ideState
91 hDiag <- getHiddenDiagnostics ideState
101 hDiag <- getHiddenDiagnostics ideState
92 pure
102 pure
93− [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing
103+ [ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing
94 | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag
104 | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag
95 , dFile == filePath
105 , dFile == filePath
96 , (title, tedit) <- suggestSignature False dDiag
106 , (title, tedit) <- suggestSignature False dDiag
@@ -103,14 +113,18 @@ executeAddSignatureCommand
103 :: LSP.LspFuncs c
113 :: LSP.LspFuncs c
104 -> IdeState
114 -> IdeState
105 -> ExecuteCommandParams
115 -> ExecuteCommandParams
106− -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
116+ -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))
107executeAddSignatureCommand _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.
108− | _command == "typesignature.add"
122+ | T.isSuffixOf "typesignature.add" _command
109 , Just (List [edit]) <- _arguments
123 , Just (List [edit]) <- _arguments
110 , Success wedit <- fromJSON edit
124 , Success wedit <- fromJSON edit
111− = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
125+ = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))
112 | otherwise
126 | otherwise
113− = return (Null, Nothing)
127+ = return (Right Null, Nothing)
114
128
115suggestAction
129suggestAction
116 :: Maybe DynFlags
130 :: Maybe DynFlags
@@ -410,6 +424,8 @@ extractNotInScopeName x
410 = Just $ NotInScopeDataConstructor name
424 = Just $ NotInScopeDataConstructor name
411 | Just [name] <- matchRegex x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"
425 | Just [name] <- matchRegex x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"
412 = Just $ NotInScopeTypeConstructorOrClass name
426 = Just $ NotInScopeTypeConstructorOrClass name
427+ | Just [name] <- matchRegex x "ot in scope: \\(([^‘ ]+)\\)"
428+ = Just $ NotInScopeThing name
413 | Just [name] <- matchRegex x "ot in scope: ([^‘ ]+)"
429 | Just [name] <- matchRegex x "ot in scope: ([^‘ ]+)"
414 = Just $ NotInScopeThing name
430 = Just $ NotInScopeThing name
415 | Just [name] <- matchRegex x "ot in scope:[^‘]*‘([^’]*)’"
431 | Just [name] <- matchRegex x "ot in scope:[^‘]*‘([^’]*)’"
src/Development/IDE/Plugin/Completions.hs+26−11
@@ -1,7 +1,10 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE TypeFamilies #-}
3+#include "ghc-api-version.h"
2
4
3module Development.IDE.Plugin.Completions(plugin) where
5module Development.IDE.Plugin.Completions(plugin) where
4
6
7+import Control.Applicative
5import Language.Haskell.LSP.Messages
8import Language.Haskell.LSP.Messages
6import Language.Haskell.LSP.Types
9import Language.Haskell.LSP.Types
7import qualified Language.Haskell.LSP.Core as LSP
10import qualified Language.Haskell.LSP.Core as LSP
@@ -10,8 +13,6 @@ import Language.Haskell.LSP.Types.Capabilities
10import Development.Shake.Classes
13import Development.Shake.Classes
11import Development.Shake
14import Development.Shake
12import GHC.Generics
15import GHC.Generics
13−import Data.Maybe
14−import HscTypes
15
16
16import Development.IDE.Plugin
17import Development.IDE.Plugin
17import Development.IDE.Core.Service
18import Development.IDE.Core.Service
@@ -22,8 +23,11 @@ import Development.IDE.Core.RuleTypes
22import Development.IDE.Core.Shake
23import Development.IDE.Core.Shake
23import Development.IDE.GHC.Util
24import Development.IDE.GHC.Util
24import Development.IDE.LSP.Server
25import Development.IDE.LSP.Server
25−import Development.IDE.Import.DependencyInformation
26
26
27+#if !MIN_GHC_API_VERSION(8,6,0) || defined(GHC_LIB)
28+import Data.Maybe
29+import Development.IDE.Import.DependencyInformation
30+#endif
27
31
28plugin :: Plugin c
32plugin :: Plugin c
29plugin = Plugin produceCompletions setHandlersCompletion
33plugin = Plugin produceCompletions setHandlersCompletion
@@ -31,20 +35,27 @@ plugin = Plugin produceCompletions setHandlersCompletion
31produceCompletions :: Rules ()
35produceCompletions :: Rules ()
32produceCompletions =
36produceCompletions =
33 define $ \ProduceCompletions file -> do
37 define $ \ProduceCompletions file -> do
38+
39+-- When possible, rely on the haddocks embedded in our interface files
40+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'
41+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
42+ let parsedDeps = []
43+#else
34 deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
44 deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
35 parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)
45 parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)
46+#endif
36 tm <- fmap fst <$> useWithStale TypeCheck file
47 tm <- fmap fst <$> useWithStale TypeCheck file
37 packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file
48 packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file
38 case (tm, packageState) of
49 case (tm, packageState) of
39 (Just tm', Just packageState') -> do
50 (Just tm', Just packageState') -> do
40− cdata <- liftIO $ cacheDataProducer packageState' (hsc_dflags packageState')
51+ cdata <- liftIO $ cacheDataProducer packageState'
41 (tmrModule tm') parsedDeps
52 (tmrModule tm') parsedDeps
42− return ([], Just (cdata, tm'))
53+ return ([], Just cdata)
43 _ -> return ([], Nothing)
54 _ -> return ([], Nothing)
44
55
45
56
46-- | Produce completions info for a file
57-- | Produce completions info for a file
47−type instance RuleResult ProduceCompletions = (CachedCompletions, TcModuleResult)
58+type instance RuleResult ProduceCompletions = CachedCompletions
48
59
49data ProduceCompletions = ProduceCompletions
60data ProduceCompletions = ProduceCompletions
50 deriving (Eq, Show, Typeable, Generic)
61 deriving (Eq, Show, Typeable, Generic)
@@ -66,18 +77,22 @@ getCompletionsLSP lsp ide
66 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
77 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
67 fmap Right $ case (contents, uriToFilePath' uri) of
78 fmap Right $ case (contents, uriToFilePath' uri) of
68 (Just cnts, Just path) -> do
79 (Just cnts, Just path) -> do
69− let npath = toNormalizedFilePath path
80+ let npath = toNormalizedFilePath' path
81+ (ideOpts, compls) <- runAction ide $ do
82+ opts <- getIdeOptions
70− (ideOpts, compls) <- runAction ide ((,) <$> getIdeOptions <*> useWithStale ProduceCompletions npath)
83+ compls <- useWithStale ProduceCompletions npath
84+ pm <- useWithStale GetParsedModule npath
85+ pure (opts, liftA2 (,) compls pm)
71 case compls of
86 case compls of
72− Just ((cci', tm'), mapping) -> do
87+ Just ((cci', _), (pm, mapping)) -> do
73− let position' = fromCurrentPosition mapping position
88+ let !position' = fromCurrentPosition mapping position
74 pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'
89 pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'
75 case (pfix, completionContext) of
90 case (pfix, completionContext) of
76 (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
91 (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
77 -> return (Completions $ List [])
92 -> return (Completions $ List [])
78 (Just pfix', _) -> do
93 (Just pfix', _) -> do
79 let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing
94 let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing
80− Completions . List <$> getCompletions ideOpts cci' (tmrModule tm') pfix' fakeClientCapabilities (WithSnippets True)
95+ Completions . List <$> getCompletions ideOpts cci' pm pfix' fakeClientCapabilities (WithSnippets True)
81 _ -> return (Completions $ List [])
96 _ -> return (Completions $ List [])
82 _ -> return (Completions $ List [])
97 _ -> return (Completions $ List [])
83 _ -> return (Completions $ List [])
98 _ -> return (Completions $ List [])
src/Development/IDE/Plugin/Completions/Logic.hs+23−43
@@ -11,7 +11,7 @@ module Development.IDE.Plugin.Completions.Logic (
11import Control.Applicative
11import Control.Applicative
12import Data.Char (isSpace, isUpper)
12import Data.Char (isSpace, isUpper)
13import Data.Generics
13import Data.Generics
14−import Data.List as List hiding (stripPrefix)
14+import Data.List.Extra as List hiding (stripPrefix)
15import qualified Data.Map as Map
15import qualified Data.Map as Map
16import Data.Maybe (fromMaybe, mapMaybe)
16import Data.Maybe (fromMaybe, mapMaybe)
17import qualified Data.Text as T
17import qualified Data.Text as T
@@ -132,7 +132,7 @@ occNameToComKind ty oc
132
132
133mkCompl :: IdeOptions -> CompItem -> CompletionItem
133mkCompl :: IdeOptions -> CompItem -> CompletionItem
134mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} =
134mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} =
135− CompletionItem label kind ((colon <>) <$> typeText)
135+ CompletionItem label kind (List []) ((colon <>) <$> typeText)
136 (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')
136 (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')
137 Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
137 Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
138 Nothing Nothing Nothing Nothing Nothing
138 Nothing Nothing Nothing Nothing Nothing
@@ -162,7 +162,7 @@ getArgText typ = argText
162 where
162 where
163 argTypes = getArgs typ
163 argTypes = getArgs typ
164 argText :: T.Text
164 argText :: T.Text
165− argText = mconcat $ List.intersperse " " $ zipWith snippet [1..] argTypes
165+ argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes
166 snippet :: Int -> Type -> T.Text
166 snippet :: Int -> Type -> T.Text
167 snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"
167 snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"
168 getArgs :: Type -> [Type]
168 getArgs :: Type -> [Type]
@@ -186,13 +186,13 @@ getArgText typ = argText
186
186
187mkModCompl :: T.Text -> CompletionItem
187mkModCompl :: T.Text -> CompletionItem
188mkModCompl label =
188mkModCompl label =
189− CompletionItem label (Just CiModule) Nothing
189+ CompletionItem label (Just CiModule) (List []) Nothing
190 Nothing Nothing Nothing Nothing Nothing Nothing Nothing
190 Nothing Nothing Nothing Nothing Nothing Nothing Nothing
191 Nothing Nothing Nothing Nothing Nothing
191 Nothing Nothing Nothing Nothing Nothing
192
192
193mkImportCompl :: T.Text -> T.Text -> CompletionItem
193mkImportCompl :: T.Text -> T.Text -> CompletionItem
194mkImportCompl enteredQual label =
194mkImportCompl enteredQual label =
195− CompletionItem m (Just CiModule) (Just label)
195+ CompletionItem m (Just CiModule) (List []) (Just label)
196 Nothing Nothing Nothing Nothing Nothing Nothing Nothing
196 Nothing Nothing Nothing Nothing Nothing Nothing Nothing
197 Nothing Nothing Nothing Nothing Nothing
197 Nothing Nothing Nothing Nothing Nothing
198 where
198 where
@@ -200,19 +200,20 @@ mkImportCompl enteredQual label =
200
200
201mkExtCompl :: T.Text -> CompletionItem
201mkExtCompl :: T.Text -> CompletionItem
202mkExtCompl label =
202mkExtCompl label =
203− CompletionItem label (Just CiKeyword) Nothing
203+ CompletionItem label (Just CiKeyword) (List []) Nothing
204 Nothing Nothing Nothing Nothing Nothing Nothing Nothing
204 Nothing Nothing Nothing Nothing Nothing Nothing Nothing
205 Nothing Nothing Nothing Nothing Nothing
205 Nothing Nothing Nothing Nothing Nothing
206
206
207mkPragmaCompl :: T.Text -> T.Text -> CompletionItem
207mkPragmaCompl :: T.Text -> T.Text -> CompletionItem
208mkPragmaCompl label insertText =
208mkPragmaCompl label insertText =
209− CompletionItem label (Just CiKeyword) Nothing
209+ CompletionItem label (Just CiKeyword) (List []) Nothing
210 Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
210 Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)
211 Nothing Nothing Nothing Nothing Nothing
211 Nothing Nothing Nothing Nothing Nothing
212
212
213−cacheDataProducer :: HscEnv -> DynFlags -> TypecheckedModule -> [ParsedModule] -> IO CachedCompletions
213+cacheDataProducer :: HscEnv -> TypecheckedModule -> [ParsedModule] -> IO CachedCompletions
214−cacheDataProducer packageState dflags tm deps = do
214+cacheDataProducer packageState tm deps = do
215 let parsedMod = tm_parsed_module tm
215 let parsedMod = tm_parsed_module tm
216+ dflags = hsc_dflags packageState
216 curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod
217 curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod
217 Just (_,limports,_,_) = tm_renamed_source tm
218 Just (_,limports,_,_) = tm_renamed_source tm
218
219
@@ -269,18 +270,18 @@ cacheDataProducer packageState dflags tm deps = do
269 let typ = Just $ varType var
270 let typ = Just $ varType var
270 name = Var.varName var
271 name = Var.varName var
271 label = T.pack $ showGhc name
272 label = T.pack $ showGhc name
272− docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) name
273+ docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) name
273 return $ CI name (showModName curMod) typ label Nothing docs
274 return $ CI name (showModName curMod) typ label Nothing docs
274
275
275 toCompItem :: ModuleName -> Name -> IO CompItem
276 toCompItem :: ModuleName -> Name -> IO CompItem
276 toCompItem mn n = do
277 toCompItem mn n = do
277− docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) n
278+ docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) n
278-- 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
279-- 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".
280#ifdef GHC_LIB
281#ifdef GHC_LIB
281 let ty = Right Nothing
282 let ty = Right Nothing
282#else
283#else
283− ty <- runGhcEnv packageState $ catchSrcErrors "completion" $ do
284+ ty <- evalGhcEnv packageState $ catchSrcErrors "completion" $ do
284 name' <- lookupName n
285 name' <- lookupName n
285 return $ name' >>= safeTyThingType
286 return $ name' >>= safeTyThingType
286#endif
287#endif
@@ -306,16 +307,13 @@ toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x
306 where supported = Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)
307 where supported = Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)
307
308
308-- | Returns the cached completions for the given module and position.
309-- | Returns the cached completions for the given module and position.
309−getCompletions :: IdeOptions -> CachedCompletions -> TypecheckedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]
310+getCompletions :: IdeOptions -> CachedCompletions -> ParsedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]
310getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }
311getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }
311− tm prefixInfo caps withSnippets = do
312+ pm prefixInfo caps withSnippets = do
312 let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo
313 let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo
313 enteredQual = if T.null prefixModule then "" else prefixModule <> "."
314 enteredQual = if T.null prefixModule then "" else prefixModule <> "."
314 fullPrefix = enteredQual <> prefixText
315 fullPrefix = enteredQual <> prefixText
315
316
316− -- default to value context if no explicit context
317− context = fromMaybe ValueContext $ getCContext pos (tm_parsed_module tm)
318−
319 {- correct the position by moving 'foo :: Int -> String -> '
317 {- correct the position by moving 'foo :: Int -> String -> '
320 ^
318 ^
321 to 'foo :: Int -> String -> '
319 to 'foo :: Int -> String -> '
@@ -344,10 +342,11 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl
344 where
342 where
345 isTypeCompl = isTcOcc . occName . origName
343 isTypeCompl = isTcOcc . occName . origName
346 -- completions specific to the current context
344 -- completions specific to the current context
347− ctxCompls' = case context of
345+ ctxCompls' = case getCContext pos pm of
346+ Nothing -> compls
348− TypeContext -> filter isTypeCompl compls
347+ Just TypeContext -> filter isTypeCompl compls
349− ValueContext -> filter (not . isTypeCompl) compls
348+ Just ValueContext -> filter (not . isTypeCompl) compls
350− _ -> filter (not . isTypeCompl) compls
349+ Just _ -> filter (not . isTypeCompl) compls
351 -- Add whether the text to insert has backticks
350 -- Add whether the text to insert has backticks
352 ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'
351 ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'
353
352
@@ -373,7 +372,9 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl
373 filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
372 filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
374 filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas
373 filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas
375 filtOptsCompls = filtListWith mkExtCompl
374 filtOptsCompls = filtListWith mkExtCompl
375+ filtKeywordCompls
376− filtKeywordCompls = if T.null prefixModule then filtListWith mkExtCompl keywords else []
376+ | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)
377+ | otherwise = []
377
378
378 stripLeading :: Char -> String -> String
379 stripLeading :: Char -> String -> String
379 stripLeading _ [] = []
380 stripLeading _ [] = []
@@ -527,24 +528,3 @@ prefixes =
527 , "$c"
528 , "$c"
528 , "$m"
529 , "$m"
529 ]
530 ]
530−
531−keywords :: [T.Text]
532−keywords =
533− [
534− -- From https://wiki.haskell.org/Keywords
535− "as"
536− , "case", "of"
537− , "class", "instance", "type"
538− , "data", "family", "newtype"
539− , "default"
540− , "deriving"
541− , "do", "mdo", "proc", "rec"
542− , "forall"
543− , "foreign"
544− , "hiding"
545− , "if", "then", "else"
546− , "import", "qualified", "hiding"
547− , "infix", "infixl", "infixr"
548− , "let", "in", "where"
549− , "module"
550− ]
src/Development/IDE/Spans/AtPoint.hs+5−6
@@ -19,7 +19,6 @@ import Development.IDE.Spans.Type as SpanInfo
19import Development.IDE.Spans.Common (spanDocToMarkdown)
19import Development.IDE.Spans.Common (spanDocToMarkdown)
20
20
21-- GHC API imports
21-- GHC API imports
22−import Avail
23import DynFlags
22import DynFlags
24import FastString
23import FastString
25import Name
24import Name
@@ -84,7 +83,7 @@ atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do
84 constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts
83 constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts
85 constraintsT = T.intercalate ", " (map showName constraintsOverFVs)
84 constraintsT = T.intercalate ", " (map showName constraintsOverFVs)
86
85
87− typeAnnotation = case constraintsOverFVs of
86+ typeAnnotation = case constraintsOverFVs of
88 [] -> colon <> showName typ
87 [] -> colon <> showName typ
89 [_] -> colon <> constraintsT <> "\n=> " <> showName typ
88 [_] -> colon <> constraintsT <> "\n=> " <> showName typ
90 _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ
89 _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ
@@ -124,7 +123,7 @@ locationsAtPoint
124 -> Position
123 -> Position
125 -> [SpanInfo]
124 -> [SpanInfo]
126 -> m [Location]
125 -> m [Location]
127−locationsAtPoint getHieFile IdeOptions{..} pos =
126+locationsAtPoint getHieFile _ideOptions pos =
128 fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos
127 fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos
129 where getSpan :: SpanSource -> m (Maybe SrcSpan)
128 where getSpan :: SpanSource -> m (Maybe SrcSpan)
130 getSpan NoSource = pure Nothing
129 getSpan NoSource = pure Nothing
@@ -134,16 +133,16 @@ locationsAtPoint getHieFile IdeOptions{..} pos =
134 sp@(RealSrcSpan _) -> pure $ Just sp
133 sp@(RealSrcSpan _) -> pure $ Just sp
135 sp@(UnhelpfulSpan _) -> runMaybeT $ do
134 sp@(UnhelpfulSpan _) -> runMaybeT $ do
136 guard (sp /= wiredInSrcSpan)
135 guard (sp /= wiredInSrcSpan)
137− -- 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).
138 -- In this case the interface files contain garbage source spans
137 -- In this case the interface files contain garbage source spans
139 -- 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.
140 mod <- MaybeT $ return $ nameModule_maybe name
139 mod <- MaybeT $ return $ nameModule_maybe name
141 (hieFile, srcPath) <- MaybeT $ getHieFile mod
140 (hieFile, srcPath) <- MaybeT $ getHieFile mod
142− avail <- MaybeT $ pure $ listToMaybe (filterAvails (eqName name) $ hie_exports hieFile)
141+ avail <- MaybeT $ pure $ find (eqName name . snd) $ hieExportNames hieFile
143 -- The location will point to the source file used during compilation.
142 -- The location will point to the source file used during compilation.
144 -- This file might no longer exists and even if it does the path will be relative
143 -- This file might no longer exists and even if it does the path will be relative
145 -- to the compilation directory which we don’t know.
144 -- to the compilation directory which we don’t know.
146− let span = setFileName srcPath $ nameSrcSpan $ availName avail
145+ let span = setFileName srcPath $ fst avail
147 pure span
146 pure span
148 -- We ignore uniques and source spans and only compare the name and the module.
147 -- We ignore uniques and source spans and only compare the name and the module.
149 eqName :: Name -> Name -> Bool
148 eqName :: Name -> Name -> Bool
src/Development/IDE/Spans/Calculate.hs+19−10
@@ -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− -> [ParsedModule]
55+ -> [ParsedModule] -- ^ Dependencies parsed, optional
56+ -> [ModIface] -- ^ Dependencies module interfaces, required
55 -> IO SpansInfo
57 -> IO SpansInfo
56−getSrcSpanInfos env imports tc deps =
58+getSrcSpanInfos env imports tc parsedDeps deps =
57− runGhcEnv env $
59+ evalGhcEnv env $
58− getSpanInfo imports (tmrModule tc) deps
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 -> [ParsedModule]
66 -> [ParsedModule]
67+ -> [ModIface]
65 -> m SpansInfo
68 -> m SpansInfo
66−getSpanInfo mods tcm deps =
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 = tm_parsed_module tcm : deps
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
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−116
@@ -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,135 +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
52−import GHC.Generics
37+import Data.Maybe (fromMaybe)
53
38
54−
55−-- | Newtype wrapper around FilePath that always has normalized slashes.
56−-- The NormalizedUri and hash of the FilePath are cached to avoided
57−-- repeated normalisation when we need to compute them (which is a lot).
58−--
59−-- This is one of the most performance critical parts of ghcide, do not
60−-- modify it without profiling.
61−data NormalizedFilePath = NormalizedFilePath NormalizedUriWrapper !Int !FilePath
62− deriving (Generic, Eq, Ord)
63−
64−instance NFData NormalizedFilePath where
65−instance Binary NormalizedFilePath where
66− put (NormalizedFilePath _ _ fp) = put fp
67− get = do
68− v <- Data.Binary.get :: Get FilePath
69− return (toNormalizedFilePath v)
70−
71−
72−instance Show NormalizedFilePath where
73− show (NormalizedFilePath _ _ fp) = "NormalizedFilePath " ++ show fp
74−
75−instance Hashable NormalizedFilePath where
76− hash (NormalizedFilePath _ h _) = h
77−
78−-- Just to define NFData and Binary
79−newtype NormalizedUriWrapper =
80− NormalizedUriWrapper { unwrapNormalizedFilePath :: NormalizedUri }
81− deriving (Show, Generic, Eq, Ord)
82−
83−instance NFData NormalizedUriWrapper where
84− rnf = rwhnf
85−
86−
87−instance Hashable NormalizedUriWrapper where
88−
89−instance IsString NormalizedFilePath where
90− fromString = toNormalizedFilePath
91−
92−toNormalizedFilePath :: FilePath -> NormalizedFilePath
39+toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath
93-- We want to keep empty paths instead of normalising them to "."
40-- We want to keep empty paths instead of normalising them to "."
94−toNormalizedFilePath "" = NormalizedFilePath (NormalizedUriWrapper emptyPathUri) (hash ("" :: String)) ""
41+toNormalizedFilePath' "" = emptyFilePath
95−toNormalizedFilePath fp =
42+toNormalizedFilePath' fp = LSP.toNormalizedFilePath fp
96− let nfp = normalise fp
97− in NormalizedFilePath (NormalizedUriWrapper $ filePathToUriInternal' nfp) (hash nfp) nfp
98
43
99−fromNormalizedFilePath :: NormalizedFilePath -> FilePath
44+emptyFilePath :: LSP.NormalizedFilePath
100−fromNormalizedFilePath (NormalizedFilePath _ _ fp) = fp
45+emptyFilePath = LSP.NormalizedFilePath emptyPathUri ""
101
46
102-- | 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.
103-- However, haskell-lsp doesn’t support that in uriToFilePath and given
48-- However, haskell-lsp doesn’t support that in uriToFilePath and given
104-- 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.
105-- So we have our own wrapper here that supports empty filepaths.
50-- So we have our own wrapper here that supports empty filepaths.
106−uriToFilePath' :: Uri -> Maybe FilePath
51+uriToFilePath' :: LSP.Uri -> Maybe FilePath
107uriToFilePath' uri
52uriToFilePath' uri
108− | uri == fromNormalizedUri emptyPathUri = Just ""
53+ | uri == LSP.fromNormalizedUri emptyPathUri = Just ""
109 | otherwise = LSP.uriToFilePath uri
54 | otherwise = LSP.uriToFilePath uri
110
55
111−emptyPathUri :: NormalizedUri
56+emptyPathUri :: LSP.NormalizedUri
112−emptyPathUri = filePathToUriInternal' ""
57+emptyPathUri =
113−
58+ let s = "file://"
114−filePathToUri' :: NormalizedFilePath -> NormalizedUri
59+ in LSP.NormalizedUri (hash s) s
115−filePathToUri' (NormalizedFilePath (NormalizedUriWrapper u) _ _) = u
116
60
117−filePathToUriInternal' :: FilePath -> NormalizedUri
118−filePathToUriInternal' fp = toNormalizedUri $ Uri $ T.pack $ LSP.fileScheme <> "//" <> platformAdjustToUriPath fp
119− where
120− -- The definitions below are variants of the corresponding functions in Language.Haskell.LSP.Types.Uri that assume that
121− -- the filepath has already been normalised. This is necessary since normalising the filepath has a nontrivial cost.
122−
123− toNormalizedUri :: Uri -> NormalizedUri
124− toNormalizedUri (Uri t) =
125− let fp = T.pack $ escapeURIString isUnescapedInURI $ unEscapeString $ T.unpack t
126− in NormalizedUri (hash fp) fp
127−
128− platformAdjustToUriPath :: FilePath -> String
129− platformAdjustToUriPath srcPath
130− | isWindows = '/' : escapedPath
131− | otherwise = escapedPath
132− where
133− (splitDirectories, splitDrive)
134− | isWindows =
135− (FPW.splitDirectories, FPW.splitDrive)
136− | otherwise =
137− (FPP.splitDirectories, FPP.splitDrive)
138− escapedPath =
139− case splitDrive srcPath of
140− (drv, rest) ->
141− convertDrive drv `FPP.joinDrive`
142− FPP.joinPath (map (escapeURIString unescaped) $ splitDirectories rest)
143− -- splitDirectories does not remove the path separator after the drive so
144− -- we do a final replacement of \ to /
145− convertDrive drv
146− | isWindows && FPW.hasTrailingPathSeparator drv =
147− FPP.addTrailingPathSeparator (init drv)
148− | otherwise = drv
149− unescaped c
150− | isWindows = isUnreserved c || c `elem` [':', '\\', '/']
151− | otherwise = isUnreserved c || c == '/'
152−
153−
154−
155−fromUri :: LSP.NormalizedUri -> NormalizedFilePath
61+filePathToUri' :: LSP.NormalizedFilePath -> LSP.NormalizedUri
156−fromUri = toNormalizedFilePath . fromMaybe noFilePath . uriToFilePath' . fromNormalizedUri
62+filePathToUri' = LSP.normalizedFilePathToUri
157
63
64+fromUri :: LSP.NormalizedUri -> LSP.NormalizedFilePath
65+fromUri = fromMaybe (toNormalizedFilePath' noFilePath) . LSP.uriToNormalizedFilePath
158
66
159noFilePath :: FilePath
67noFilePath :: FilePath
160noFilePath = "<unknown>"
68noFilePath = "<unknown>"
src/Development/IDE/Types/Options.hs+29−2
@@ -12,6 +12,7 @@ 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
17import Development.Shake
18import Development.Shake
@@ -19,12 +20,14 @@ import Development.IDE.GHC.Util
19import GHC hiding (parseModule, typecheckModule)
20import GHC hiding (parseModule, typecheckModule)
20import GhcPlugins as GHC hiding (fst3, (<>))
21import GhcPlugins as GHC hiding (fst3, (<>))
21import 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
22
25
23data IdeOptions = IdeOptions
26data IdeOptions = IdeOptions
24 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource
27 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource
25 -- ^ 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
26 -- and a list of errors, along with a new parse tree.
29 -- and a list of errors, along with a new parse tree.
27− , optGhcSession :: Action (FilePath -> Action HscEnvEq)
30+ , optGhcSession :: Action (FilePath -> Action (IdeResult HscEnvEq))
28 -- ^ 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@.
29 -- For the same 'ComponentOptions' from hie-bios, 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.
30 -- 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.
@@ -48,6 +51,9 @@ data IdeOptions = IdeOptions
48 -- ^ the ```language to use
51 -- ^ the ```language to use
49 , optNewColonConvention :: Bool
52 , optNewColonConvention :: Bool
50 -- ^ 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.
51 , optDefer :: IdeDefer
57 , optDefer :: IdeDefer
52 -- ^ Whether to defer type errors, typed holes and out of scope
58 -- ^ Whether to defer type errors, typed holes and out of scope
53 -- variables. Deferral allows the IDE to continue to provide
59 -- variables. Deferral allows the IDE to continue to provide
@@ -72,7 +78,7 @@ clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress
72clientSupportsProgress caps = IdeReportProgress $ Just True ==
78clientSupportsProgress caps = IdeReportProgress $ Just True ==
73 (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))
79 (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))
74
80
75−defaultIdeOptions :: Action (FilePath -> Action HscEnvEq) -> IdeOptions
81+defaultIdeOptions :: Action (FilePath -> Action (IdeResult HscEnvEq)) -> IdeOptions
76defaultIdeOptions session = IdeOptions
82defaultIdeOptions session = IdeOptions
77 {optPreprocessor = IdePreprocessedSource [] []
83 {optPreprocessor = IdePreprocessedSource [] []
78 ,optGhcSession = session
84 ,optGhcSession = session
@@ -84,6 +90,7 @@ defaultIdeOptions session = IdeOptions
84 ,optReportProgress = IdeReportProgress False
90 ,optReportProgress = IdeReportProgress False
85 ,optLanguageSyntax = "haskell"
91 ,optLanguageSyntax = "haskell"
86 ,optNewColonConvention = False
92 ,optNewColonConvention = False
93+ ,optKeywords = haskellKeywords
87 ,optDefer = IdeDefer True
94 ,optDefer = IdeDefer True
88 ,optTesting = False
95 ,optTesting = False
89 }
96 }
@@ -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+5−4
@@ -2,10 +2,10 @@ resolver: nightly-2019-09-16
2packages:
2packages:
3- .
3- .
4extra-deps:
4extra-deps:
5−- haskell-lsp-0.20.0.0
5+- haskell-lsp-0.22.0.0
6−- haskell-lsp-types-0.20.0.0
6+- haskell-lsp-types-0.22.0.0
7−- lsp-test-0.10.1.0
7+- lsp-test-0.10.3.0
8−- hie-bios-0.4.0
8+- hie-bios-0.5.0
9- ghc-lib-parser-8.8.1
9- ghc-lib-parser-8.8.1
10- ghc-lib-8.8.1
10- ghc-lib-8.8.1
11- fuzzy-0.1.0.0
11- fuzzy-0.1.0.0
@@ -13,6 +13,7 @@ extra-deps:
13- regex-base-0.94.0.0
13- regex-base-0.94.0.0
14- regex-tdfa-1.3.1.0
14- regex-tdfa-1.3.1.0
15- haddock-library-1.8.0
15- haddock-library-1.8.0
16+- ghc-check-0.3.0.1
16nix:
17nix:
17 packages: [zlib]
18 packages: [zlib]
18flags:
19flags:
stack.yaml+5−4
@@ -2,10 +2,10 @@ resolver: nightly-2019-09-21
2packages:
2packages:
3- .
3- .
4extra-deps:
4extra-deps:
5−- haskell-lsp-0.20.0.0
5+- haskell-lsp-0.22.0.0
6−- haskell-lsp-types-0.20.0.0
6+- haskell-lsp-types-0.22.0.0
7−- lsp-test-0.10.1.0
7+- lsp-test-0.11.0.1
8−- hie-bios-0.4.0
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
@@ -14,5 +14,6 @@ extra-deps:
14- parser-combinators-1.2.1
14- parser-combinators-1.2.1
15- haddock-library-1.8.0
15- haddock-library-1.8.0
16- tasty-rerun-1.1.17
16- tasty-rerun-1.1.17
17+- ghc-check-0.3.0.1
17nix:
18nix:
18 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+6−5
@@ -5,13 +5,13 @@ packages:
5extra-deps:
5extra-deps:
6- aeson-1.4.6.0
6- aeson-1.4.6.0
7- base-orphans-0.8.2
7- base-orphans-0.8.2
8−- haskell-lsp-0.20.0.0
8+- haskell-lsp-0.22.0.0
9−- haskell-lsp-types-0.20.0.0
9+- haskell-lsp-types-0.22.0.0
10−- lsp-test-0.10.1.0
10+- lsp-test-0.11.0.1
11- rope-utf16-splay-0.3.1.0
11- rope-utf16-splay-0.3.1.0
12- filepattern-0.1.1
12- filepattern-0.1.1
13- js-dgtable-0.5.2
13- js-dgtable-0.5.2
14−- hie-bios-0.4.0
14+- hie-bios-0.5.0
15- fuzzy-0.1.0.0
15- fuzzy-0.1.0.0
16- shake-0.18.5
16- shake-0.18.5
17- time-compat-1.9.2.2
17- time-compat-1.9.2.2
@@ -22,11 +22,12 @@ extra-deps:
22- unordered-containers-0.2.10.0
22- unordered-containers-0.2.10.0
23- file-embed-0.0.11.2
23- file-embed-0.0.11.2
24- heaps-0.3.6.1
24- heaps-0.3.6.1
25−
25+- ghc-check-0.3.0.1
26# For tasty-retun
26# For tasty-retun
27- ansi-terminal-0.10.3
27- ansi-terminal-0.10.3
28- ansi-wl-pprint-0.6.9
28- ansi-wl-pprint-0.6.9
29- tasty-1.2.3
29- tasty-1.2.3
30- tasty-rerun-1.1.17
30- tasty-rerun-1.1.17
31+
31nix:
32nix:
32 packages: [zlib]
33 packages: [zlib]
stack88.yaml+5
@@ -2,5 +2,10 @@ 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
9+- hie-bios-0.5.0
5nix:
10nix:
6 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+516−269
@@ -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,29 +10,32 @@
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.Aeson (Value)
17+import Data.Aeson (FromJSON, Value)
16−import Data.Char (toLower)
17import Data.Foldable
18import Data.Foldable
18−import Data.List
19+import Data.List.Extra
19import Data.Rope.UTF16 (Rope)
20import Data.Rope.UTF16 (Rope)
20import qualified Data.Rope.UTF16 as Rope
21import qualified Data.Rope.UTF16 as Rope
21import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
22import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
22import Development.IDE.GHC.Util
23import Development.IDE.GHC.Util
23import qualified Data.Text as T
24import qualified Data.Text as T
25+import Data.Typeable
24import Development.IDE.Spans.Common
26import Development.IDE.Spans.Common
25import Development.IDE.Test
27import Development.IDE.Test
26import Development.IDE.Test.Runfiles
28import Development.IDE.Test.Runfiles
27import Development.IDE.Types.Location
29import Development.IDE.Types.Location
28−import qualified Language.Haskell.LSP.Test as LSPTest
30+import Development.Shake (getDirectoryFilesIO)
29−import Language.Haskell.LSP.Test hiding (openDoc')
31+import Language.Haskell.LSP.Test
30import Language.Haskell.LSP.Messages
32import Language.Haskell.LSP.Messages
31import Language.Haskell.LSP.Types
33import Language.Haskell.LSP.Types
32import Language.Haskell.LSP.Types.Capabilities
34import Language.Haskell.LSP.Types.Capabilities
35+import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)
33import Language.Haskell.LSP.VFS (applyChange)
36import Language.Haskell.LSP.VFS (applyChange)
37+import Network.URI
34−import System.Environment.Blank (setEnv)
38+import System.Environment.Blank (getEnv, setEnv, unsetEnv)
35import System.FilePath
39import System.FilePath
36import System.IO.Extra
40import System.IO.Extra
37import System.Directory
41import System.Directory
@@ -45,30 +49,35 @@ import Test.Tasty.QuickCheck
45import Data.Maybe
49import Data.Maybe
46
50
47main :: IO ()
51main :: IO ()
52+main = do
53+ -- We mess with env vars so run single-threaded.
54+ setEnv "TASTY_NUM_THREADS" "1" True
48−main = defaultMainWithRerun $ testGroup "HIE"
55+ defaultMainWithRerun $ testGroup "HIE"
49− [ testSession "open close" $ do
56+ [ testSession "open close" $ do
50− doc <- openDoc' "Testing.hs" "haskell" ""
57+ doc <- createDoc "Testing.hs" "haskell" ""
51− void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
58+ void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)
52− void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
59+ void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)
53− closeDoc doc
60+ closeDoc doc
54− void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
61+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)
55− , initializeResponseTests
62+ , initializeResponseTests
56− , completionTests
63+ , completionTests
57− , cppTests
64+ , cppTests
58− , diagnosticTests
65+ , diagnosticTests
59− , codeActionTests
66+ , codeActionTests
60− , codeLensesTests
67+ , codeLensesTests
61− , outlineTests
68+ , outlineTests
62− , findDefinitionAndHoverTests
69+ , findDefinitionAndHoverTests
63− , pluginTests
70+ , pluginTests
64− , preprocessorTests
71+ , preprocessorTests
65− , thTests
72+ , thTests
73+ , safeTests
66− , unitTests
74+ , unitTests
67− , haddockTests
75+ , haddockTests
68− , positionMappingTests
76+ , positionMappingTests
69− , watchedFilesTests
77+ , watchedFilesTests
70− , cradleTests
78+ , cradleTests
79+ , dependentFileTest
71− ]
80+ ]
72
81
73initializeResponseTests :: TestTree
82initializeResponseTests :: TestTree
74initializeResponseTests = withResource acquire release tests where
83initializeResponseTests = withResource acquire release tests where
@@ -103,7 +112,7 @@ initializeResponseTests = withResource acquire release tests where
103 , chk "NO doc link" _documentLinkProvider Nothing
112 , chk "NO doc link" _documentLinkProvider Nothing
104 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
113 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)
105 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
114 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)
106− , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
115+ , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])
107 , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
116 , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))
108 , chk "NO experimental" _experimental Nothing
117 , chk "NO experimental" _experimental Nothing
109 ] where
118 ] where
@@ -119,8 +128,17 @@ initializeResponseTests = withResource acquire release tests where
119 chk title getActual expected =
128 chk title getActual expected =
120 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
129 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir
121
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+
122 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner
123− innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c
141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c
124 innerCaps _ = error "this test only expects inner capabilities"
142 innerCaps _ = error "this test only expects inner capabilities"
125
143
126 acquire :: IO InitializeResponse
144 acquire :: IO InitializeResponse
@@ -134,7 +152,7 @@ diagnosticTests :: TestTree
134diagnosticTests = testGroup "diagnostics"
152diagnosticTests = testGroup "diagnostics"
135 [ testSessionWait "fix syntax error" $ do
153 [ testSessionWait "fix syntax error" $ do
136 let content = T.unlines [ "module Testing wher" ]
154 let content = T.unlines [ "module Testing wher" ]
137− doc <- openDoc' "Testing.hs" "haskell" content
155+ doc <- createDoc "Testing.hs" "haskell" content
138 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]
139 let change = TextDocumentContentChangeEvent
157 let change = TextDocumentContentChangeEvent
140 { _range = Just (Range (Position 0 15) (Position 0 19))
158 { _range = Just (Range (Position 0 15) (Position 0 19))
@@ -145,7 +163,7 @@ diagnosticTests = testGroup "diagnostics"
145 expectDiagnostics [("Testing.hs", [])]
163 expectDiagnostics [("Testing.hs", [])]
146 , testSessionWait "introduce syntax error" $ do
164 , testSessionWait "introduce syntax error" $ do
147 let content = T.unlines [ "module Testing where" ]
165 let content = T.unlines [ "module Testing where" ]
148− doc <- openDoc' "Testing.hs" "haskell" content
166+ doc <- createDoc "Testing.hs" "haskell" content
149 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
167 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)
150 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
168 void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)
151 let change = TextDocumentContentChangeEvent
169 let change = TextDocumentContentChangeEvent
@@ -163,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"
163 , "bar :: Int -> Int -> Int"
181 , "bar :: Int -> Int -> Int"
164 , "bar a b = cd + b"
182 , "bar a b = cd + b"
165 ]
183 ]
166− _ <- openDoc' "Testing.hs" "haskell" content
184+ _ <- createDoc "Testing.hs" "haskell" content
167 expectDiagnostics
185 expectDiagnostics
168 [ ( "Testing.hs"
186 [ ( "Testing.hs"
169 , [ (DsError, (2, 14), "Variable not in scope: ab")
187 , [ (DsError, (2, 14), "Variable not in scope: ab")
@@ -177,7 +195,7 @@ diagnosticTests = testGroup "diagnostics"
177 , "foo :: Int -> String -> Int"
195 , "foo :: Int -> String -> Int"
178 , "foo a b = a + b"
196 , "foo a b = a + b"
179 ]
197 ]
180− _ <- openDoc' "Testing.hs" "haskell" content
198+ _ <- createDoc "Testing.hs" "haskell" content
181 expectDiagnostics
199 expectDiagnostics
182 [ ( "Testing.hs"
200 [ ( "Testing.hs"
183 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]
@@ -189,7 +207,7 @@ diagnosticTests = testGroup "diagnostics"
189 , "foo :: Int -> String"
207 , "foo :: Int -> String"
190 , "foo a = _ a"
208 , "foo a = _ a"
191 ]
209 ]
192− _ <- openDoc' "Testing.hs" "haskell" content
210+ _ <- createDoc "Testing.hs" "haskell" content
193 expectDiagnostics
211 expectDiagnostics
194 [ ( "Testing.hs"
212 [ ( "Testing.hs"
195 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]
@@ -211,24 +229,23 @@ diagnosticTests = testGroup "diagnostics"
211 [ ("A.hs", [(DsError, (2,4), aMessage)])
229 [ ("A.hs", [(DsError, (2,4), aMessage)])
212 , ("B.hs", [(DsError, (3,4), bMessage)])]
230 , ("B.hs", [(DsError, (3,4), bMessage)])]
213 deferralTest title binding msg = testSessionWait title $ do
231 deferralTest title binding msg = testSessionWait title $ do
214− _ <- openDoc' "A.hs" "haskell" $ sourceA binding
232+ _ <- createDoc "A.hs" "haskell" $ sourceA binding
215− _ <- openDoc' "B.hs" "haskell" sourceB
233+ _ <- createDoc "B.hs" "haskell" sourceB
216 expectDiagnostics $ expectedDs msg
234 expectDiagnostics $ expectedDs msg
217 in
235 in
218 [ deferralTest "type error" "True" "Couldn't match expected type"
236 [ deferralTest "type error" "True" "Couldn't match expected type"
219 , deferralTest "typed hole" "_" "Found hole"
237 , deferralTest "typed hole" "_" "Found hole"
220 , deferralTest "out of scope var" "unbound" "Variable not in scope"
238 , deferralTest "out of scope var" "unbound" "Variable not in scope"
221− , deferralTest "message shows error" "True" "A.hs:3:5: error:"
222 ]
239 ]
223
240
224 , testSessionWait "remove required module" $ do
241 , testSessionWait "remove required module" $ do
225 let contentA = T.unlines [ "module ModuleA where" ]
242 let contentA = T.unlines [ "module ModuleA where" ]
226− docA <- openDoc' "ModuleA.hs" "haskell" contentA
243+ docA <- createDoc "ModuleA.hs" "haskell" contentA
227 let contentB = T.unlines
244 let contentB = T.unlines
228 [ "module ModuleB where"
245 [ "module ModuleB where"
229 , "import ModuleA"
246 , "import ModuleA"
230 ]
247 ]
231− _ <- openDoc' "ModuleB.hs" "haskell" contentB
248+ _ <- createDoc "ModuleB.hs" "haskell" contentB
232 let change = TextDocumentContentChangeEvent
249 let change = TextDocumentContentChangeEvent
233 { _range = Just (Range (Position 0 0) (Position 0 20))
250 { _range = Just (Range (Position 0 0) (Position 0 20))
234 , _rangeLength = Nothing
251 , _rangeLength = Nothing
@@ -241,20 +258,20 @@ diagnosticTests = testGroup "diagnostics"
241 [ "module ModuleB where"
258 [ "module ModuleB where"
242 , "import ModuleA"
259 , "import ModuleA"
243 ]
260 ]
244− _ <- openDoc' "ModuleB.hs" "haskell" contentB
261+ _ <- createDoc "ModuleB.hs" "haskell" contentB
245 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
246 let contentA = T.unlines [ "module ModuleA where" ]
263 let contentA = T.unlines [ "module ModuleA where" ]
247− _ <- openDoc' "ModuleA.hs" "haskell" contentA
264+ _ <- createDoc "ModuleA.hs" "haskell" contentA
248 expectDiagnostics [("ModuleB.hs", [])]
265 expectDiagnostics [("ModuleB.hs", [])]
249 , testSessionWait "add missing module (non workspace)" $ do
266 , testSessionWait "add missing module (non workspace)" $ do
250 let contentB = T.unlines
267 let contentB = T.unlines
251 [ "module ModuleB where"
268 [ "module ModuleB where"
252 , "import ModuleA"
269 , "import ModuleA"
253 ]
270 ]
254− _ <- openDoc'' "/tmp/ModuleB.hs" "haskell" contentB
271+ _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB
255 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
272 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]
256 let contentA = T.unlines [ "module ModuleA where" ]
273 let contentA = T.unlines [ "module ModuleA where" ]
257− _ <- openDoc'' "/tmp/ModuleA.hs" "haskell" contentA
274+ _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA
258 expectDiagnostics [("/tmp/ModuleB.hs", [])]
275 expectDiagnostics [("/tmp/ModuleB.hs", [])]
259 , testSessionWait "cyclic module dependency" $ do
276 , testSessionWait "cyclic module dependency" $ do
260 let contentA = T.unlines
277 let contentA = T.unlines
@@ -265,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"
265 [ "module ModuleB where"
282 [ "module ModuleB where"
266 , "import ModuleA"
283 , "import ModuleA"
267 ]
284 ]
268− _ <- openDoc' "ModuleA.hs" "haskell" contentA
285+ _ <- createDoc "ModuleA.hs" "haskell" contentA
269− _ <- openDoc' "ModuleB.hs" "haskell" contentB
286+ _ <- createDoc "ModuleB.hs" "haskell" contentB
270 expectDiagnostics
287 expectDiagnostics
271 [ ( "ModuleA.hs"
288 [ ( "ModuleA.hs"
272 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
@@ -287,9 +304,9 @@ diagnosticTests = testGroup "diagnostics"
287 let contentBboot = T.unlines
304 let contentBboot = T.unlines
288 [ "module ModuleB where"
305 [ "module ModuleB where"
289 ]
306 ]
290− _ <- openDoc' "ModuleA.hs" "haskell" contentA
307+ _ <- createDoc "ModuleA.hs" "haskell" contentA
291− _ <- openDoc' "ModuleB.hs" "haskell" contentB
308+ _ <- createDoc "ModuleB.hs" "haskell" contentB
292− _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot
309+ _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
293 expectDiagnostics []
310 expectDiagnostics []
294 , testSessionWait "correct reference used with hs-boot" $ do
311 , testSessionWait "correct reference used with hs-boot" $ do
295 let contentB = T.unlines
312 let contentB = T.unlines
@@ -311,10 +328,10 @@ diagnosticTests = testGroup "diagnostics"
311 -- resolved to the hs-boot file
328 -- resolved to the hs-boot file
312 , "y = x"
329 , "y = x"
313 ]
330 ]
314− _ <- openDoc' "ModuleB.hs" "haskell" contentB
331+ _ <- createDoc "ModuleB.hs" "haskell" contentB
315− _ <- openDoc' "ModuleA.hs" "haskell" contentA
332+ _ <- createDoc "ModuleA.hs" "haskell" contentA
316− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot
333+ _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot
317− _ <- openDoc' "ModuleC.hs" "haskell" contentC
334+ _ <- createDoc "ModuleC.hs" "haskell" contentC
318 expectDiagnostics []
335 expectDiagnostics []
319 , testSessionWait "redundant import" $ do
336 , testSessionWait "redundant import" $ do
320 let contentA = T.unlines ["module ModuleA where"]
337 let contentA = T.unlines ["module ModuleA where"]
@@ -323,8 +340,8 @@ diagnosticTests = testGroup "diagnostics"
323 , "module ModuleB where"
340 , "module ModuleB where"
324 , "import ModuleA"
341 , "import ModuleA"
325 ]
342 ]
326− _ <- openDoc' "ModuleA.hs" "haskell" contentA
343+ _ <- createDoc "ModuleA.hs" "haskell" contentA
327− _ <- openDoc' "ModuleB.hs" "haskell" contentB
344+ _ <- createDoc "ModuleB.hs" "haskell" contentB
328 expectDiagnostics
345 expectDiagnostics
329 [ ( "ModuleB.hs"
346 [ ( "ModuleB.hs"
330 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]
@@ -346,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"
346 , "wrong1 = ThisList.map"
363 , "wrong1 = ThisList.map"
347 , "wrong2 = BaseList.x"
364 , "wrong2 = BaseList.x"
348 ]
365 ]
349− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent
366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent
350− _ <- openDoc' "Main.hs" "haskell" mainContent
367+ _ <- createDoc "Main.hs" "haskell" mainContent
351 expectDiagnostics
368 expectDiagnostics
352 [ ( "Main.hs"
369 [ ( "Main.hs"
353 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")
@@ -362,7 +379,7 @@ diagnosticTests = testGroup "diagnostics"
362 , "foo :: Ord a => a -> Int"
379 , "foo :: Ord a => a -> Int"
363 , "foo a = 1"
380 , "foo a = 1"
364 ]
381 ]
365− _ <- openDoc' "Foo.hs" "haskell" fooContent
382+ _ <- createDoc "Foo.hs" "haskell" fooContent
366 expectDiagnostics
383 expectDiagnostics
367 [ ( "Foo.hs"
384 [ ( "Foo.hs"
368 -- The test is to make sure that warnings contain unqualified names
385 -- The test is to make sure that warnings contain unqualified names
@@ -387,18 +404,18 @@ diagnosticTests = testGroup "diagnostics"
387 Just pathB <- pure $ uriToFilePath uriB
404 Just pathB <- pure $ uriToFilePath uriB
388 uriB <- pure $
405 uriB <- pure $
389 let (drive, suffix) = splitDrive pathB
406 let (drive, suffix) = splitDrive pathB
390− in filePathToUri (joinDrive (map toLower drive ) suffix)
407+ in filePathToUri (joinDrive (lower drive) suffix)
391 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
408 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
392 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
409 liftIO $ writeFileUTF8 pathB $ T.unpack bContent
393 uriA <- getDocUri "A/A.hs"
410 uriA <- getDocUri "A/A.hs"
394 Just pathA <- pure $ uriToFilePath uriA
411 Just pathA <- pure $ uriToFilePath uriA
395 uriA <- pure $
412 uriA <- pure $
396 let (drive, suffix) = splitDrive pathA
413 let (drive, suffix) = splitDrive pathA
397− in filePathToUri (joinDrive (map toLower drive ) suffix)
414+ in filePathToUri (joinDrive (lower drive) suffix)
398 let itemA = TextDocumentItem uriA "haskell" 0 aContent
415 let itemA = TextDocumentItem uriA "haskell" 0 aContent
399 let a = TextDocumentIdentifier uriA
416 let a = TextDocumentIdentifier uriA
400 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
417 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)
401− diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
418+ diagsNot <- skipManyTill anyMessage diagnostic
402 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
419 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)
403 -- 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
404 -- the diagnostics for A.B will also be lower-case.
421 -- the diagnostics for A.B will also be lower-case.
@@ -407,6 +424,38 @@ diagnosticTests = testGroup "diagnostics"
407 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
424 liftIO $ unless ("redundant" `T.isInfixOf` msg) $
408 assertFailure ("Expected redundant import but got " <> T.unpack msg)
425 assertFailure ("Expected redundant import but got " <> T.unpack msg)
409 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
410 ]
459 ]
411
460
412codeActionTests :: TestTree
461codeActionTests :: TestTree
@@ -432,26 +481,26 @@ codeLensesTests = testGroup "code lenses"
432watchedFilesTests :: TestTree
481watchedFilesTests :: TestTree
433watchedFilesTests = testGroup "watched files"
482watchedFilesTests = testGroup "watched files"
434 [ testSession' "workspace files" $ \sessionDir -> do
483 [ testSession' "workspace files" $ \sessionDir -> do
435− liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-isrc\"]}}"
484+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"
436− _ <- openDoc' "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport B"
485+ _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
437− watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd
486+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
438−
487+
439− -- Expect 6 subscriptions (A does not get any because it's VFS):
488+ -- Expect 4 subscriptions (A does not get any because it's VFS):
440− -- - /path-to-workspace/B.hs
489+ -- - /path-to-workspace/WatchedFilesMissingModule.hs
441− -- - /path-to-workspace/B.lhs
490+ -- - /path-to-workspace/WatchedFilesMissingModule.lhs
442− -- - B.hs
491+ -- - /path-to-workspace/src/WatchedFilesMissingModule.hs
443− -- - B.lhs
492+ -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs
444− -- - src/B.hs
445− -- - src/B.lhs
446− liftIO $ length watchedFileRegs @?= 6
493+ liftIO $ length watchedFileRegs @?= 4
447
494
448 , testSession' "non workspace file" $ \sessionDir -> do
495 , testSession' "non workspace file" $ \sessionDir -> do
449− liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
496+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
450− _ <- openDoc' "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport B"
497+ _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
451− watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd
498+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
452
499
453− -- Expect 4 subscriptions:
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
454− liftIO $ length watchedFileRegs @?= 4
503+ liftIO $ length watchedFileRegs @?= 2
455
504
456 -- TODO add a test for didChangeWorkspaceFolder
505 -- TODO add a test for didChangeWorkspaceFolder
457 ]
506 ]
@@ -464,7 +513,7 @@ renameActionTests = testGroup "rename actions"
464 , "foo :: Int -> Int"
513 , "foo :: Int -> Int"
465 , "foo argName = argNme"
514 , "foo argName = argNme"
466 ]
515 ]
467− doc <- openDoc' "Testing.hs" "haskell" content
516+ doc <- createDoc "Testing.hs" "haskell" content
468 _ <- waitForDiagnostics
517 _ <- waitForDiagnostics
469 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’"
470 executeCodeAction action
519 executeCodeAction action
@@ -482,7 +531,7 @@ renameActionTests = testGroup "rename actions"
482 , "foo :: Maybe a -> [a]"
531 , "foo :: Maybe a -> [a]"
483 , "foo = maybToList"
532 , "foo = maybToList"
484 ]
533 ]
485− doc <- openDoc' "Testing.hs" "haskell" content
534+ doc <- createDoc "Testing.hs" "haskell" content
486 _ <- waitForDiagnostics
535 _ <- waitForDiagnostics
487 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’"
488 executeCodeAction action
537 executeCodeAction action
@@ -500,7 +549,7 @@ renameActionTests = testGroup "rename actions"
500 , "foo :: Char -> Char -> Char -> Char"
549 , "foo :: Char -> Char -> Char -> Char"
501 , "foo argument1 argument2 argument3 = argumentX"
550 , "foo argument1 argument2 argument3 = argumentX"
502 ]
551 ]
503− doc <- openDoc' "Testing.hs" "haskell" content
552+ doc <- createDoc "Testing.hs" "haskell" content
504 _ <- waitForDiagnostics
553 _ <- waitForDiagnostics
505 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
554 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))
506 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
555 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]
@@ -512,7 +561,7 @@ renameActionTests = testGroup "rename actions"
512 , "monus x y = max 0 (x - y)"
561 , "monus x y = max 0 (x - y)"
513 , "foo x y = x `monnus` y"
562 , "foo x y = x `monnus` y"
514 ]
563 ]
515− doc <- openDoc' "Testing.hs" "haskell" content
564+ doc <- createDoc "Testing.hs" "haskell" content
516 _ <- waitForDiagnostics
565 _ <- waitForDiagnostics
517 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))
518 [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 ]
@@ -535,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
535 , "func :: _"
584 , "func :: _"
536 , "func x = x"
585 , "func x = x"
537 ]
586 ]
538− doc <- openDoc' "Testing.hs" "haskell" content
587+ doc <- createDoc "Testing.hs" "haskell" content
539 _ <- waitForDiagnostics
588 _ <- waitForDiagnostics
540 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
541 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -555,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
555 , "func :: _"
604 , "func :: _"
556 , "func x y = x + y"
605 , "func x y = x + y"
557 ]
606 ]
558− doc <- openDoc' "Testing.hs" "haskell" content
607+ doc <- createDoc "Testing.hs" "haskell" content
559 _ <- waitForDiagnostics
608 _ <- waitForDiagnostics
560 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))
561 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -578,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"
578 , " y = x * 2"
627 , " y = x * 2"
579 , " in y"
628 , " in y"
580 ]
629 ]
581− doc <- openDoc' "Testing.hs" "haskell" content
630+ doc <- createDoc "Testing.hs" "haskell" content
582 _ <- waitForDiagnostics
631 _ <- waitForDiagnostics
583 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))
584 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands
@@ -603,7 +652,7 @@ removeImportTests = testGroup "remove import actions"
603 let contentA = T.unlines
652 let contentA = T.unlines
604 [ "module ModuleA where"
653 [ "module ModuleA where"
605 ]
654 ]
606− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
607 let contentB = T.unlines
656 let contentB = T.unlines
608 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
609 , "module ModuleB where"
658 , "module ModuleB where"
@@ -611,7 +660,7 @@ removeImportTests = testGroup "remove import actions"
611 , "stuffB :: Integer"
660 , "stuffB :: Integer"
612 , "stuffB = 123"
661 , "stuffB = 123"
613 ]
662 ]
614− docB <- openDoc' "ModuleB.hs" "haskell" contentB
663+ docB <- createDoc "ModuleB.hs" "haskell" contentB
615 _ <- waitForDiagnostics
664 _ <- waitForDiagnostics
616 [CACodeAction action@CodeAction { _title = actionTitle }]
665 [CACodeAction action@CodeAction { _title = actionTitle }]
617 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -629,7 +678,7 @@ removeImportTests = testGroup "remove import actions"
629 let contentA = T.unlines
678 let contentA = T.unlines
630 [ "module ModuleA where"
679 [ "module ModuleA where"
631 ]
680 ]
632− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
633 let contentB = T.unlines
682 let contentB = T.unlines
634 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
635 , "module ModuleB where"
684 , "module ModuleB where"
@@ -637,7 +686,7 @@ removeImportTests = testGroup "remove import actions"
637 , "stuffB :: Integer"
686 , "stuffB :: Integer"
638 , "stuffB = 123"
687 , "stuffB = 123"
639 ]
688 ]
640− docB <- openDoc' "ModuleB.hs" "haskell" contentB
689+ docB <- createDoc "ModuleB.hs" "haskell" contentB
641 _ <- waitForDiagnostics
690 _ <- waitForDiagnostics
642 [CACodeAction action@CodeAction { _title = actionTitle }]
691 [CACodeAction action@CodeAction { _title = actionTitle }]
643 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -659,14 +708,14 @@ removeImportTests = testGroup "remove import actions"
659 , "stuffB = 123"
708 , "stuffB = 123"
660 , "stuffC = ()"
709 , "stuffC = ()"
661 ]
710 ]
662− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
663 let contentB = T.unlines
712 let contentB = T.unlines
664 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
713 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
665 , "module ModuleB where"
714 , "module ModuleB where"
666 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
715 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"
667 , "main = print stuffB"
716 , "main = print stuffB"
668 ]
717 ]
669− docB <- openDoc' "ModuleB.hs" "haskell" contentB
718+ docB <- createDoc "ModuleB.hs" "haskell" contentB
670 _ <- waitForDiagnostics
719 _ <- waitForDiagnostics
671 [CACodeAction action@CodeAction { _title = actionTitle }]
720 [CACodeAction action@CodeAction { _title = actionTitle }]
672 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
721 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -688,22 +737,18 @@ removeImportTests = testGroup "remove import actions"
688 , "stuffB :: Integer"
737 , "stuffB :: Integer"
689 , "stuffB = 123"
738 , "stuffB = 123"
690 ]
739 ]
691− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
692 let contentB = T.unlines
741 let contentB = T.unlines
693 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
742 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
694 , "module ModuleB where"
743 , "module ModuleB where"
695 , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
744 , "import qualified ModuleA as A ((<?>), stuffB, (!!))"
696 , "main = print A.stuffB"
745 , "main = print A.stuffB"
697 ]
746 ]
698− docB <- openDoc' "ModuleB.hs" "haskell" contentB
747+ docB <- createDoc "ModuleB.hs" "haskell" contentB
699 _ <- waitForDiagnostics
748 _ <- waitForDiagnostics
700 [CACodeAction action@CodeAction { _title = actionTitle }]
749 [CACodeAction action@CodeAction { _title = actionTitle }]
701 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
750 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
702−#if MIN_GHC_API_VERSION(8,6,0)
703 liftIO $ "Remove !!, <?> from import" @=? actionTitle
751 liftIO $ "Remove !!, <?> from import" @=? actionTitle
704−#else
705− liftIO $ "Remove A.!!, A.<?> from import" @=? actionTitle
706−#endif
707 executeCodeAction action
752 executeCodeAction action
708 contentAfterAction <- documentContents docB
753 contentAfterAction <- documentContents docB
709 let expectedContentAfterAction = T.unlines
754 let expectedContentAfterAction = T.unlines
@@ -720,14 +765,14 @@ removeImportTests = testGroup "remove import actions"
720 , "stuffB :: Integer"
765 , "stuffB :: Integer"
721 , "stuffB = 123"
766 , "stuffB = 123"
722 ]
767 ]
723− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
724 let contentB = T.unlines
769 let contentB = T.unlines
725 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
770 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
726 , "module ModuleB where"
771 , "module ModuleB where"
727 , "import ModuleA (A(..), stuffB)"
772 , "import ModuleA (A(..), stuffB)"
728 , "main = print stuffB"
773 , "main = print stuffB"
729 ]
774 ]
730− docB <- openDoc' "ModuleB.hs" "haskell" contentB
775+ docB <- createDoc "ModuleB.hs" "haskell" contentB
731 _ <- waitForDiagnostics
776 _ <- waitForDiagnostics
732 [CACodeAction action@CodeAction { _title = actionTitle }]
777 [CACodeAction action@CodeAction { _title = actionTitle }]
733 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
778 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -747,14 +792,14 @@ removeImportTests = testGroup "remove import actions"
747 , "data D = A | B"
792 , "data D = A | B"
748 , "data E = F"
793 , "data E = F"
749 ]
794 ]
750− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
795+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
751 let contentB = T.unlines
796 let contentB = T.unlines
752 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
797 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
753 , "module ModuleB where"
798 , "module ModuleB where"
754 , "import ModuleA (D(A,B), E(F))"
799 , "import ModuleA (D(A,B), E(F))"
755 , "main = B"
800 , "main = B"
756 ]
801 ]
757− docB <- openDoc' "ModuleB.hs" "haskell" contentB
802+ docB <- createDoc "ModuleB.hs" "haskell" contentB
758 _ <- waitForDiagnostics
803 _ <- waitForDiagnostics
759 [CACodeAction action@CodeAction { _title = actionTitle }]
804 [CACodeAction action@CodeAction { _title = actionTitle }]
760 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
805 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))
@@ -895,8 +940,8 @@ extendImportTests = testGroup "extend import actions"
895 ]
940 ]
896 where
941 where
897 template contentA contentB range expectedAction expectedContentB = do
942 template contentA contentB range expectedAction expectedContentB = do
898− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
899− docB <- openDoc' "ModuleB.hs" "haskell" contentB
944+ docB <- createDoc "ModuleB.hs" "haskell" contentB
900 _ <- waitForDiagnostics
945 _ <- waitForDiagnostics
901 CACodeAction action@CodeAction { _title = actionTitle } : _
946 CACodeAction action@CodeAction { _title = actionTitle } : _
902 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
947 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -936,6 +981,8 @@ suggestImportTests = testGroup "suggest import actions"
936 , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"
981 , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"
937 , test True [] "f = pack" [] "import Data.Text (pack)"
982 , test True [] "f = pack" [] "import Data.Text (pack)"
938 , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)"
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 ((&))"
939 ]
986 ]
940 ]
987 ]
941 where
988 where
@@ -944,19 +991,20 @@ suggestImportTests = testGroup "suggest import actions"
944 after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
991 after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
945 cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"
992 cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"
946 liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
993 liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
947− doc <- openDoc' "Test.hs" "haskell" before
994+ doc <- createDoc "Test.hs" "haskell" before
948 _diags <- waitForDiagnostics
995 _diags <- waitForDiagnostics
949 let defLine = length imps + 1
996 let defLine = length imps + 1
950 range = Range (Position defLine 0) (Position defLine maxBound)
997 range = Range (Position defLine 0) (Position defLine maxBound)
951 actions <- getCodeActions doc range
998 actions <- getCodeActions doc range
952− case wanted of
999+ if wanted
953− False ->
1000+ then do
1001+ action <- liftIO $ pickActionWithTitle newImp actions
1002+ executeCodeAction action
1003+ contentAfterAction <- documentContents doc
1004+ liftIO $ after @=? contentAfterAction
1005+ else
954− liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
1006+ liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []
955− True -> do
1007+
956− action <- liftIO $ pickActionWithTitle newImp actions
957− executeCodeAction action
958− contentAfterAction <- documentContents doc
959− liftIO $ after @=? contentAfterAction
960
1008
961addExtensionTests :: TestTree
1009addExtensionTests :: TestTree
962addExtensionTests = testGroup "add language extension actions"
1010addExtensionTests = testGroup "add language extension actions"
@@ -1003,7 +1051,7 @@ addExtensionTests = testGroup "add language extension actions"
1003 ]
1051 ]
1004 where
1052 where
1005 template initialContent range expectedAction expectedContents = do
1053 template initialContent range expectedAction expectedContents = do
1006− doc <- openDoc' "Module.hs" "haskell" initialContent
1054+ doc <- createDoc "Module.hs" "haskell" initialContent
1007 _ <- waitForDiagnostics
1055 _ <- waitForDiagnostics
1008 CACodeAction action@CodeAction { _title = actionTitle } : _
1056 CACodeAction action@CodeAction { _title = actionTitle } : _
1009 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1057 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1026,7 +1074,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
1026 [""
1074 [""
1027 ,"someOtherCode = ()"
1075 ,"someOtherCode = ()"
1028 ]
1076 ]
1029− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1030 _ <- waitForDiagnostics
1078 _ <- waitForDiagnostics
1031 CACodeAction action@CodeAction { _title = actionTitle } : _
1079 CACodeAction action@CodeAction { _title = actionTitle } : _
1032 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1080 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1050,7 +1098,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"
1050 [""
1098 [""
1051 ,"someOtherCode = ()"
1099 ,"someOtherCode = ()"
1052 ]
1100 ]
1053− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')
1054 _ <- waitForDiagnostics
1102 _ <- waitForDiagnostics
1055 CACodeAction action@CodeAction { _title = actionTitle } : _
1103 CACodeAction action@CodeAction { _title = actionTitle } : _
1056 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1104 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1089,8 +1137,8 @@ fixConstructorImportTests = testGroup "fix import actions"
1089 ]
1137 ]
1090 where
1138 where
1091 template contentA contentB range expectedAction expectedContentB = do
1139 template contentA contentB range expectedAction expectedContentB = do
1092− _docA <- openDoc' "ModuleA.hs" "haskell" contentA
1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA
1093− docB <- openDoc' "ModuleB.hs" "haskell" contentB
1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB
1094 _diags <- waitForDiagnostics
1142 _diags <- waitForDiagnostics
1095 CACodeAction action@CodeAction { _title = actionTitle } : _
1143 CACodeAction action@CodeAction { _title = actionTitle } : _
1096 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
1144 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>
@@ -1109,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"
1109 [ "module Testing where"
1157 [ "module Testing where"
1110 , "import Data.Mape"
1158 , "import Data.Mape"
1111 ]
1159 ]
1112− doc <- openDoc' "Testing.hs" "haskell" content
1160+ doc <- createDoc "Testing.hs" "haskell" content
1113 _ <- waitForDiagnostics
1161 _ <- waitForDiagnostics
1114 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
1162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))
1115 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 ]
@@ -1146,7 +1194,7 @@ fillTypedHoleTests = let
1146 newA newB newC = testSession (T.unpack actionTitle) $ do
1194 newA newB newC = testSession (T.unpack actionTitle) $ do
1147 let originalCode = sourceCode oldA oldB oldC
1195 let originalCode = sourceCode oldA oldB oldC
1148 let expectedCode = sourceCode newA newB newC
1196 let expectedCode = sourceCode newA newB newC
1149− doc <- openDoc' "Testing.hs" "haskell" originalCode
1197+ doc <- createDoc "Testing.hs" "haskell" originalCode
1150 _ <- waitForDiagnostics
1198 _ <- waitForDiagnostics
1151 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
1199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))
1152 chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
1200 chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands
@@ -1194,7 +1242,7 @@ addSigActionTests = let
1194 def >:: sig = testSession (T.unpack def) $ do
1242 def >:: sig = testSession (T.unpack def) $ do
1195 let originalCode = before def
1243 let originalCode = before def
1196 let expectedCode = after' def sig
1244 let expectedCode = after' def sig
1197− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode
1198 _ <- waitForDiagnostics
1246 _ <- waitForDiagnostics
1199 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
1247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))
1200 chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
1248 chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands
@@ -1226,7 +1274,7 @@ addSigLensesTests = let
1226 sigSession withMissing def sig = testSession (T.unpack def) $ do
1274 sigSession withMissing def sig = testSession (T.unpack def) $ do
1227 let originalCode = before withMissing def
1275 let originalCode = before withMissing def
1228 let expectedCode = after' withMissing def sig
1276 let expectedCode = after' withMissing def sig
1229− doc <- openDoc' "Sigs.hs" "haskell" originalCode
1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode
1230 [CodeLens {_command = Just c}] <- getCodeLenses doc
1278 [CodeLens {_command = Just c}] <- getCodeLenses doc
1231 executeCommand c
1279 executeCommand c
1232 modifiedCode <- getDocumentEdit doc
1280 modifiedCode <- getDocumentEdit doc
@@ -1248,24 +1296,19 @@ addSigLensesTests = let
1248 ]
1296 ]
1249 ]
1297 ]
1250
1298
1251−findDefinitionAndHoverTests :: TestTree
1299+checkDefs :: [Location] -> Session [Expect] -> Session ()
1252−findDefinitionAndHoverTests = let
1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where
1253−
1254− tst (get, check) pos targetRange title = testSession title $ do
1255− doc <- openTestDataDoc sourceFilePath
1256− found <- get doc pos
1257− check found targetRange
1258
1301
1259− checkDefs :: [Location] -> [Expect] -> Session ()
1260− checkDefs defs expectations = traverse_ check expectations where
1261−
1262− check (ExpectRange expectedRange) = do
1302+ check (ExpectRange expectedRange) = do
1263− assertNDefinitionsFound 1 defs
1303+ assertNDefinitionsFound 1 defs
1264− assertRangeCorrect (head defs) expectedRange
1304+ assertRangeCorrect (head defs) expectedRange
1305+ check (ExpectLocation expectedLocation) = do
1306+ assertNDefinitionsFound 1 defs
1307+ liftIO $ head defs @?= expectedLocation
1265− check ExpectNoDefinitions = do
1308+ check ExpectNoDefinitions = do
1266− assertNDefinitionsFound 0 defs
1309+ assertNDefinitionsFound 0 defs
1267− 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"
1268− check _ = pure () -- all other expectations not relevant to getDefinition
1311+ check _ = pure () -- all other expectations not relevant to getDefinition
1269
1312
1270 assertNDefinitionsFound :: Int -> [a] -> Session ()
1313 assertNDefinitionsFound :: Int -> [a] -> Session ()
1271 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
1314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
@@ -1273,8 +1316,19 @@ findDefinitionAndHoverTests = let
1273 assertRangeCorrect Location{_range = foundRange} expectedRange =
1316 assertRangeCorrect Location{_range = foundRange} expectedRange =
1274 liftIO $ expectedRange @=? foundRange
1317 liftIO $ expectedRange @=? foundRange
1275
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+
1276− checkHover :: Maybe Hover -> [Expect] -> Session ()
1330+ checkHover :: Maybe Hover -> Session [Expect] -> Session ()
1277− checkHover hover expectations = traverse_ check expectations where
1331+ checkHover hover expectations = traverse_ check =<< expectations where
1278
1332
1279 check expected =
1333 check expected =
1280 case hover of
1334 case hover of
@@ -1317,9 +1371,12 @@ findDefinitionAndHoverTests = let
1317
1371
1318 mkFindTests tests = testGroup "get"
1372 mkFindTests tests = testGroup "get"
1319 [ testGroup "definition" $ mapMaybe fst tests
1373 [ testGroup "definition" $ mapMaybe fst tests
1320− , 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)
1321
1378
1322− test runDef runHover look expect title =
1379+ testM runDef runHover look expect title =
1323 ( runDef $ tst def look expect title
1380 ( runDef $ tst def look expect title
1324 , runHover $ tst hover look expect title ) where
1381 , runHover $ tst hover look expect title ) where
1325 def = (getDefinitions, checkDefs)
1382 def = (getDefinitions, checkDefs)
@@ -1327,87 +1384,100 @@ findDefinitionAndHoverTests = let
1327 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
1384 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out
1328
1385
1329 -- search locations expectations on results
1386 -- search locations expectations on results
1330− 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]
1331− fffL8 = Position 8 4 ;
1388+ fffL8 = Position 12 4 ;
1332− fffL14 = Position 14 7 ;
1389+ fffL14 = Position 18 7 ;
1333− aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]
1390+ aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]
1334− dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]
1391+ dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]
1335− dcL12 = Position 12 11 ;
1392+ dcL12 = Position 16 11 ;
1336− 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’"]]
1337− 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"]]
1338− vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]
1395+ vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6]
1339− opL16 = Position 16 15 ; op = [mkR 17 2 17 4]
1396+ opL16 = Position 20 15 ; op = [mkR 21 2 21 4]
1340− opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]
1397+ opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]
1341− aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]
1398+ aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]
1342− b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]
1399+ b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]
1343− 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"]]
1344− 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"]]
1345− clL25 = Position 25 9
1402+ clL25 = Position 29 9
1346− 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’"]]
1347− dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]
1404+ dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21]
1348− dnbL30 = Position 30 23
1405+ dnbL30 = Position 34 23
1349− 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]
1350− lclL33 = Position 33 22
1407+ lclL33 = Position 37 22
1351− mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14]
1408+ mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14]
1352− mclL37 = Position 37 1
1409+ mclL37 = Position 41 1
1353− spaceL37 = Position 37 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1410+ spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]
1354− docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1411+ docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]
1355 ; constr = [ExpectHoverText ["Monad m"]]
1412 ; constr = [ExpectHoverText ["Monad m"]]
1356− eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1413+ eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]
1357− intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]]
1414+ intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]]
1358− tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1415+ tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]
1359− intL41 = Position 41 20 ; litI = [ExpectHoverText ["7518"]]
1416+ intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]]
1360− chrL36 = Position 37 24 ; litC = [ExpectHoverText ["'f'"]]
1417+ chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]]
1361− txtL8 = Position 8 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1418+ txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]]
1362− lstL43 = Position 43 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1419+ lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]
1363− 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]
1364− 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]
1365 in
1424 in
1366 mkFindTests
1425 mkFindTests
1367− -- def hover look expect
1426+ -- def hover look expect
1368− [ test yes yes fffL4 fff "field in record definition"
1427+ [ test yes yes fffL4 fff "field in record definition"
1369− , test broken broken fffL8 fff "field in record construction #71"
1428+ , test broken broken fffL8 fff "field in record construction #71"
1370− , 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
1371− , test yes yes aaaL14 aaa "top-level name" -- 120
1430+ , test yes yes aaaL14 aaa "top-level name" -- 120
1372− , test yes yes dcL7 tcDC "data constructor record #247"
1431+ , test yes yes dcL7 tcDC "data constructor record #247"
1373− , test yes yes dcL12 tcDC "data constructor plain" -- 121
1432+ , test yes yes dcL12 tcDC "data constructor plain" -- 121
1374− , test yes yes tcL6 tcData "type constructor #248" -- 147
1433+ , test yes yes tcL6 tcData "type constructor #248" -- 147
1375− , test broken yes xtcL5 xtc "type constructor external #248,249"
1434+ , test broken yes xtcL5 xtc "type constructor external #248,249"
1376− , test broken yes xvL20 xvMsg "value external package #249" -- 120
1435+ , test broken yes xvL20 xvMsg "value external package #249" -- 120
1377− , test yes yes vvL16 vv "plain parameter" -- 120
1436+ , test yes yes vvL16 vv "plain parameter" -- 120
1378− , test yes yes aL18 apmp "pattern match name" -- 120
1437+ , test yes yes aL18 apmp "pattern match name" -- 120
1379− , test yes yes opL16 op "top-level operator" -- 120, 123
1438+ , test yes yes opL16 op "top-level operator" -- 120, 123
1380− , test yes yes opL18 opp "parameter operator" -- 120
1439+ , test yes yes opL18 opp "parameter operator" -- 120
1381− , test yes yes b'L19 bp "name in backticks" -- 120
1440+ , test yes yes b'L19 bp "name in backticks" -- 120
1382− , test yes yes clL23 cls "class in instance declaration #250"
1441+ , test yes yes clL23 cls "class in instance declaration #250"
1383− , test yes yes clL25 cls "class in signature #250" -- 147
1442+ , test yes yes clL25 cls "class in signature #250" -- 147
1384− , test broken yes eclL15 ecls "external class in signature #249,250"
1443+ , test broken yes eclL15 ecls "external class in signature #249,250"
1385− , test yes yes dnbL29 dnb "do-notation bind" -- 137
1444+ , test yes yes dnbL29 dnb "do-notation bind" -- 137
1386− , test yes yes dnbL30 dnb "do-notation lookup"
1445+ , test yes yes dnbL30 dnb "do-notation lookup"
1387− , test yes yes lcbL33 lcb "listcomp bind" -- 137
1446+ , test yes yes lcbL33 lcb "listcomp bind" -- 137
1388− , test yes yes lclL33 lcb "listcomp lookup"
1447+ , test yes yes lclL33 lcb "listcomp lookup"
1389− , test yes yes mclL36 mcl "top-level fn 1st clause"
1448+ , test yes yes mclL36 mcl "top-level fn 1st clause"
1390− , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1449+ , test yes yes mclL37 mcl "top-level fn 2nd clause #246"
1391− , test yes yes spaceL37 space "top-level fn on space #315"
1450+ , test yes yes spaceL37 space "top-level fn on space #315"
1392− , test no broken docL41 doc "documentation #7"
1451+ , test no broken docL41 doc "documentation #7"
1393− , test no yes eitL40 kindE "kind of Either #273"
1452+ , test no yes eitL40 kindE "kind of Either #273"
1394− , test no yes intL40 kindI "kind of Int #273"
1453+ , test no yes intL40 kindI "kind of Int #273"
1395− , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1454+ , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"
1396− , test no yes intL41 litI "literal Int in hover info #274"
1455+ , test no yes intL41 litI "literal Int in hover info #274"
1397− , test no yes chrL36 litC "literal Char in hover info #274"
1456+ , test no yes chrL36 litC "literal Char in hover info #274"
1398− , test no yes txtL8 litT "literal Text in hover info #274"
1457+ , test no yes txtL8 litT "literal Text in hover info #274"
1399− , test no yes lstL43 litL "literal List in hover info #274"
1458+ , test no yes lstL43 litL "literal List in hover info #274"
1400− , test no yes docL41 constr "type constraint in hover info #283"
1459+ , test no yes docL41 constr "type constraint in hover info #283"
1401− , test broken broken outL45 outSig "top-level signature #310"
1460+ , test broken broken outL45 outSig "top-level signature #310"
1402− , 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)"
1403 ]
1464 ]
1404 where yes, broken :: (TestTree -> Maybe TestTree)
1465 where yes, broken :: (TestTree -> Maybe TestTree)
1405 yes = Just -- test should run and pass
1466 yes = Just -- test should run and pass
1406 broken = Just . (`xfail` "known broken")
1467 broken = Just . (`xfail` "known broken")
1407 no = const Nothing -- don't run this test at all
1468 no = const Nothing -- don't run this test at all
1408
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+
1409pluginTests :: TestTree
1478pluginTests :: TestTree
1410−pluginTests = testSessionWait "plugins" $ do
1479+pluginTests = (`xfail8101` "known broken (#556)")
1480+ $ testSessionWait "plugins" $ do
1411 let content =
1481 let content =
1412 T.unlines
1482 T.unlines
1413 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
1483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"
@@ -1421,7 +1491,7 @@ pluginTests = testSessionWait "plugins" $ do
1421 , "foo :: Int -> Int -> Int"
1491 , "foo :: Int -> Int -> Int"
1422 , "foo a b = a + c"
1492 , "foo a b = a + c"
1423 ]
1493 ]
1424− _ <- openDoc' "Testing.hs" "haskell" content
1494+ _ <- createDoc "Testing.hs" "haskell" content
1425 expectDiagnostics
1495 expectDiagnostics
1426 [ ( "Testing.hs",
1496 [ ( "Testing.hs",
1427 [(DsError, (8, 14), "Variable not in scope: c")]
1497 [(DsError, (8, 14), "Variable not in scope: c")]
@@ -1448,7 +1518,7 @@ cppTests =
1448 run $ expectError content (2, 1)
1518 run $ expectError content (2, 1)
1449 )
1519 )
1450 , testSessionWait "cpp-ghcide" $ do
1520 , testSessionWait "cpp-ghcide" $ do
1451− _ <- openDoc' "A.hs" "haskell" $ T.unlines
1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines
1452 ["{-# LANGUAGE CPP #-}"
1522 ["{-# LANGUAGE CPP #-}"
1453 ,"main ="
1523 ,"main ="
1454 ,"#ifdef __GHCIDE__"
1524 ,"#ifdef __GHCIDE__"
@@ -1462,7 +1532,7 @@ cppTests =
1462 where
1532 where
1463 expectError :: T.Text -> Cursor -> Session ()
1533 expectError :: T.Text -> Cursor -> Session ()
1464 expectError content cursor = do
1534 expectError content cursor = do
1465− _ <- openDoc' "Testing.hs" "haskell" content
1535+ _ <- createDoc "Testing.hs" "haskell" content
1466 expectDiagnostics
1536 expectDiagnostics
1467 [ ( "Testing.hs",
1537 [ ( "Testing.hs",
1468 [(DsError, cursor, "error: unterminated")]
1538 [(DsError, cursor, "error: unterminated")]
@@ -1478,13 +1548,43 @@ preprocessorTests = testSessionWait "preprocessor" $ do
1478 , "module Testing where"
1548 , "module Testing where"
1479 , "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
1480 ]
1550 ]
1481− _ <- openDoc' "Testing.hs" "haskell" content
1551+ _ <- createDoc "Testing.hs" "haskell" content
1482 expectDiagnostics
1552 expectDiagnostics
1483 [ ( "Testing.hs",
1553 [ ( "Testing.hs",
1484 [(DsError, (2, 8), "Variable not in scope: z")]
1554 [(DsError, (2, 8), "Variable not in scope: z")]
1485 )
1555 )
1486 ]
1556 ]
1487
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+
1488thTests :: TestTree
1588thTests :: TestTree
1489thTests =
1589thTests =
1490 testGroup
1590 testGroup
@@ -1510,8 +1610,8 @@ thTests =
1510 "b :: Integer",
1610 "b :: Integer",
1511 "b = $(litE $ IntegerL $ a) + n"
1611 "b = $(litE $ IntegerL $ a) + n"
1512 ]
1612 ]
1513− _ <- openDoc' "A.hs" "haskell" sourceA
1613+ _ <- createDoc "A.hs" "haskell" sourceA
1514− _ <- openDoc' "B.hs" "haskell" sourceB
1614+ _ <- createDoc "B.hs" "haskell" sourceB
1515 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
1615 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]
1516 , testSessionWait "newtype-closure" $ do
1616 , testSessionWait "newtype-closure" $ do
1517 let sourceA =
1617 let sourceA =
@@ -1531,8 +1631,8 @@ thTests =
1531 ,"import A"
1631 ,"import A"
1532 ,"b :: Int"
1632 ,"b :: Int"
1533 ,"b = $( a )" ]
1633 ,"b = $( a )" ]
1534− _ <- openDoc' "A.hs" "haskell" sourceA
1634+ _ <- createDoc "A.hs" "haskell" sourceA
1535− _ <- openDoc' "B.hs" "haskell" sourceB
1635+ _ <- createDoc "B.hs" "haskell" sourceB
1536 return ()
1636 return ()
1537 ]
1637 ]
1538
1638
@@ -1541,7 +1641,7 @@ completionTests
1541 = testGroup "completion"
1641 = testGroup "completion"
1542 [ testSessionWait "variable" $ do
1642 [ testSessionWait "variable" $ do
1543 let source = T.unlines ["module A where", "f = hea"]
1643 let source = T.unlines ["module A where", "f = hea"]
1544− docId <- openDoc' "A.hs" "haskell" source
1644+ docId <- createDoc "A.hs" "haskell" source
1545 compls <- getCompletions docId (Position 1 7)
1645 compls <- getCompletions docId (Position 1 7)
1546 liftIO $ map dropDocs compls @?=
1646 liftIO $ map dropDocs compls @?=
1547 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
1647 [complItem "head" (Just CiFunction) (Just "[a] -> a")]
@@ -1553,7 +1653,7 @@ completionTests
1553 ]
1653 ]
1554 , testSessionWait "constructor" $ do
1654 , testSessionWait "constructor" $ do
1555 let source = T.unlines ["module A where", "f = Tru"]
1655 let source = T.unlines ["module A where", "f = Tru"]
1556− docId <- openDoc' "A.hs" "haskell" source
1656+ docId <- createDoc "A.hs" "haskell" source
1557 compls <- getCompletions docId (Position 1 7)
1657 compls <- getCompletions docId (Position 1 7)
1558 liftIO $ map dropDocs compls @?=
1658 liftIO $ map dropDocs compls @?=
1559 [ complItem "True" (Just CiConstructor) (Just "Bool")
1659 [ complItem "True" (Just CiConstructor) (Just "Bool")
@@ -1565,7 +1665,7 @@ completionTests
1565 ]
1665 ]
1566 , testSessionWait "type" $ do
1666 , testSessionWait "type" $ do
1567 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 = ()"]
1568− docId <- openDoc' "A.hs" "haskell" source
1668+ docId <- createDoc "A.hs" "haskell" source
1569 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1669 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]
1570 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"]]
1571 compls <- getCompletions docId (Position 2 7)
1671 compls <- getCompletions docId (Position 2 7)
@@ -1582,7 +1682,7 @@ completionTests
1582 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1682 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]
1583 , testSessionWait "qualified" $ do
1683 , testSessionWait "qualified" $ do
1584 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 = ()"]
1585− docId <- openDoc' "A.hs" "haskell" source
1685+ docId <- createDoc "A.hs" "haskell" source
1586 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1686 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]
1587 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"]]
1588 compls <- getCompletions docId (Position 2 15)
1688 compls <- getCompletions docId (Position 2 15)
@@ -1596,9 +1696,30 @@ completionTests
1596 ]
1696 ]
1597 , testSessionWait "keyword" $ do
1697 , testSessionWait "keyword" $ do
1598 let source = T.unlines ["module A where", "f = newty"]
1698 let source = T.unlines ["module A where", "f = newty"]
1599− docId <- openDoc' "A.hs" "haskell" source
1699+ docId <- createDoc "A.hs" "haskell" source
1600 compls <- getCompletions docId (Position 1 9)
1700 compls <- getCompletions docId (Position 1 9)
1601 liftIO $ compls @?= [keywordItem "newtype"]
1701 liftIO $ compls @?= [keywordItem "newtype"]
1702+ , testSessionWait "type context" $ do
1703+ let source = T.unlines
1704+ [ "{-# OPTIONS_GHC -Wunused-binds #-}"
1705+ , "module A () where"
1706+ , "f = f"
1707+ ]
1708+ docId <- createDoc "A.hs" "haskell" source
1709+ expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]
1710+ changeDoc docId
1711+ [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
1712+ [ "{-# OPTIONS_GHC -Wunused-binds #-}"
1713+ , "module A () where"
1714+ , "f = f"
1715+ , "g :: Intege"
1716+ ]
1717+ ]
1718+ -- At this point the module parses but does not typecheck.
1719+ -- This should be sufficient to detect that we are in a
1720+ -- type context and only show the completion to the type.
1721+ compls <- getCompletions docId (Position 3 11)
1722+ liftIO $ map dropDocs compls @?= [complItem "Integer"(Just CiStruct) (Just "*")]
1602 ]
1723 ]
1603 where
1724 where
1604 dropDocs :: CompletionItem -> CompletionItem
1725 dropDocs :: CompletionItem -> CompletionItem
@@ -1606,6 +1727,7 @@ completionTests
1606 complItem label kind ty = CompletionItem
1727 complItem label kind ty = CompletionItem
1607 { _label = label
1728 { _label = label
1608 , _kind = kind
1729 , _kind = kind
1730+ , _tags = List []
1609 , _detail = (":: " <>) <$> ty
1731 , _detail = (":: " <>) <$> ty
1610 , _documentation = Nothing
1732 , _documentation = Nothing
1611 , _deprecated = Nothing
1733 , _deprecated = Nothing
@@ -1623,6 +1745,7 @@ completionTests
1623 keywordItem label = CompletionItem
1745 keywordItem label = CompletionItem
1624 { _label = label
1746 { _label = label
1625 , _kind = Just CiKeyword
1747 , _kind = Just CiKeyword
1748+ , _tags = List []
1626 , _detail = Nothing
1749 , _detail = Nothing
1627 , _documentation = Nothing
1750 , _documentation = Nothing
1628 , _deprecated = Nothing
1751 , _deprecated = Nothing
@@ -1650,7 +1773,7 @@ outlineTests = testGroup
1650 "outline"
1773 "outline"
1651 [ testSessionWait "type class" $ do
1774 [ testSessionWait "type class" $ do
1652 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"]
1653− docId <- openDoc' "A.hs" "haskell" source
1776+ docId <- createDoc "A.hs" "haskell" source
1654 symbols <- getDocumentSymbols docId
1777 symbols <- getDocumentSymbols docId
1655 liftIO $ symbols @?= Left
1778 liftIO $ symbols @?= Left
1656 [ moduleSymbol
1779 [ moduleSymbol
@@ -1663,7 +1786,7 @@ outlineTests = testGroup
1663 ]
1786 ]
1664 , testSessionWait "type class instance " $ do
1787 , testSessionWait "type class instance " $ do
1665 let source = T.unlines ["class A a where", "instance A () where"]
1788 let source = T.unlines ["class A a where", "instance A () where"]
1666− docId <- openDoc' "A.hs" "haskell" source
1789+ docId <- createDoc "A.hs" "haskell" source
1667 symbols <- getDocumentSymbols docId
1790 symbols <- getDocumentSymbols docId
1668 liftIO $ symbols @?= Left
1791 liftIO $ symbols @?= Left
1669 [ classSymbol "A a" (R 0 0 0 15) []
1792 [ classSymbol "A a" (R 0 0 0 15) []
@@ -1671,7 +1794,7 @@ outlineTests = testGroup
1671 ]
1794 ]
1672 , testSessionWait "type family" $ do
1795 , testSessionWait "type family" $ do
1673 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1796 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]
1674− docId <- openDoc' "A.hs" "haskell" source
1797+ docId <- createDoc "A.hs" "haskell" source
1675 symbols <- getDocumentSymbols docId
1798 symbols <- getDocumentSymbols docId
1676 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)]
1677 , testSessionWait "type family instance " $ do
1800 , testSessionWait "type family instance " $ do
@@ -1680,7 +1803,7 @@ outlineTests = testGroup
1680 , "type family A a"
1803 , "type family A a"
1681 , "type instance A () = ()"
1804 , "type instance A () = ()"
1682 ]
1805 ]
1683− docId <- openDoc' "A.hs" "haskell" source
1806+ docId <- createDoc "A.hs" "haskell" source
1684 symbols <- getDocumentSymbols docId
1807 symbols <- getDocumentSymbols docId
1685 liftIO $ symbols @?= Left
1808 liftIO $ symbols @?= Left
1686 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
1809 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)
@@ -1688,7 +1811,7 @@ outlineTests = testGroup
1688 ]
1811 ]
1689 , testSessionWait "data family" $ do
1812 , testSessionWait "data family" $ do
1690 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1813 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]
1691− docId <- openDoc' "A.hs" "haskell" source
1814+ docId <- createDoc "A.hs" "haskell" source
1692 symbols <- getDocumentSymbols docId
1815 symbols <- getDocumentSymbols docId
1693 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)]
1694 , testSessionWait "data family instance " $ do
1817 , testSessionWait "data family instance " $ do
@@ -1697,7 +1820,7 @@ outlineTests = testGroup
1697 , "data family A a"
1820 , "data family A a"
1698 , "data instance A () = A ()"
1821 , "data instance A () = A ()"
1699 ]
1822 ]
1700− docId <- openDoc' "A.hs" "haskell" source
1823+ docId <- createDoc "A.hs" "haskell" source
1701 symbols <- getDocumentSymbols docId
1824 symbols <- getDocumentSymbols docId
1702 liftIO $ symbols @?= Left
1825 liftIO $ symbols @?= Left
1703 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
1826 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)
@@ -1705,36 +1828,36 @@ outlineTests = testGroup
1705 ]
1828 ]
1706 , testSessionWait "constant" $ do
1829 , testSessionWait "constant" $ do
1707 let source = T.unlines ["a = ()"]
1830 let source = T.unlines ["a = ()"]
1708− docId <- openDoc' "A.hs" "haskell" source
1831+ docId <- createDoc "A.hs" "haskell" source
1709 symbols <- getDocumentSymbols docId
1832 symbols <- getDocumentSymbols docId
1710 liftIO $ symbols @?= Left
1833 liftIO $ symbols @?= Left
1711 [docSymbol "a" SkFunction (R 0 0 0 6)]
1834 [docSymbol "a" SkFunction (R 0 0 0 6)]
1712 , testSessionWait "pattern" $ do
1835 , testSessionWait "pattern" $ do
1713 let source = T.unlines ["Just foo = Just 21"]
1836 let source = T.unlines ["Just foo = Just 21"]
1714− docId <- openDoc' "A.hs" "haskell" source
1837+ docId <- createDoc "A.hs" "haskell" source
1715 symbols <- getDocumentSymbols docId
1838 symbols <- getDocumentSymbols docId
1716 liftIO $ symbols @?= Left
1839 liftIO $ symbols @?= Left
1717 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1840 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]
1718 , testSessionWait "pattern with type signature" $ do
1841 , testSessionWait "pattern with type signature" $ do
1719 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1842 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]
1720− docId <- openDoc' "A.hs" "haskell" source
1843+ docId <- createDoc "A.hs" "haskell" source
1721 symbols <- getDocumentSymbols docId
1844 symbols <- getDocumentSymbols docId
1722 liftIO $ symbols @?= Left
1845 liftIO $ symbols @?= Left
1723 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1846 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]
1724 , testSessionWait "function" $ do
1847 , testSessionWait "function" $ do
1725 let source = T.unlines ["a x = ()"]
1848 let source = T.unlines ["a x = ()"]
1726− docId <- openDoc' "A.hs" "haskell" source
1849+ docId <- createDoc "A.hs" "haskell" source
1727 symbols <- getDocumentSymbols docId
1850 symbols <- getDocumentSymbols docId
1728 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1851 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]
1729 , testSessionWait "type synonym" $ do
1852 , testSessionWait "type synonym" $ do
1730 let source = T.unlines ["type A = Bool"]
1853 let source = T.unlines ["type A = Bool"]
1731− docId <- openDoc' "A.hs" "haskell" source
1854+ docId <- createDoc "A.hs" "haskell" source
1732 symbols <- getDocumentSymbols docId
1855 symbols <- getDocumentSymbols docId
1733 liftIO $ symbols @?= Left
1856 liftIO $ symbols @?= Left
1734 [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)]
1735 , testSessionWait "datatype" $ do
1858 , testSessionWait "datatype" $ do
1736 let source = T.unlines ["data A = C"]
1859 let source = T.unlines ["data A = C"]
1737− docId <- openDoc' "A.hs" "haskell" source
1860+ docId <- createDoc "A.hs" "haskell" source
1738 symbols <- getDocumentSymbols docId
1861 symbols <- getDocumentSymbols docId
1739 liftIO $ symbols @?= Left
1862 liftIO $ symbols @?= Left
1740 [ docSymbolWithChildren "A"
1863 [ docSymbolWithChildren "A"
@@ -1742,9 +1865,21 @@ outlineTests = testGroup
1742 (R 0 0 0 10)
1865 (R 0 0 0 10)
1743 [docSymbol "C" SkConstructor (R 0 9 0 10)]
1866 [docSymbol "C" SkConstructor (R 0 9 0 10)]
1744 ]
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+ ]
1745 , testSessionWait "import" $ do
1880 , testSessionWait "import" $ do
1746 let source = T.unlines ["import Data.Maybe"]
1881 let source = T.unlines ["import Data.Maybe"]
1747− docId <- openDoc' "A.hs" "haskell" source
1882+ docId <- createDoc "A.hs" "haskell" source
1748 symbols <- getDocumentSymbols docId
1883 symbols <- getDocumentSymbols docId
1749 liftIO $ symbols @?= Left
1884 liftIO $ symbols @?= Left
1750 [docSymbolWithChildren "imports"
1885 [docSymbolWithChildren "imports"
@@ -1755,7 +1890,7 @@ outlineTests = testGroup
1755 ]
1890 ]
1756 , testSessionWait "multiple import" $ do
1891 , testSessionWait "multiple import" $ do
1757 let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]
1892 let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]
1758− docId <- openDoc' "A.hs" "haskell" source
1893+ docId <- createDoc "A.hs" "haskell" source
1759 symbols <- getDocumentSymbols docId
1894 symbols <- getDocumentSymbols docId
1760 liftIO $ symbols @?= Left
1895 liftIO $ symbols @?= Left
1761 [docSymbolWithChildren "imports"
1896 [docSymbolWithChildren "imports"
@@ -1770,7 +1905,7 @@ outlineTests = testGroup
1770 [ "{-# language ForeignFunctionInterface #-}"
1905 [ "{-# language ForeignFunctionInterface #-}"
1771 , "foreign import ccall \"a\" a :: Int"
1906 , "foreign import ccall \"a\" a :: Int"
1772 ]
1907 ]
1773− docId <- openDoc' "A.hs" "haskell" source
1908+ docId <- createDoc "A.hs" "haskell" source
1774 symbols <- getDocumentSymbols docId
1909 symbols <- getDocumentSymbols docId
1775 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)]
1776 , testSessionWait "foreign export" $ do
1911 , testSessionWait "foreign export" $ do
@@ -1778,7 +1913,7 @@ outlineTests = testGroup
1778 [ "{-# language ForeignFunctionInterface #-}"
1913 [ "{-# language ForeignFunctionInterface #-}"
1779 , "foreign export ccall odd :: Int -> Bool"
1914 , "foreign export ccall odd :: Int -> Bool"
1780 ]
1915 ]
1781− docId <- openDoc' "A.hs" "haskell" source
1916+ docId <- createDoc "A.hs" "haskell" source
1782 symbols <- getDocumentSymbols docId
1917 symbols <- getDocumentSymbols docId
1783 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)]
1784 ]
1919 ]
@@ -1791,6 +1926,8 @@ outlineTests = testGroup
1791 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1926 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing
1792 docSymbolWithChildren name kind loc cc =
1927 docSymbolWithChildren name kind loc cc =
1793 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)
1794 moduleSymbol name loc cc = DocumentSymbol name
1931 moduleSymbol name loc cc = DocumentSymbol name
1795 Nothing
1932 Nothing
1796 SkFile
1933 SkFile
@@ -1812,8 +1949,16 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')
1812xfail :: TestTree -> String -> TestTree
1949xfail :: TestTree -> String -> TestTree
1813xfail = flip expectFailBecause
1950xfail = flip expectFailBecause
1814
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+
1815data Expect
1959data Expect
1816 = ExpectRange Range -- Both gotoDef and hover should report this range
1960 = ExpectRange Range -- Both gotoDef and hover should report this range
1961+ | ExpectLocation Location
1817-- | ExpectDefRange Range -- Only gotoDef should report this range
1962-- | ExpectDefRange Range -- Only gotoDef should report this range
1818 | ExpectHoverRange Range -- Only hover should report this range
1963 | ExpectHoverRange Range -- Only hover should report this range
1819 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
1964 | ExpectHoverText [T.Text] -- the hover message must contain these snippets
@@ -1826,6 +1971,9 @@ data Expect
1826mkR :: Int -> Int -> Int -> Int -> Expect
1971mkR :: Int -> Int -> Int -> Int -> Expect
1827mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
1972mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn
1828
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+
1829haddockTests :: TestTree
1977haddockTests :: TestTree
1830haddockTests
1978haddockTests
1831 = testGroup "haddock"
1979 = testGroup "haddock"
@@ -1885,6 +2033,7 @@ cradleTests :: TestTree
1885cradleTests = testGroup "cradle"
2033cradleTests = testGroup "cradle"
1886 [testGroup "dependencies" [sessionDepsArePickedUp]
2034 [testGroup "dependencies" [sessionDepsArePickedUp]
1887 ,testGroup "loading" [loadCradleOnlyonce]
2035 ,testGroup "loading" [loadCradleOnlyonce]
2036+ ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]
1888 ]
2037 ]
1889
2038
1890loadCradleOnlyonce :: TestTree
2039loadCradleOnlyonce :: TestTree
@@ -1899,17 +2048,53 @@ loadCradleOnlyonce = testGroup "load cradle only once"
1899 test dir
2048 test dir
1900 implicit dir = test dir
2049 implicit dir = test dir
1901 test _dir = do
2050 test _dir = do
1902− doc <- openDoc' "B.hs" "haskell" "module B where\nimport Data.Foo"
2051+ doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"
1903 msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2052 msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
1904 liftIO $ length msgs @?= 1
2053 liftIO $ length msgs @?= 1
1905 changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]
2054 changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]
1906 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2055 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
1907 liftIO $ length msgs @?= 0
2056 liftIO $ length msgs @?= 0
1908− _ <- openDoc' "A.hs" "haskell" "module A where\nimport Bar"
2057+ _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"
1909 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
2058 msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))
1910 liftIO $ length msgs @?= 0
2059 liftIO $ length msgs @?= 0
1911
2060
1912
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+
1913cradleLoadedMessage :: Session FromServerMessage
2098cradleLoadedMessage :: Session FromServerMessage
1914cradleLoadedMessage = satisfy $ \case
2099cradleLoadedMessage = satisfy $ \case
1915 NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod
2100 NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod
@@ -1918,6 +2103,56 @@ cradleLoadedMessage = satisfy $ \case
1918cradleLoadedMethod :: T.Text
2103cradleLoadedMethod :: T.Text
1919cradleLoadedMethod = "ghcide/cradle/loaded"
2104cradleLoadedMethod = "ghcide/cradle/loaded"
1920
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+
1921sessionDepsArePickedUp :: TestTree
2156sessionDepsArePickedUp :: TestTree
1922sessionDepsArePickedUp = testSession'
2157sessionDepsArePickedUp = testSession'
1923 "session-deps-are-picked-up"
2158 "session-deps-are-picked-up"
@@ -1927,7 +2162,7 @@ sessionDepsArePickedUp = testSession'
1927 (dir </> "hie.yaml")
2162 (dir </> "hie.yaml")
1928 "cradle: {direct: {arguments: []}}"
2163 "cradle: {direct: {arguments: []}}"
1929 -- Open without OverloadedStrings and expect an error.
2164 -- Open without OverloadedStrings and expect an error.
1930− doc <- openDoc' "Foo.hs" "haskell" fooContent
2165+ doc <- createDoc "Foo.hs" "haskell" fooContent
1931 expectDiagnostics
2166 expectDiagnostics
1932 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
2167 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]
1933 -- Update hie.yaml to enable OverloadedStrings.
2168 -- Update hie.yaml to enable OverloadedStrings.
@@ -1962,6 +2197,9 @@ sessionDepsArePickedUp = testSession'
1962testSession :: String -> Session () -> TestTree
2197testSession :: String -> Session () -> TestTree
1963testSession name = testCase name . run
2198testSession name = testCase name . run
1964
2199
2200+testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree
2201+testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix
2202+
1965testSession' :: String -> (FilePath -> Session ()) -> TestTree
2203testSession' :: String -> (FilePath -> Session ()) -> TestTree
1966testSession' name = testCase name . run'
2204testSession' name = testCase name . run'
1967
2205
@@ -1996,6 +2234,19 @@ mkRange a b c d = Range (Position a b) (Position c d)
1996run :: Session a -> IO a
2234run :: Session a -> IO a
1997run s = withTempDir $ \dir -> runInDir dir s
2235run s = withTempDir $ \dir -> runInDir dir s
1998
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+
1999run' :: (FilePath -> Session a) -> IO a
2250run' :: (FilePath -> Session a) -> IO a
2000run' s = withTempDir $ \dir -> runInDir dir (s dir)
2251run' s = withTempDir $ \dir -> runInDir dir (s dir)
2001
2252
@@ -2007,6 +2258,7 @@ runInDir dir s = do
2007 -- 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
2008 createDirectoryIfMissing True $ dir ++ "/Data"
2259 createDirectoryIfMissing True $ dir ++ "/Data"
2009
2260
2261+
2010 let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
2262 let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]
2011 -- HIE calls getXgdDirectory which assumes that HOME is set.
2263 -- HIE calls getXgdDirectory which assumes that HOME is set.
2012 -- Only sets HOME if it wasn't already set.
2264 -- Only sets HOME if it wasn't already set.
@@ -2024,7 +2276,7 @@ runInDir dir s = do
2024openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
2276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
2025openTestDataDoc path = do
2277openTestDataDoc path = do
2026 source <- liftIO $ readFileUtf8 $ "test/data" </> path
2278 source <- liftIO $ readFileUtf8 $ "test/data" </> path
2027− openDoc' path "haskell" source
2279+ createDoc path "haskell" source
2028
2280
2029findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
2281findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]
2030findCodeActions doc range expectedTitles = do
2282findCodeActions doc range expectedTitles = do
@@ -2052,24 +2304,19 @@ findCodeAction doc range t = head <$> findCodeActions doc range [t]
2052unitTests :: TestTree
2304unitTests :: TestTree
2053unitTests = do
2305unitTests = do
2054 testGroup "Unit"
2306 testGroup "Unit"
2055− [ testCase "empty file path" $
2307+ [ testCase "empty file path does NOT work with the empty String literal" $
2056− 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 ""
2057 ]
2318 ]
2058
2319
2059−-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events
2060−openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
2061−openDoc' fp name contents = do
2062− res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents
2063− -- Needed as ghcide sets up and relies on WatchedFiles but lsp-test does not track them
2064− sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])
2065− return res
2066−
2067−-- | Version of 'LSPTest.openDoc'' that does not send WatchedFiles events for files outside the workspace
2068−openDoc'' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
2069−-- At the moment this is just LSPTest.openDoc' but it may change in the future
2070−-- when/if lsp-test implements WatchedFiles
2071−openDoc'' = LSPTest.openDoc'
2072−
2073positionMappingTests :: TestTree
2320positionMappingTests :: TestTree
2074positionMappingTests =
2321positionMappingTests =
2075 testGroup "position mapping"
2322 testGroup "position mapping"
@@ -2239,11 +2486,11 @@ nthLine i r
2239 | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
2486 | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
2240 | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r
2487 | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r
2241
2488
2242−getWatchedFilesSubscriptionsUntilProgressEnd :: Session [Maybe Value]
2489+getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]
2243−getWatchedFilesSubscriptionsUntilProgressEnd = do
2490+getWatchedFilesSubscriptionsUntil = do
2244− msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @WorkDoneProgressEndNotification)
2491+ msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)
2245 return
2492 return
2246 [ args
2493 [ args
2247− | Just (RequestMessage{_params = RegistrationParams (List regs)}) <- msgs
2494+ | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs
2248 , Registration _id WorkspaceDidChangeWatchedFiles args <- regs
2495 , Registration _id WorkspaceDidChangeWatchedFiles args <- regs
2249 ]
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 '‘' = '\''