286635b...master · ghcide

git.iko.soy/ghcide

on master help sign in

.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+4

@@ -4,3 +4,7 @@ dist-newstyle/

4cabal.project.local

5*~

6*.lock

7+/.tasty-rerun-log

8+.vscode

9+/.hlint-*

10+bench/example

.hlint.yaml+5−1

@@ -73,18 +73,22 @@

73 - {name: ViewPatterns, within: []}

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

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

CHANGELOG.md+20

@@ -1,5 +1,25 @@

1### unreleased

3+### 0.2.0 (2020-06-02)

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)

5* Code action for inserting new definitions (see #309).

25* Code action for inserting new definitions (see #309).

README.md+62−3

@@ -25,13 +25,40 @@ There are more details about our approach [in this blog post](https://4ta.uk/p/s

25| Display type and source module of values | hover |

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) |

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

30### Install `ghcide`

47### Install `ghcide`

32#### With Nix

49#### With Nix

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.

36#### With Cabal or Stack

63#### With Cabal or Stack

@@ -64,6 +91,10 @@ The `ghcide` executable mostly relies on [`hie-bios`](https://github.com/mpicker

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.

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

69You can install the VSCode extension from the [VSCode

100You can install the VSCode extension from the [VSCode

@@ -203,7 +234,11 @@ Add this to your coc-settings.json (which you can edit with :CocConfig):

203```

234```

204

235

205Here's a nice article on setting up neovim and coc: [Vim and Haskell in

236Here's a nice article on setting up neovim and coc: [Vim and Haskell in

206−2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/)

237+2019](http://marco-lopes.com/articles/Vim-and-Haskell-in-2019/) (this is actually for haskell-ide, not ghcide)

238+

239+Here is a Docker container that pins down the build and configuration for

240+Neovim and ghcide on a minimal Debian 10 base system:

241+[docker-ghcide-neovim](https://github.com/carlohamalainen/docker-ghcide-neovim/).

207

242

208### SpaceVim

243### SpaceVim

209

244

@@ -248,10 +283,32 @@ Add this to your coc-settings.json (which you can edit with :CocConfig):

248This example above describes a setup in which `ghcide` is installed

283This example above describes a setup in which `ghcide` is installed

249using `stack install ghcide` within a project.

284using `stack install ghcide` within a project.

250

285

286+### Using with Kakoune

287+

288+Install [kak-lsp](https://github.com/ul/kak-lsp).

289+

290+Change `kak-lsp.toml` to include this:

291+

292+```toml

293+[language.haskell]

294+filetypes = ["haskell"]

295+roots = ["Setup.hs", "stack.yaml", "*.cabal", "cabal.project", "hie.yaml"]

296+command = "ghcide"

297+args = ["--lsp"]

298+```

299+

251## Hacking on ghcide

300## Hacking on ghcide

252

301

253To build and work on `ghcide` itself, you can use Stack or cabal, e.g.,

302To build and work on `ghcide` itself, you can use Stack or cabal, e.g.,

254running `stack test` will execute the test suite.

303running `stack test` will execute the test suite.

304+If you are using Windows, you should disable the `auto.crlf` setting and configure your editor to use LF line endings, directly or making it use the existing `.editor-config`.

305+

306+If you are chasing down test failures, you can use the tasty-rerun feature by running tests as

307+

308+ stack --stack-yaml=stack84.yaml test --test-arguments "--rerun"

309+

310+This writes a log file called `.tasty-rerun-log` of the failures, and only runs those.

311+See the [tasty-rerun](https://hackage.haskell.org/package/tasty-rerun-1.1.17/docs/Test-Tasty-Ingredients-Rerun.html) documentation for other options.

255

312

256### Building the extension

313### Building the extension

257

314

@@ -268,8 +325,10 @@ Now opening a `.hs` file should work with `ghcide`.

268

325

269## History and relationship to other Haskell IDE's

326## History and relationship to other Haskell IDE's

270

327

328+The teams behind this project and the [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme) have agreed to join forces under the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server), see the [original announcement](https://neilmitchell.blogspot.com/2020/01/one-haskell-ide-to-rule-them-all.html). The technical work is ongoing, with the likely model being that this project serves as the core, while plugins and integrations are kept in the [`haskell-language-server` project](https://github.com/haskell/haskell-language-server).

329+

271The code behind `ghcide` was originally developed by [Digital Asset](https://digitalasset.com/) as part of the [DAML programming language](https://github.com/digital-asset/daml). DAML is a smart contract language targeting distributed-ledger runtimes, based on [GHC](https://www.haskell.org/ghc/) with custom language extensions. The DAML programming language has [an IDE](https://webide.daml.com/), and work was done to separate off a reusable Haskell-only IDE (what is now `ghcide`) which the [DAML IDE then builds upon](https://github.com/digital-asset/daml/tree/master/compiler/damlc). Since that time, there have been various [non-Digital Asset contributors](https://github.com/digital-asset/ghcide/graphs/contributors), in addition to continued investment by Digital Asset. All contributions require a [Contributor License Agreement](https://cla.digitalasset.com/digital-asset/ghcide) that states you license the code under the [Apache License](LICENSE).

330The code behind `ghcide` was originally developed by [Digital Asset](https://digitalasset.com/) as part of the [DAML programming language](https://github.com/digital-asset/daml). DAML is a smart contract language targeting distributed-ledger runtimes, based on [GHC](https://www.haskell.org/ghc/) with custom language extensions. The DAML programming language has [an IDE](https://webide.daml.com/), and work was done to separate off a reusable Haskell-only IDE (what is now `ghcide`) which the [DAML IDE then builds upon](https://github.com/digital-asset/daml/tree/master/compiler/damlc). Since that time, there have been various [non-Digital Asset contributors](https://github.com/digital-asset/ghcide/graphs/contributors), in addition to continued investment by Digital Asset. All contributions require a [Contributor License Agreement](https://cla.digitalasset.com/digital-asset/ghcide) that states you license the code under the [Apache License](LICENSE).

272

331

273−The Haskell community [has](https://github.com/DanielG/ghc-mod) [various](https://github.com/chrisdone/intero) [IDE](https://github.com/rikvdkleij/intellij-haskell) [choices](http://leksah.org/), but the one that has been gathering momentum is [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme). Our project owes a debt of gratitude to the `haskell-ide-engine`. We reuse libraries from their ecosystem, including [`hie-bios`](https://github.com/mpickering/hie-bios#readme) (a likely future environment setup layer in `haskell-ide-engine`), [`haskell-lsp`](https://github.com/alanz/haskell-lsp#readme) and [`lsp-test`](https://github.com/bubba/lsp-test#readme) (the `haskell-ide-engine` [LSP protocol](https://microsoft.github.io/language-server-protocol/) pieces). We make heavy use of their contributions to GHC itself, in particular the work to make GHC take string buffers rather than files. While `ghcide` is not a part of `haskell-ide-engine`, we feel it _could_ form the core of a future version - but such decisions are up to the `haskell-ide-engine` contributors.

332+The Haskell community [has](https://github.com/DanielG/ghc-mod) [various](https://github.com/chrisdone/intero) [IDE](https://github.com/rikvdkleij/intellij-haskell) [choices](http://leksah.org/), but the one that had been gathering momentum is [`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine#readme). Our project owes a debt of gratitude to the `haskell-ide-engine`. We reuse libraries from their ecosystem, including [`hie-bios`](https://github.com/mpickering/hie-bios#readme) (a likely future environment setup layer in `haskell-ide-engine`), [`haskell-lsp`](https://github.com/alanz/haskell-lsp#readme) and [`lsp-test`](https://github.com/bubba/lsp-test#readme) (the `haskell-ide-engine` [LSP protocol](https://microsoft.github.io/language-server-protocol/) pieces). We make heavy use of their contributions to GHC itself, in particular the work to make GHC take string buffers rather than files.

274

333

275The best summary of the architecture of `ghcide` is available [this talk](https://www.youtube.com/watch?v=cijsaeWNf2E&list=PLxxF72uPfQVRdAsvj7THoys-nVj-oc4Ss) ([slides](https://ndmitchell.com/downloads/slides-making_a_haskell_ide-07_sep_2019.pdf)), given at [MuniHac 2019](https://munihac.de/2019.html). However, since that talk the project has renamed from `hie-core` to `ghcide`, and the repo has moved to [this location](https://github.com/digital-asset/ghcide/).

334The best summary of the architecture of `ghcide` is available [this talk](https://www.youtube.com/watch?v=cijsaeWNf2E&list=PLxxF72uPfQVRdAsvj7THoys-nVj-oc4Ss) ([slides](https://ndmitchell.com/downloads/slides-making_a_haskell_ide-07_sep_2019.pdf)), given at [MuniHac 2019](https://munihac.de/2019.html). However, since that talk the project has renamed from `hie-core` to `ghcide`, and the repo has moved to [this location](https://github.com/digital-asset/ghcide/).

azure-pipelines.yml+3−184

@@ -4,6 +4,7 @@ trigger:

4 branches:

5 include:

6 - master

7+ - azure*

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

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 #-}

5+{- An automated benchmark built around the simple experiment described in:

7+ > https://neilmitchell.blogspot.com/2020/05/fixing-space-leaks-in-ghcide.html

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+4

@@ -12,6 +12,8 @@ data Arguments = Arguments

12 ,argFiles :: [FilePath]

13 ,argsVersion :: Bool

14 ,argsShakeProfiling :: Maybe FilePath

15+ ,argsTesting :: Bool

16+ ,argsThreads :: Int

15 }

17 }

17getArguments :: IO Arguments

19getArguments :: IO Arguments

@@ -29,3 +31,5 @@ arguments = Arguments

29 <*> many (argument str (metavar "FILES/DIRS..."))

31 <*> many (argument str (metavar "FILES/DIRS..."))

30 <*> switch (long "version" <> help "Show ghcide and GHC versions")

32 <*> switch (long "version" <> help "Show ghcide and GHC versions")

31 <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")

33 <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")

34+ <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")

35+ <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault)

exe/Main.hs+525−123

@@ -7,20 +7,26 @@

8module Main(main) where

10+import Linker (initDynLinker)

11+import Data.IORef

12+import NameCache

13+import Packages

14+import Module

10import Arguments

15import Arguments

11−import Data.Binary (Binary)

16+import Control.Concurrent.Async

12−import Data.Dynamic (Typeable)

13−import Data.Hashable (Hashable)

14−import Data.Maybe

15−import Data.List.Extra

16−import System.FilePath

17import Control.Concurrent.Extra

18−import Control.DeepSeq (NFData)

19import Control.Exception

18import Control.Exception

20import Control.Monad.Extra

19import Control.Monad.Extra

21import Control.Monad.IO.Class

20import Control.Monad.IO.Class

22import Data.Default

21import Data.Default

23−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

24import Development.IDE.Core.Debouncer

30import Development.IDE.Core.Debouncer

25import Development.IDE.Core.FileStore

31import Development.IDE.Core.FileStore

26import Development.IDE.Core.OfInterest

32import Development.IDE.Core.OfInterest

@@ -37,34 +43,39 @@ import Development.IDE.GHC.Util

37import Development.IDE.Plugin

43import Development.IDE.Plugin

38import Development.IDE.Plugin.Completions as Completions

44import Development.IDE.Plugin.Completions as Completions

39import Development.IDE.Plugin.CodeAction as CodeAction

45import Development.IDE.Plugin.CodeAction as CodeAction

40−import qualified Data.Text as T

46+import qualified Language.Haskell.LSP.Core as LSP

41−import qualified Data.Text.IO as T

42import Language.Haskell.LSP.Messages

47import Language.Haskell.LSP.Messages

43−import Language.Haskell.LSP.Types (LspId(IdInt))

48+import Language.Haskell.LSP.Types

44−import Linker

45−import Data.Version

49+import Data.Aeson (ToJSON(toJSON))

46import Development.IDE.LSP.LanguageServer

50import Development.IDE.LSP.LanguageServer

47import qualified System.Directory.Extra as IO

51import qualified System.Directory.Extra as IO

48import System.Environment

52import System.Environment

49import System.IO

53import System.IO

50import 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)

51import Paths_ghcide

59import Paths_ghcide

52import Development.GitRev

60import Development.GitRev

53−import Development.Shake (Action, RuleResult, Rules, action, doesFileExist, need)

61+import Development.Shake (Action, action)

54import qualified Data.HashSet as HashSet

62import qualified Data.HashSet as HashSet

63+import qualified Data.HashMap.Strict as HM

55import qualified Data.Map.Strict as Map

64import qualified Data.Map.Strict as Map

56−

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)

57import GHC hiding (def)

71import GHC hiding (def)

58−import GHC.Generics (Generic)

72+import GHC.Check ( VersionCheck(..), makeGhcVersionChecker )

59−import qualified GHC.Paths

73+import Data.Either.Extra

61−import HIE.Bios

62import HIE.Bios.Cradle

75import HIE.Bios.Cradle

63import HIE.Bios.Types

76import HIE.Bios.Types

65−-- Set the GHC libdir to the nix libdir if it's present.

78+import Utils

66−getLibdir :: IO FilePath

67−getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"

69ghcideVersion :: IO String

80ghcideVersion :: IO String

70ghcideVersion = do

81ghcideVersion = do

@@ -94,74 +105,65 @@ main = do

94 whenJust argsCwd IO.setCurrentDirectory

105 whenJust argsCwd IO.setCurrentDirectory

106

96 dir <- IO.getCurrentDirectory

107 dir <- IO.getCurrentDirectory

108+ command <- makeLspCommandId "typesignature.add"

109

98 let plugins = Completions.plugin <> CodeAction.plugin

110 let plugins = Completions.plugin <> CodeAction.plugin

99 onInitialConfiguration = const $ Right ()

111 onInitialConfiguration = const $ Right ()

100 onConfigurationChange = const $ Right ()

112 onConfigurationChange = const $ Right ()

113+ options = def { LSP.executeCommandCommands = Just [command]

114+ , LSP.completionTriggerCharacters = Just "."

115+ }

101

116

102 if argLSP then do

117 if argLSP then do

103 t <- offsetTime

118 t <- offsetTime

104 hPutStrLn stderr "Starting LSP server..."

119 hPutStrLn stderr "Starting LSP server..."

105 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!"

106− runLanguageServer def (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do

121+ runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do

107 t <- t

122 t <- t

108 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t

123 hPutStrLn stderr $ "Started LSP server in " ++ showDuration t

109− let options = (defaultIdeOptions $ loadSession dir)

124+ let options = (defaultIdeOptions $ loadSessionShake dir)

110 { optReportProgress = clientSupportsProgress caps

125 { optReportProgress = clientSupportsProgress caps

111 , optShakeProfiling = argsShakeProfiling

126 , optShakeProfiling = argsShakeProfiling

127+ , optTesting = argsTesting

128+ , optThreads = argsThreads

112 }

129 }

113 debouncer <- newAsyncDebouncer

130 debouncer <- newAsyncDebouncer

114− initialise caps (loadGhcSessionIO >> mainRule >> pluginRules plugins >> action kick)

131+ initialise caps (mainRule >> pluginRules plugins >> action kick)

115 getLspId event (logger minBound) debouncer options vfs

132 getLspId event (logger minBound) debouncer options vfs

116 else do

133 else do

134+ -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error

135+ hSetEncoding stdout utf8

136+ hSetEncoding stderr utf8

137+

117 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."

138 putStrLn $ "Ghcide setup tester in " ++ dir ++ "."

118 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"

139 putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"

119

140

120− putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir

141+ putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir

121 files <- expandFiles (argFiles ++ ["." | null argFiles])

142 files <- expandFiles (argFiles ++ ["." | null argFiles])

122 -- LSP works with absolute file paths, so try and behave similarly

143 -- LSP works with absolute file paths, so try and behave similarly

123 files <- nubOrd <$> mapM IO.canonicalizePath files

144 files <- nubOrd <$> mapM IO.canonicalizePath files

124 putStrLn $ "Found " ++ show (length files) ++ " files"

145 putStrLn $ "Found " ++ show (length files) ++ " files"

125

146

126− 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"

127 cradles <- mapM findCradle files

148 cradles <- mapM findCradle files

128 let ucradles = nubOrd cradles

149 let ucradles = nubOrd cradles

129 let n = length ucradles

150 let n = length ucradles

130 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]

151 putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]

131− sessions <- forM (zipFrom (1 :: Int) ucradles) $ \(i, x) -> do

132− let msg = maybe ("Implicit cradle for " ++ dir) ("Loading " ++) x

133− putStrLn $ "\nStep 3/6, Cradle " ++ show i ++ "/" ++ show n ++ ": " ++ msg

134− cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x

135− when (isNothing x) $ print cradle

136− putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session"

137− opts <- getComponentOptions cradle

138− createSession opts

139−

140− putStrLn "\nStep 5/6: Initializing the IDE"

152+ putStrLn "\nStep 3/4: Initializing the IDE"

141 vfs <- makeVFSHandle

153 vfs <- makeVFSHandle

142− let cradlesToSessions = Map.fromList $ zip ucradles sessions

154+ debouncer <- newAsyncDebouncer

143− let filesToCradles = Map.fromList $ zip files cradles

144− let grab file = fromMaybe (head sessions) $ do

145− cradle <- Map.lookup file filesToCradles

146− Map.lookup cradle cradlesToSessions

147−

148− let options =

149− (defaultIdeOptions $ return $ return . grab)

150− { optShakeProfiling = argsShakeProfiling }

151− ide <- initialise def (loadGhcSessionIO >> 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

152−

156+

153− putStrLn "\nStep 6/6: Type checking the files"

157+ putStrLn "\nStep 4/4: Type checking the files"

154− setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath files

158+ setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files

155− results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files

159+ results <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath' files)

156 let (worked, failed) = partition fst $ zip (map isJust results) files

160 let (worked, failed) = partition fst $ zip (map isJust results) files

157 when (failed /= []) $

161 when (failed /= []) $

158 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed

162 putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed

159

163

160 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"

161 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"

165 putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"

162−

166+ return ()

163− unless (null failed) exitFailure

164−

165

167

166expandFiles :: [FilePath] -> IO [FilePath]

168expandFiles :: [FilePath] -> IO [FilePath]

167expandFiles = concatMapM $ \x -> do

169expandFiles = concatMapM $ \x -> do

@@ -184,84 +186,408 @@ kick = do

184-- | Print an LSP event.

186-- | Print an LSP event.

185showEvent :: Lock -> FromServerMessage -> IO ()

187showEvent :: Lock -> FromServerMessage -> IO ()

186showEvent _ (EventFileDiagnostics _ []) = return ()

188showEvent _ (EventFileDiagnostics _ []) = return ()

187−showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) =

189+showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =

188 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags

190 withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags

189showEvent lock e = withLock lock $ print e

191showEvent lock e = withLock lock $ print e

190

192

191

193

192−-- Rule type for caching GHC sessions.

194+-- | Run the specific cradle on a specific FilePath via hie-bios.

193−type instance RuleResult GetHscEnv = HscEnvEq

194−

195−data GetHscEnv = GetHscEnv

196− { hscenvOptions :: [String] -- componentOptions from hie-bios

197− , hscenvDependencies :: [FilePath] -- componentDependencies from hie-bios

198− }

199− deriving (Eq, Show, Typeable, Generic)

200−instance Hashable GetHscEnv

201−instance NFData GetHscEnv

202−instance Binary GetHscEnv

203−

204−

205−loadGhcSessionIO :: Rules ()

206−loadGhcSessionIO =

207− -- This rule is for caching the GHC session. E.g., even when the cabal file

208− -- changed, if the resulting flags did not change, we would continue to use

209− -- the existing session.

210− defineNoFile $ \(GetHscEnv opts deps) ->

211− liftIO $ createSession $ ComponentOptions opts deps

212−

213−

214−getComponentOptions :: Cradle a -> IO ComponentOptions

195+cradleToSessionOpts :: Cradle a -> FilePath -> IO (Either [CradleError] ComponentOptions)

215−getComponentOptions cradle = do

196+cradleToSessionOpts cradle file = do

216 let showLine s = putStrLn ("> " ++ s)

197 let showLine s = putStrLn ("> " ++ s)

217− cradleRes <- runCradle (cradleOptsProg cradle) showLine ""

198+ cradleRes <- runCradle (cradleOptsProg cradle) showLine file

218 case cradleRes of

199 case cradleRes of

219− CradleSuccess r -> pure r

200+ CradleSuccess r -> pure (Right r)

220− CradleFail err -> throwIO err

201+ CradleFail err -> return (Left [err])

221− -- TODO Rather than failing here, we should ignore any files that use this cradle.

202+ -- For the None cradle perhaps we still want to report an Info

222− -- That will require some more changes.

203+ -- message about the fact that the file is being ignored.

223− CradleNone -> fail "'none' cradle is not yet supported"

204+ CradleNone -> return (Left [])

224−

205+

225−

206+emptyHscEnv :: IO HscEnv

226−createSession :: ComponentOptions -> IO HscEnvEq

207+emptyHscEnv = do

227−createSession opts = do

228 libdir <- getLibdir

208 libdir <- getLibdir

229− env <- runGhc (Just libdir) $ do

209+ env <- runGhc (Just libdir) getSession

230− _targets <- initSession opts

231− getSession

232 initDynLinker env

210 initDynLinker env

233− newHscEnvEq env

211+ pure env

234−

212+

235−

213+-- | Convert a target to a list of potential absolute paths.

236−cradleToSession :: Maybe FilePath -> Cradle a -> Action HscEnvEq

214+-- A TargetModule can be anywhere listed by the supplied include

237−cradleToSession mbYaml cradle = do

215+-- directories

238− cmpOpts <- liftIO $ getComponentOptions cradle

216+-- A target file is a relative path but with a specific prefix so just need

239− let opts = componentOptions cmpOpts

217+-- to canonicalise it.

240− deps = componentDependencies cmpOpts

218+targetToFile :: [FilePath] -> TargetId -> IO [NormalizedFilePath]

241− deps' = case mbYaml of

219+targetToFile is (TargetModule mod) = do

242− -- For direct cradles, the hie.yaml file itself must be watched.

220+ let fps = [i </> moduleNameSlashes mod -<.> ext | ext <- exts, i <- is ]

243− Just yaml | isDirectCradle cradle -> yaml : deps

221+ exts = ["hs", "hs-boot", "lhs"]

244− _ -> deps

222+ mapM (fmap toNormalizedFilePath' . canonicalizePath) fps

245− existingDeps <- filterM doesFileExist deps'

223+targetToFile _ (TargetFile f _) = do

246− need existingDeps

224+ f' <- canonicalizePath f

247− useNoFile_ $ GetHscEnv opts deps

225+ return [toNormalizedFilePath' f']

248−

226+

249−

227+setNameCache :: IORef NameCache -> HscEnv -> HscEnv

250−loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq)

228+setNameCache nc hsc = hsc { hsc_NC = nc }

251−loadSession dir = liftIO $ do

229+

252− cradleLoc <- memoIO $ \v -> do

230+loadSessionShake :: FilePath -> Action (FilePath -> Action (IdeResult HscEnvEq))

253− res <- findCradle v

231+loadSessionShake fp = do

254− -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path

232+ se <- getShakeExtras

255− -- try and normalise that

233+ IdeOptions{optTesting} <- getIdeOptions

256− -- e.g. see https://github.com/digital-asset/ghcide/issues/126

234+ res <- liftIO $ loadSession optTesting se fp

257− res' <- traverse IO.makeAbsolute res

235+ return (fmap liftIO res)

258− return $ normalise <$> res'

236+

259− let session :: Maybe FilePath -> Action HscEnvEq

237+-- | This is the key function which implements multi-component support. All

260− session file = do

238+-- components mapping to the same hie.yaml file are mapped to the same

261− c <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file

239+-- HscEnv which is updated as new components are discovered.

262− cradleToSession file c

240+loadSession :: Bool -> ShakeExtras -> FilePath -> IO (FilePath -> IO (IdeResult HscEnvEq))

263− return $ \file -> session =<< liftIO (cradleLoc file)

241+loadSession optTesting ShakeExtras{logger, eventer} dir = do

264−

242+ -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file

243+ hscEnvs <- newVar Map.empty :: IO (Var HieMap)

244+ -- Mapping from a Filepath to HscEnv

245+ fileToFlags <- newVar Map.empty :: IO (Var FlagsMap)

246+

247+ -- This caches the mapping from Mod.hs -> hie.yaml

248+ cradleLoc <- memoIO $ \v -> do

249+ res <- findCradle v

250+ -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path

251+ -- try and normalise that

252+ -- e.g. see https://github.com/digital-asset/ghcide/issues/126

253+ res' <- traverse IO.makeAbsolute res

254+ return $ normalise <$> res'

255+

256+ -- Create a new HscEnv from a hieYaml root and a set of options

257+ -- If the hieYaml file already has an HscEnv, the new component is

258+ -- combined with the components in the old HscEnv into a new HscEnv

259+ -- which contains the union.

260+ let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions)

261+ -> IO (HscEnv, ComponentInfo, [ComponentInfo])

262+ packageSetup (hieYaml, cfp, opts) = do

263+ -- Parse DynFlags for the newly discovered component

264+ hscEnv <- emptyHscEnv

265+ (df, targets) <- evalGhcEnv hscEnv $

266+ setOptions opts (hsc_dflags hscEnv)

267+ dep_info <- getDependencyInfo (componentDependencies opts ++ maybeToList hieYaml)

268+ -- Now lookup to see whether we are combining with an existing HscEnv

269+ -- or making a new one. The lookup returns the HscEnv and a list of

270+ -- information about other components loaded into the HscEnv

271+ -- (unitId, DynFlag, Targets)

272+ modifyVar hscEnvs $ \m -> do

273+ -- Just deps if there's already an HscEnv

274+ -- Nothing is it's the first time we are making an HscEnv

275+ let oldDeps = Map.lookup hieYaml m

276+ let -- Add the raw information about this component to the list

277+ -- We will modify the unitId and DynFlags used for

278+ -- compilation but these are the true source of

279+ -- information.

280+ new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info

281+ : maybe [] snd oldDeps

282+ -- Get all the unit-ids for things in this component

283+ inplace = map rawComponentUnitId new_deps

284+

285+ new_deps' <- forM new_deps $ \RawComponentInfo{..} -> do

286+ -- Remove all inplace dependencies from package flags for

287+ -- components in this HscEnv

288+ let (df2, uids) = removeInplacePackages inplace rawComponentDynFlags

289+ let prefix = show rawComponentUnitId

290+ -- See Note [Avoiding bad interface files]

291+ processed_df <- setCacheDir logger prefix (sort $ map show uids) opts df2

292+ -- The final component information, mostly the same but the DynFlags don't

293+ -- contain any packages which are also loaded

294+ -- into the same component.

295+ pure $ ComponentInfo rawComponentUnitId

296+ processed_df

297+ uids

298+ rawComponentTargets

299+ rawComponentFP

300+ rawComponentCOptions

301+ rawComponentDependencyInfo

302+ -- Make a new HscEnv, we have to recompile everything from

303+ -- scratch again (for now)

304+ -- It's important to keep the same NameCache though for reasons

305+ -- that I do not fully understand

306+ logInfo logger (T.pack ("Making new HscEnv" ++ show inplace))

307+ hscEnv <- case oldDeps of

308+ Nothing -> emptyHscEnv

309+ Just (old_hsc, _) -> setNameCache (hsc_NC old_hsc) <$> emptyHscEnv

310+ newHscEnv <-

311+ -- Add the options for the current component to the HscEnv

312+ evalGhcEnv hscEnv $ do

313+ _ <- setSessionDynFlags df

314+ getSession

315+ -- Modify the map so the hieYaml now maps to the newly created

316+ -- HscEnv

317+ -- Returns

318+ -- . the new HscEnv so it can be used to modify the

319+ -- FilePath -> HscEnv map (fileToFlags)

320+ -- . The information for the new component which caused this cache miss

321+ -- . The modified information (without -inplace flags) for

322+ -- existing packages

323+ pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps'))

324+

325+ let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> IO (IdeResult HscEnvEq)

326+ session (hieYaml, cfp, opts) = do

327+ (hscEnv, new, old_deps) <- packageSetup (hieYaml, cfp, opts)

328+ -- Make a map from unit-id to DynFlags, this is used when trying to

329+ -- resolve imports. (especially PackageImports)

330+ let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps)

331+

332+ -- For each component, now make a new HscEnvEq which contains the

333+ -- HscEnv for the hie.yaml file but the DynFlags for that component

334+

335+ -- New HscEnv for the component in question, returns the new HscEnvEq and

336+ -- a mapping from FilePath to the newly created HscEnvEq.

337+ let new_cache = newComponentCache logger hscEnv uids

338+ (cs, res) <- new_cache new

339+ -- Modified cache targets for everything else in the hie.yaml file

340+ -- which now uses the same EPS and so on

341+ cached_targets <- concatMapM (fmap fst . new_cache) old_deps

342+ modifyVar_ fileToFlags $ \var -> do

343+ pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var

344+

345+ return (fst res)

346+

347+ let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq)

348+ consultCradle hieYaml cfp = do

349+ when optTesting $ eventer $ notifyCradleLoaded cfp

350+ logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp)

351+ cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml

352+ eopts <- cradleToSessionOpts cradle cfp

353+ logDebug logger $ T.pack ("Session loading result: " <> show eopts)

354+ case eopts of

355+ -- The cradle gave us some options so get to work turning them

356+ -- into and HscEnv.

357+ Right opts -> do

358+ session (hieYaml, toNormalizedFilePath' cfp, opts)

359+ -- Failure case, either a cradle error or the none cradle

360+ Left err -> do

361+ dep_info <- getDependencyInfo (maybeToList hieYaml)

362+ let ncfp = toNormalizedFilePath' cfp

363+ let res = (map (renderCradleError ncfp) err, Nothing)

364+ modifyVar_ fileToFlags $ \var -> do

365+ pure $ Map.insertWith HM.union hieYaml (HM.singleton ncfp (res, dep_info)) var

366+ return res

367+

368+ -- This caches the mapping from hie.yaml + Mod.hs -> [String]

369+ let sessionOpts :: (Maybe FilePath, FilePath) -> IO (IdeResult HscEnvEq)

370+ sessionOpts (hieYaml, file) = do

371+ v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags

372+ cfp <- canonicalizePath file

373+ case HM.lookup (toNormalizedFilePath' cfp) v of

374+ Just (opts, old_di) -> do

375+ deps_ok <- checkDependencyInfo old_di

376+ if not deps_ok

377+ then do

378+ -- If the dependencies are out of date then clear both caches and start

379+ -- again.

380+ modifyVar_ fileToFlags (const (return Map.empty))

381+ -- Keep the same name cache

382+ modifyVar_ hscEnvs (return . Map.adjust (\(h, _) -> (h, [])) hieYaml )

383+ consultCradle hieYaml cfp

384+ else return opts

385+ Nothing -> consultCradle hieYaml cfp

386+

387+ dummyAs <- async $ return (error "Uninitialised")

388+ runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq)))

389+ -- The main function which gets options for a file. We only want one of these running

390+ -- at a time. Therefore the IORef contains the currently running cradle, if we try

391+ -- to get some more options then we wait for the currently running action to finish

392+ -- before attempting to do so.

393+ let getOptions :: FilePath -> IO (IdeResult HscEnvEq)

394+ getOptions file = do

395+ hieYaml <- cradleLoc file

396+ sessionOpts (hieYaml, file)

397+ return $ \file -> do

398+ join $ mask_ $ modifyVar runningCradle $ \as -> do

399+ -- If the cradle is not finished, then wait for it to finish.

400+ void $ wait as

401+ as <- async $ getOptions file

402+ return (as, wait as)

403+

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

265

591

266-- | Memoize an IO function, with the characteristics:

592-- | Memoize an IO function, with the characteristics:

267--

593--

@@ -279,3 +605,79 @@ memoIO op = do

279 res <- onceFork $ op k

605 res <- onceFork $ op k

280 return (Map.insert k res mp, res)

606 return (Map.insert k res mp, res)

281 Just res -> return (mp, res)

607 Just res -> return (mp, res)

608+

609+setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (DynFlags, [Target])

610+setOptions (ComponentOptions theOpts compRoot _) dflags = do

611+ (dflags', targets) <- addCmdOpts theOpts dflags

612+ let dflags'' =

613+ -- disabled, generated directly by ghcide instead

614+ flip gopt_unset Opt_WriteInterface $

615+ -- disabled, generated directly by ghcide instead

616+ -- also, it can confuse the interface stale check

617+ dontWriteHieFiles $

618+ setIgnoreInterfacePragmas $

619+ setLinkerOptions $

620+ disableOptimisation $

621+ makeDynFlagsAbsolute compRoot dflags'

622+ -- initPackages parses the -package flags and

623+ -- sets up the visibility for each component.

624+ (final_df, _) <- liftIO $ initPackages dflags''

625+ return (final_df, targets)

626+

627+

628+-- we don't want to generate object code so we compile to bytecode

629+-- (HscInterpreted) which implies LinkInMemory

630+-- HscInterpreted

631+setLinkerOptions :: DynFlags -> DynFlags

632+setLinkerOptions df = df {

633+ ghcLink = LinkInMemory

634+ , hscTarget = HscNothing

635+ , ghcMode = CompManager

636+ }

637+

638+setIgnoreInterfacePragmas :: DynFlags -> DynFlags

639+setIgnoreInterfacePragmas df =

640+ gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges

641+

642+disableOptimisation :: DynFlags -> DynFlags

643+disableOptimisation df = updOptLevel 0 df

644+

645+setHiDir :: FilePath -> DynFlags -> DynFlags

646+setHiDir f d =

647+ -- override user settings to avoid conflicts leading to recompilation

648+ d { hiDir = Just f}

649+

650+getCacheDir :: String -> [String] -> IO FilePath

651+getCacheDir prefix opts = IO.getXdgDirectory IO.XdgCache (cacheDir </> prefix ++ "-" ++ opts_hash)

652+ where

653+ -- Create a unique folder per set of different GHC options, assuming that each different set of

654+ -- GHC options will create incompatible interface files.

655+ opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts)

656+

657+-- | Sub directory for the cache path

658+cacheDir :: String

659+cacheDir = "ghcide"

660+

661+notifyCradleLoaded :: FilePath -> FromServerMessage

662+notifyCradleLoaded fp =

663+ NotCustomServer $

664+ NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $

665+ toJSON fp

666+

667+cradleLoadedMethod :: T.Text

668+cradleLoadedMethod = "ghcide/cradle/loaded"

669+

670+ghcVersionChecker :: IO VersionCheck

671+ghcVersionChecker = $$(makeGhcVersionChecker (pure <$> getLibdir))

672+

673+checkGhcVersion :: IO (Maybe HscEnvEq)

674+checkGhcVersion = do

675+ res <- ghcVersionChecker

676+ case res of

677+ Failure err -> do

678+ putStrLn $ "Error while checking GHC version: " ++ show err

679+ return Nothing

680+ Mismatch {..} ->

681+ return $ Just GhcVersionMismatch {..}

682+ _ ->

683+ return Nothing

exe/Utils.hsnew file+9

@@ -0,0 +1,9 @@

1+module Utils (getLibdir) where

3+import qualified GHC.Paths

4+import System.Environment

5+import Data.Maybe

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+94−10

@@ -2,12 +2,12 @@ cabal-version: 1.20

2build-type: Simple

3category: Development

4name: ghcide

5−version: 0.1.0

5+version: 0.2.0

6license: Apache-2.0

7license-file: LICENSE

8author: Digital Asset

9maintainer: Digital Asset

10−copyright: Digital Asset 2018-2019

10+copyright: Digital Asset 2018-2020

11synopsis: The core of an IDE

12description:

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

16tested-with: GHC==8.6.5

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

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,16 +143,26 @@ 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

140 Development.IDE.Spans.Type

152 Development.IDE.Spans.Type

153+ Development.IDE.Plugin.CodeAction.PositionIndexed

154+ Development.IDE.Plugin.CodeAction.Rules

155+ Development.IDE.Plugin.CodeAction.RuleTypes

141 Development.IDE.Plugin.Completions.Logic

156 Development.IDE.Plugin.Completions.Logic

142 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

143 ghc-options: -Wall -Wno-name-shadowing

166 ghc-options: -Wall -Wno-name-shadowing

144

167

145executable ghcide-test-preprocessor

168executable ghcide-test-preprocessor

@@ -167,34 +190,52 @@ executable ghcide

167 "-with-rtsopts=-I0 -qg -A128M"

190 "-with-rtsopts=-I0 -qg -A128M"

168 main-is: Main.hs

191 main-is: Main.hs

169 build-depends:

192 build-depends:

193+ time,

194+ async,

170 hslogger,

195 hslogger,

196+ aeson,

171 base == 4.*,

197 base == 4.*,

172 binary,

198 binary,

199+ base16-bytestring >=0.1.1 && <0.2,

200+ bytestring,

173 containers,

201 containers,

202+ cryptohash-sha1 >=0.11.100 && <0.12,

174 data-default,

203 data-default,

175 deepseq,

204 deepseq,

176 directory,

205 directory,

177 extra,

206 extra,

178 filepath,

207 filepath,

208+ ghc-check >= 0.3.0.1 && < 0.4,

179 ghc-paths,

209 ghc-paths,

180 ghc,

210 ghc,

181 gitrev,

211 gitrev,

182 hashable,

212 hashable,

183 haskell-lsp,

213 haskell-lsp,

214+ haskell-lsp-types,

184− hie-bios >= 0.4.0 && < 0.5,

215+ hie-bios >= 0.5.0 && < 0.6,

185 ghcide,

216 ghcide,

186 optparse-applicative,

217 optparse-applicative,

187 shake,

218 shake,

188 text,

219 text,

189 unordered-containers

220 unordered-containers

190 other-modules:

221 other-modules:

222+ Utils

191 Arguments

223 Arguments

192 Paths_ghcide

224 Paths_ghcide

193

225

194 default-extensions:

226 default-extensions:

227+ BangPatterns

228+ DeriveFunctor

195 DeriveGeneric

229 DeriveGeneric

230+ GeneralizedNewtypeDeriving

231+ LambdaCase

232+ NamedFieldPuns

233+ OverloadedStrings

196 RecordWildCards

234 RecordWildCards

235+ ScopedTypeVariables

236+ StandaloneDeriving

197 TupleSections

237 TupleSections

238+ TypeApplications

198 ViewPatterns

239 ViewPatterns

199

240

200test-suite ghcide-tests

241test-suite ghcide-tests

@@ -226,16 +267,19 @@ test-suite ghcide-tests

226 haddock-library,

267 haddock-library,

227 haskell-lsp,

268 haskell-lsp,

228 haskell-lsp-types,

269 haskell-lsp-types,

270+ network-uri,

229 lens,

271 lens,

230− lsp-test >= 0.8,

272+ lsp-test >= 0.11.0.1 && < 0.12,

231 parser-combinators,

273 parser-combinators,

232 QuickCheck,

274 QuickCheck,

233 quickcheck-instances,

275 quickcheck-instances,

234 rope-utf16-splay,

276 rope-utf16-splay,

277+ shake,

235 tasty,

278 tasty,

236 tasty-expected-failure,

279 tasty-expected-failure,

237 tasty-hunit,

280 tasty-hunit,

238 tasty-quickcheck,

281 tasty-quickcheck,

282+ tasty-rerun,

239 text

283 text

240 hs-source-dirs: test/cabal test/exe test/src

284 hs-source-dirs: test/cabal test/exe test/src

241 include-dirs: include

285 include-dirs: include

@@ -258,3 +302,43 @@ test-suite ghcide-tests

258 TupleSections

302 TupleSections

259 TypeApplications

303 TypeApplications

260 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 @@

3+{-

4+Forked from GHC v8.10.1 to work around the readFile side effect in mkHiefile

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 @@

2+{-

3+Forked from GHC v8.8.1 to work around the readFile side effect in mkHiefile

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

7+#ifdef mingw32_HOST_OS

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+269−79

@@ -9,6 +9,7 @@

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

11 ( TcModuleResult(..)

12+ , RunSimplifier(..)

12 , compileModule

13 , compileModule

13 , parseModule

14 , parseModule

14 , typecheckModule

15 , typecheckModule

@@ -16,6 +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

23+ , loadHieFile

24+ , loadInterface

25+ , loadDepModule

26+ , loadModuleHome

19 ) where

27 ) where

21import Development.IDE.Core.RuleTypes

29import Development.IDE.Core.RuleTypes

@@ -29,6 +37,7 @@ import Development.IDE.GHC.Util

29import qualified GHC.LanguageExtensions.Type as GHC

37import qualified GHC.LanguageExtensions.Type as GHC

30import Development.IDE.Types.Options

38import Development.IDE.Types.Options

31import Development.IDE.Types.Location

39import Development.IDE.Types.Location

40+import Outputable

33#if MIN_GHC_API_VERSION(8,6,0)

42#if MIN_GHC_API_VERSION(8,6,0)

34import DynamicLoading (initializePlugins)

43import DynamicLoading (initializePlugins)

@@ -43,42 +52,53 @@ import ErrUtils

43#endif

52#endif

45import Finder

54import Finder

46−import qualified GHC

55+import qualified Development.IDE.GHC.Compat as GHC

56+import qualified Development.IDE.GHC.Compat as Compat

47import GhcMonad

57import GhcMonad

48import GhcPlugins as GHC hiding (fst3, (<>))

58import GhcPlugins as GHC hiding (fst3, (<>))

49import qualified HeaderInfo as Hdr

59import qualified HeaderInfo as Hdr

50import HscMain (hscInteractive, hscSimplify)

60import HscMain (hscInteractive, hscSimplify)

61+import LoadIface (readIface)

62+import qualified Maybes

51import MkIface

63import MkIface

64+import NameCache

52import StringBuffer as SB

65import StringBuffer as SB

53−import TcRnMonad (tcg_th_coreplugins)

66+import TcRnMonad (initIfaceLoad, tcg_th_coreplugins)

67+import TcIface (typecheckIface)

54import TidyPgm

68import TidyPgm

70+import Control.Exception.Safe

56import Control.Monad.Extra

71import Control.Monad.Extra

57import Control.Monad.Except

72import Control.Monad.Except

58import Control.Monad.Trans.Except

73import Control.Monad.Trans.Except

59−import Data.Function

74+import Data.Bifunctor (first, second)

60−import Data.Ord

61import qualified Data.Text as T

75import qualified Data.Text as T

62import Data.IORef

76import Data.IORef

63import Data.List.Extra

77import Data.List.Extra

64import Data.Maybe

78import Data.Maybe

65−import Data.Tuple.Extra

66import qualified Data.Map.Strict as Map

79import qualified Data.Map.Strict as Map

67import 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-- | 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'.

71parseModule

90parseModule

72 :: IdeOptions

91 :: IdeOptions

73 -> HscEnv

92 -> HscEnv

93+ -> [PackageName]

74 -> FilePath

94 -> FilePath

75 -> Maybe SB.StringBuffer

95 -> Maybe SB.StringBuffer

76 -> IO (IdeResult (StringBuffer, ParsedModule))

96 -> IO (IdeResult (StringBuffer, ParsedModule))

77−parseModule IdeOptions{..} env filename mbContents =

97+parseModule IdeOptions{..} env comp_pkgs filename mbContents =

78 fmap (either (, Nothing) id) $

98 fmap (either (, Nothing) id) $

79− runGhcEnv env $ runExceptT $ do

99+ evalGhcEnv env $ runExceptT $ do

80 (contents, dflags) <- preprocessor filename mbContents

100 (contents, dflags) <- preprocessor filename mbContents

81− (diag, modu) <- parseFileContents optPreprocessor dflags filename contents

101+ (diag, modu) <- parseFileContents optPreprocessor dflags comp_pkgs filename contents

82 return (diag, Just (contents, modu))

102 return (diag, Just (contents, modu))

103

104

@@ -90,34 +110,39 @@ computePackageDeps

90computePackageDeps env pkg = do

110computePackageDeps env pkg = do

91 let dflags = hsc_dflags env

111 let dflags = hsc_dflags env

92 case lookupInstalledPackage dflags pkg of

112 case lookupInstalledPackage dflags pkg of

93− Nothing -> return $ Left [ideErrorText (toNormalizedFilePath noFilePath) $

113+ Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $

94 T.pack $ "unknown package: " ++ show pkg]

114 T.pack $ "unknown package: " ++ show pkg]

95 Just pkgInfo -> return $ Right $ depends pkgInfo

115 Just pkgInfo -> return $ Right $ depends pkgInfo

116

97−

98−-- | Typecheck a single module using the supplied dependencies and packages.

99−typecheckModule

100− :: IdeDefer

117+typecheckModule :: IdeDefer

101− -> HscEnv

118+ -> HscEnv

102− -> [TcModuleResult]

119+ -> [(ModSummary, (ModIface, Maybe Linkable))]

103− -> ParsedModule

120+ -> ParsedModule

104− -> IO (IdeResult TcModuleResult)

121+ -> IO (IdeResult (HscEnv, TcModuleResult))

105−typecheckModule (IdeDefer defer) packageState deps pm =

122+typecheckModule (IdeDefer defer) hsc depsIn pm = do

106− let demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id

107− in

108− fmap (either (, Nothing) (second Just)) $

123+ fmap (either (, Nothing) (second Just . sequence) . sequence) $

109− runGhcEnv packageState $

124+ runGhcEnv hsc $

110− catchSrcErrors "typecheck" $ do

125+ catchSrcErrors "typecheck" $ do

111− 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+

112− let modSummary = pm_mod_summary pm

133+ let modSummary = pm_mod_summary pm

113− dflags = ms_hspp_opts modSummary

134+ dflags = ms_hspp_opts modSummary

135+

136+ mapM_ (uncurry loadDepModule . snd) deps

114− modSummary' <- initPlugins modSummary

137+ modSummary' <- initPlugins modSummary

115− (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->

138+ (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->

116− GHC.typecheckModule $ enableTopLevelWarnings

139+ GHC.typecheckModule $ enableTopLevelWarnings

117− $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}

140+ $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}

118− tcm2 <- mkTcModuleResult tcm

141+ tcm2 <- mkTcModuleResult tcm

119− let errorPipeline = unDefer . hideDiag dflags

142+ let errorPipeline = unDefer . hideDiag dflags

120− return (map errorPipeline warnings, tcm2)

143+ return (map errorPipeline warnings, tcm2)

144+ where

145+ demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id

121

146

122initPlugins :: GhcMonad m => ModSummary -> m ModSummary

147initPlugins :: GhcMonad m => ModSummary -> m ModSummary

123initPlugins modSummary = do

148initPlugins modSummary = do

@@ -129,18 +154,25 @@ initPlugins modSummary = do

129 return modSummary

154 return modSummary

130#endif

155#endif

131

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+

132-- | Compile a single type-checked module to a 'CoreModule' value, or

163-- | Compile a single type-checked module to a 'CoreModule' value, or

133-- provide errors.

164-- provide errors.

134compileModule

165compileModule

166+ :: RunSimplifier

135− :: HscEnv

167+ -> HscEnv

136− -> [TcModuleResult]

168+ -> [(ModSummary, HomeModInfo)]

137 -> TcModuleResult

169 -> TcModuleResult

138 -> IO (IdeResult (SafeHaskellMode, CgGuts, ModDetails))

170 -> IO (IdeResult (SafeHaskellMode, CgGuts, ModDetails))

139−compileModule packageState deps tmr =

171+compileModule (RunSimplifier simplify) packageState deps tmr =

140 fmap (either (, Nothing) (second Just)) $

172 fmap (either (, Nothing) (second Just)) $

141− runGhcEnv packageState $

173+ evalGhcEnv packageState $

142 catchSrcErrors "compile" $ do

174 catchSrcErrors "compile" $ do

143− setupEnv (deps ++ [tmr])

175+ setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])

144

176

145 let tm = tmrModule tmr

177 let tm = tmrModule tmr

146 session <- getSession

178 session <- getSession

@@ -150,21 +182,22 @@ compileModule packageState deps tmr =

150 let tm' = tm{tm_parsed_module = pm'}

182 let tm' = tm{tm_parsed_module = pm'}

151 GHC.dm_core_module <$> GHC.desugarModule tm'

183 GHC.dm_core_module <$> GHC.desugarModule tm'

152 let tc_result = fst (tm_internals_ (tmrModule tmr))

184 let tc_result = fst (tm_internals_ (tmrModule tmr))

153− -- Have to call the simplifier on the code even if we are at

185+ desugared_guts <-

154− -- -O0 as otherwise the code generation fails which leads to

186+ if simplify

155− -- errors like #256

187+ then do

156− plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)

188+ plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)

157− desugared_guts <- liftIO $ hscSimplify session plugins desugar

189+ liftIO $ hscSimplify session plugins desugar

190+ else pure desugar

158 -- give variables unique OccNames

191 -- give variables unique OccNames

159 (guts, details) <- liftIO $ tidyProgram session desugared_guts

192 (guts, details) <- liftIO $ tidyProgram session desugared_guts

160 return (map snd warnings, (mg_safe_haskell desugar, guts, details))

193 return (map snd warnings, (mg_safe_haskell desugar, guts, details))

161

194

162−generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable)

195+generateByteCode :: HscEnv -> [(ModSummary, HomeModInfo)] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable)

163generateByteCode hscEnv deps tmr guts =

196generateByteCode hscEnv deps tmr guts =

164 fmap (either (, Nothing) (second Just)) $

197 fmap (either (, Nothing) (second Just)) $

165− runGhcEnv hscEnv $

198+ evalGhcEnv hscEnv $

166 catchSrcErrors "bytecode" $ do

199 catchSrcErrors "bytecode" $ do

167− setupEnv (deps ++ [tmr])

200+ setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])

168 session <- getSession

201 session <- getSession

169 (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->

202 (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->

170#if MIN_GHC_API_VERSION(8,10,0)

203#if MIN_GHC_API_VERSION(8,10,0)

@@ -222,7 +255,7 @@ hideDiag originalFlags (Reason warning, (nfp, _sh, fd))

222 | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))

255 | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))

223hideDiag _originalFlags t = t

256hideDiag _originalFlags t = t

224

257

225−addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags

258+addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags

226addRelativeImport fp modu dflags = dflags

259addRelativeImport fp modu dflags = dflags

227 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}

260 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}

228

261

@@ -232,29 +265,81 @@ mkTcModuleResult

232 -> m TcModuleResult

265 -> m TcModuleResult

233mkTcModuleResult tcm = do

266mkTcModuleResult tcm = do

234 session <- getSession

267 session <- getSession

268+ let sf = modInfoSafe (tm_checked_module_info tcm)

235#if MIN_GHC_API_VERSION(8,10,0)

269#if MIN_GHC_API_VERSION(8,10,0)

236− iface <- liftIO $ mkIfaceTc session Sf_None details tcGblEnv

270+ iface <- liftIO $ mkIfaceTc session sf details tcGblEnv

237#else

271#else

238− (iface, _) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv

272+ (iface, _) <- liftIO $ mkIfaceTc session Nothing sf details tcGblEnv

239#endif

273#endif

240 let mod_info = HomeModInfo iface details Nothing

274 let mod_info = HomeModInfo iface details Nothing

241 return $ TcModuleResult tcm mod_info

275 return $ TcModuleResult tcm mod_info

242 where

276 where

243 (tcGblEnv, details) = tm_internals_ tcm

277 (tcGblEnv, details) = tm_internals_ tcm

244

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+

245-- | Setup the environment that GHC needs according to our

325-- | Setup the environment that GHC needs according to our

246-- best understanding (!)

326-- best understanding (!)

327+--

328+-- This involves setting up the finder cache and populating the

329+-- HPT.

247−setupEnv :: GhcMonad m => [TcModuleResult] -> m ()

330+setupEnv :: GhcMonad m => [(ModSummary, HomeModInfo)] -> m ()

248−setupEnv tmsIn = do

331+setupEnv tms = do

249− -- 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)

250− -- takes precedence, so put the .hs-boot file earlier in the list

333+ -- load dependent modules, which must be in topological order.

251− let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule

334+ modifySession $ \e ->

252− tms = sortBy (compare `on` Down . isSourceFile) tmsIn

335+ foldl' (\e (_, hmi) -> loadModuleHome hmi e) e tms

253

336

337+-- | Initialise the finder cache, dependencies should be topologically

338+-- sorted.

339+setupFinderCache :: GhcMonad m => [ModSummary] -> m ()

340+setupFinderCache mss = do

254 session <- getSession

341 session <- getSession

255

342

256− let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms

257−

258 -- set the target and module graph in the session

343 -- set the target and module graph in the session

259 let graph = mkModuleGraph mss

344 let graph = mkModuleGraph mss

260 setSession session { hsc_mod_graph = graph }

345 setSession session { hsc_mod_graph = graph }

@@ -273,26 +358,40 @@ setupEnv tmsIn = do

273 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache

358 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache

274 modifySession $ \s -> s { hsc_FC = newFinderCacheVar }

359 modifySession $ \s -> s { hsc_FC = newFinderCacheVar }

275

360

276− -- load dependent modules, which must be in topological order.

277− mapM_ loadModuleHome tms

278−

279

361

280-- | Load a module, quickly. Input doesn't need to be desugared.

362-- | Load a module, quickly. Input doesn't need to be desugared.

281-- A module must be loaded before dependent modules can be typechecked.

363-- A module must be loaded before dependent modules can be typechecked.

282-- This variant of loadModuleHome will *never* cause recompilation, it just

364-- This variant of loadModuleHome will *never* cause recompilation, it just

283-- 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.

284loadModuleHome

370loadModuleHome

285− :: (GhcMonad m)

371+ :: HomeModInfo

286− => TcModuleResult

372+ -> HscEnv

287− -> m ()

373+ -> HscEnv

288−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

289− 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) }

290− where

384+ initIfaceLoad hsc' (typecheckIface iface)

291− ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr

385+ let mod_info = HomeModInfo iface details linkable

292− mod_info = tmrModInfo tmr

386+ return $ loadModuleHome mod_info hsc

293− mod = ms_mod_name ms

387+ where

294−

388+ mod = moduleName $ mi_module iface

295

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'

296

395

297-- | 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

298-- name and its imports.

397-- name and its imports.

@@ -313,16 +412,14 @@ getImportsParsed dflags (L loc parsed) = do

313 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"

412 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"

314 ])

413 ])

315

414

316−

317-- | Produce a module summary from a StringBuffer.

415-- | Produce a module summary from a StringBuffer.

318getModSummaryFromBuffer

416getModSummaryFromBuffer

319 :: GhcMonad m

417 :: GhcMonad m

320 => FilePath

418 => FilePath

321− -> SB.StringBuffer

322 -> DynFlags

419 -> DynFlags

323 -> GHC.ParsedSource

420 -> GHC.ParsedSource

324 -> ExceptT [FileDiagnostic] m ModSummary

421 -> ExceptT [FileDiagnostic] m ModSummary

325−getModSummaryFromBuffer fp contents dflags parsed = do

422+getModSummaryFromBuffer fp dflags parsed = do

326 (modName, imports) <- liftEither $ getImportsParsed dflags parsed

423 (modName, imports) <- liftEither $ getImportsParsed dflags parsed

327

424

328 modLoc <- liftIO $ mkHomeModLocation dflags modName fp

425 modLoc <- liftIO $ mkHomeModLocation dflags modName fp

@@ -338,7 +435,7 @@ getModSummaryFromBuffer fp contents dflags parsed = do

338 , ms_textual_imps = [imp | (False, imp) <- imports]

435 , ms_textual_imps = [imp | (False, imp) <- imports]

339 , ms_hspp_file = fp

436 , ms_hspp_file = fp

340 , ms_hspp_opts = dflags

437 , ms_hspp_opts = dflags

341− , ms_hspp_buf = Just contents

438+ , ms_hspp_buf = Nothing

342

439

343 -- defaults:

440 -- defaults:

344 , ms_hsc_src = sourceType

441 , ms_hsc_src = sourceType

@@ -353,17 +450,61 @@ getModSummaryFromBuffer fp contents dflags parsed = do

353 where

450 where

354 sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile

451 sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile

355

452

356−

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+

357−-- | Given a buffer, flags, file path and module summary, produce a

497+-- | Given a buffer, flags, and file path, produce a

358-- 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

359parseFileContents

499parseFileContents

360 :: GhcMonad m

500 :: GhcMonad m

361 => (GHC.ParsedSource -> IdePreprocessedSource)

501 => (GHC.ParsedSource -> IdePreprocessedSource)

362 -> DynFlags -- ^ flags to use

502 -> DynFlags -- ^ flags to use

503+ -> [PackageName] -- ^ The package imports to ignore

363 -> FilePath -- ^ the filename (for source locations)

504 -> FilePath -- ^ the filename (for source locations)

364 -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)

505 -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)

365 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)

506 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)

366−parseFileContents customPreprocessor dflags filename contents = do

507+parseFileContents customPreprocessor dflags comp_pkgs filename contents = do

367 let loc = mkRealSrcLoc (mkFastString filename) 1 1

508 let loc = mkRealSrcLoc (mkFastString filename) 1 1

368 case unP Parser.parseModule (mkPState dflags contents loc) of

509 case unP Parser.parseModule (mkPState dflags contents loc) of

369#if MIN_GHC_API_VERSION(8,10,0)

510#if MIN_GHC_API_VERSION(8,10,0)

@@ -395,14 +536,63 @@ parseFileContents customPreprocessor dflags filename contents = do

395 -- Ok, we got here. It's safe to continue.

536 -- Ok, we got here. It's safe to continue.

396 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

537 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

397 unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs

538 unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs

539+ let parsed' = removePackageImports comp_pkgs parsed

398 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

540 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

399− ms <- getModSummaryFromBuffer filename contents dflags parsed

541+ ms <- getModSummaryFromBuffer filename dflags parsed'

400 let pm =

542 let pm =

401 ParsedModule {

543 ParsedModule {

402 pm_mod_summary = ms

544 pm_mod_summary = ms

403− , pm_parsed_source = parsed

545+ , pm_parsed_source = parsed'

404 , pm_extra_src_files=[] -- src imports not allowed

546 , pm_extra_src_files=[] -- src imports not allowed

405 , pm_annotations = hpm_annotations

547 , pm_annotations = hpm_annotations

406 }

548 }

407 warnings = diagFromErrMsgs "parser" dflags warns

549 warnings = diagFromErrMsgs "parser" dflags warns

408 pure (warnings ++ preproc_warnings, pm)

550 pure (warnings ++ preproc_warnings, pm)

551+

552+

553+-- | After parsing the module remove all package imports referring to

554+-- these packages as we have already dealt with what they map to.

555+removePackageImports :: [PackageName] -> GHC.ParsedSource -> GHC.ParsedSource

556+removePackageImports pkgs (L l h@HsModule {hsmodImports} ) = L l (h { hsmodImports = imports' })

557+ where

558+ imports' = map do_one_import hsmodImports

559+ do_one_import (L l i@ImportDecl{ideclPkgQual}) =

560+ case PackageName . sl_fs <$> ideclPkgQual of

561+ Just pn | pn `elem` pkgs -> L l (i { ideclPkgQual = Nothing })

562+ _ -> L l i

563+#if MIN_GHC_API_VERSION(8,6,0)

564+ do_one_import l = l

565+#endif

566+

567+loadHieFile :: FilePath -> IO GHC.HieFile

568+loadHieFile f = do

569+ u <- mkSplitUniqSupply 'a'

570+ let nameCache = initNameCache u []

571+ fmap (GHC.hie_file_result . fst) $ GHC.readHieFile nameCache f

572+

573+-- | Retuns an up-to-date module interface if available.

574+-- Assumes file exists.

575+-- Requires the 'HscEnv' to be set up with dependencies

576+loadInterface

577+ :: HscEnv

578+ -> ModSummary

579+ -> [HiFileResult]

580+ -> IO (Either String ModIface)

581+loadInterface session ms deps = do

582+ let hiFile = case ms_hsc_src ms of

583+ HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)

584+ _ -> ml_hi_file $ ms_location ms

585+ r <- initIfaceLoad session $ readIface (ms_mod ms) hiFile

586+ case r of

587+ Maybes.Succeeded iface -> do

588+ session' <- foldM (\e d -> loadDepModuleIO (hirModIface d) Nothing e) session deps

589+ (reason, iface') <- checkOldIface session' ms SourceUnmodified (Just iface)

590+ return $ maybeToEither (showReason reason) iface'

591+ Maybes.Failed err -> do

592+ let errMsg = showSDoc (hsc_dflags session) err

593+ return $ Left errMsg

594+

595+showReason :: RecompileRequired -> String

596+showReason MustCompile = "Stale"

597+showReason (RecompBecause reason) = "Stale (" ++ reason ++ ")"

598+showReason UpToDate = "Up to date"

src/Development/IDE/Core/FileExists.hs+23−38

@@ -22,6 +22,7 @@ import Development.IDE.Core.FileStore

22import Development.IDE.Core.IdeConfiguration

23import Development.IDE.Core.Shake

24import Development.IDE.Types.Location

25+import Development.IDE.Types.Logger

25import Development.Shake

26import Development.Shake

26import Development.Shake.Classes

27import Development.Shake.Classes

27import GHC.Generics

28import GHC.Generics

@@ -90,20 +91,29 @@ getFileExists fp = use_ GetFileExists fp

90-- Provides a fast implementation if client supports dynamic watched files.

91-- Provides a fast implementation if client supports dynamic watched files.

91-- Creates a global state as a side effect in that case.

92-- Creates a global state as a side effect in that case.

92fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules ()

93fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules ()

93−fileExistsRules getLspId ClientCapabilities{_workspace}

94+fileExistsRules getLspId ClientCapabilities{_workspace} vfs = do

95+ -- Create the global always, although it should only be used if we have fast rules.

96+ -- But there's a chance someone will send unexpected notifications anyway,

97+ -- e.g. https://github.com/digital-asset/ghcide/issues/599

98+ addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])

99+ case () of

94− | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace

100+ _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace

95− , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles

101+ , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles

96− , Just True <- _dynamicRegistration

102+ , Just True <- _dynamicRegistration

97− = fileExistsRulesFast getLspId

103+ -> fileExistsRulesFast getLspId vfs

104+ | otherwise -> do

105+ logger <- logger <$> getShakeExtrasRules

106+ liftIO $ logDebug logger "Warning: Client does not support watched files. Falling back to OS polling"

98− | otherwise = fileExistsRulesSlow

107+ fileExistsRulesSlow vfs

108

100-- Requires an lsp client that provides WatchedFiles notifications.

109-- Requires an lsp client that provides WatchedFiles notifications.

101fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()

110fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()

102−fileExistsRulesFast getLspId vfs = do

111+fileExistsRulesFast getLspId vfs =

103− addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])

104 defineEarlyCutoff $ \GetFileExists file -> do

112 defineEarlyCutoff $ \GetFileExists file -> do

105 isWf <- isWorkspaceFile file

113 isWf <- isWorkspaceFile file

114+ if isWf

106− if isWf then fileExistsFast getLspId vfs file else fileExistsSlow vfs file

115+ then fileExistsFast getLspId vfs file

116+ else fileExistsSlow vfs file

107

117

108fileExistsFast :: IO LspId -> VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))

118fileExistsFast :: IO LspId -> VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))

109fileExistsFast getLspId vfs file = do

119fileExistsFast getLspId vfs file = do

@@ -140,9 +150,10 @@ fileExistsFast getLspId vfs file = do

140 WorkspaceDidChangeWatchedFiles

150 WorkspaceDidChangeWatchedFiles

141 (Just (A.toJSON regOptions))

151 (Just (A.toJSON regOptions))

142 regOptions =

152 regOptions =

143− DidChangeWatchedFilesRegistrationOptions { watchers = List [watcher] }

153+ DidChangeWatchedFilesRegistrationOptions { _watchers = List [watcher] }

154+ watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True}

144− watcher = FileSystemWatcher { globPattern = fromNormalizedFilePath fp

155+ watcher = FileSystemWatcher { _globPattern = fromNormalizedFilePath fp

145− , kind = Just 5 -- Create and Delete events only

156+ , _kind = Just watchKind

146 }

157 }

147

158

148 eventer $ ReqRegisterCapability req

159 eventer $ ReqRegisterCapability req

@@ -168,29 +179,3 @@ getFileExistsVFS vfs file = do

168 handle (\(_ :: IOException) -> return False) $

179 handle (\(_ :: IOException) -> return False) $

169 (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^

180 (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^

170 Dir.doesFileExist (fromNormalizedFilePath file)

181 Dir.doesFileExist (fromNormalizedFilePath file)

171−

172−--------------------------------------------------------------------------------------------------

173−-- The message definitions below probably belong in haskell-lsp-types

174−

175−data DidChangeWatchedFilesRegistrationOptions = DidChangeWatchedFilesRegistrationOptions

176− { watchers :: List FileSystemWatcher

177− }

178−

179−instance A.ToJSON DidChangeWatchedFilesRegistrationOptions where

180− toJSON DidChangeWatchedFilesRegistrationOptions {..} =

181− A.object ["watchers" A..= watchers]

182−

183−data FileSystemWatcher = FileSystemWatcher

184− { -- | The glob pattern to watch.

185− -- For details on glob pattern syntax, check the spec: https://microsoft.github.io/language-server-protocol/specifications/specification-3-14/#workspace_didChangeWatchedFiles

186− globPattern :: String

187− -- | The kind of event to subscribe to. Defaults to all.

188− -- Defined as a bitmap of Create(1), Change(2), and Delete(4)

189− , kind :: Maybe Int

190− }

191−

192−instance A.ToJSON FileSystemWatcher where

193− toJSON FileSystemWatcher {..} =

194− A.object

195− $ ["globPattern" A..= globPattern]

196− ++ [ "kind" A..= x | Just x <- [kind] ]

src/Development/IDE/Core/IdeConfiguration.hs+11−6

@@ -17,6 +17,7 @@ import Development.IDE.Core.Shake

17import Development.IDE.Types.Location

18import Development.Shake

19import Language.Haskell.LSP.Types

20+import System.FilePath (isRelative)

21-- | Lsp client relevant configuration details

22-- | Lsp client relevant configuration details

22data IdeConfiguration = IdeConfiguration

23data IdeConfiguration = IdeConfiguration

@@ -58,9 +59,13 @@ modifyWorkspaceFolders ide f = do

58 writeVar var (IdeConfiguration (f ws))

59 writeVar var (IdeConfiguration (f ws))

60isWorkspaceFile :: NormalizedFilePath -> Action Bool

61isWorkspaceFile :: NormalizedFilePath -> Action Bool

61−isWorkspaceFile file = do

62+isWorkspaceFile file =

63+ if isRelative (fromNormalizedFilePath file)

64+ then return True

65+ else do

62− IdeConfiguration {..} <- getIdeConfiguration

66+ IdeConfiguration {..} <- getIdeConfiguration

63− let toText = getUri . fromNormalizedUri

67+ let toText = getUri . fromNormalizedUri

64− return $ any

68+ return $

69+ any

65− (\root -> toText root `isPrefixOf` toText (filePathToUri' file))

70+ (\root -> toText root `isPrefixOf` toText (filePathToUri' file))

66− workspaceFolders

71+ workspaceFolders

src/Development/IDE/Core/PositionMapping.hs+48−10

@@ -2,10 +2,15 @@

2-- SPDX-License-Identifier: Apache-2.0

3module Development.IDE.Core.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

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 }

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

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)

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

src/Development/IDE/Core/Preprocessor.hs+15−13

@@ -29,11 +29,15 @@ import Data.IORef (IORef, modifyIORef, newIORef, readIORef)

29import Data.Text (Text)

30import qualified Data.Text as T

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)

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

100

97diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic]

101diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic]

98diagsFromCPPLogs filename logs =

102diagsFromCPPLogs filename logs =

99− map (\d -> (toNormalizedFilePath filename, ShowDiag, cppDiagToDiagnostic d)) $

103+ map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $

100 go [] logs

104 go [] logs

101 where

105 where

102 -- On errors, CPP calls logAction with a real span for the initial log and

106 -- On errors, CPP calls logAction with a real span for the initial log and

@@ -118,7 +122,8 @@ diagsFromCPPLogs filename logs =

118 _code = Nothing,

122 _code = Nothing,

119 _source = Just "CPP",

123 _source = Just "CPP",

120 _message = T.unlines $ cdMessage d,

124 _message = T.unlines $ cdMessage d,

121− _relatedInformation = Nothing

125+ _relatedInformation = Nothing,

126+ _tags = Nothing

122 }

127 }

123

128

124

129

@@ -128,13 +133,17 @@ isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]

128

133

129-- | This reads the pragma information directly from the provided buffer.

134-- | This reads the pragma information directly from the provided buffer.

130parsePragmasIntoDynFlags

135parsePragmasIntoDynFlags

131− :: GhcMonad m

136+ :: (ExceptionMonad m, HasDynFlags m, MonadIO m)

132 => FilePath

137 => FilePath

133 -> SB.StringBuffer

138 -> SB.StringBuffer

134 -> m (Either [FileDiagnostic] DynFlags)

139 -> m (Either [FileDiagnostic] DynFlags)

135parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do

140parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do

136− dflags0 <- getSessionDynFlags

141+ dflags0 <- getDynFlags

137 let opts = Hdr.getOptions dflags0 contents fp

142 let opts = Hdr.getOptions dflags0 contents fp

143+

144+ -- Force bits that might keep the dflags and stringBuffer alive unnecessarily

145+ liftIO $ evaluate $ rnf opts

146+

138 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts

147 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts

139 return dflags

148 return dflags

140

149

@@ -166,18 +175,11 @@ runLhs dflags filename contents = withTempDir $ \dir -> do

166 escape (c:cs) = c : escape cs

175 escape (c:cs) = c : escape cs

167 escape [] = []

176 escape [] = []

168

177

169−

170−modifyOptP :: ([String] -> [String]) -> DynFlags -> DynFlags

171−modifyOptP op = onSettings (onOptP op)

172− where

173− onSettings f x = x{settings = f $ settings x}

174− onOptP f x = x{sOpt_P = f $ sOpt_P x}

175−

176-- | Run CPP on a file

178-- | Run CPP on a file

177runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer

179runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer

178runCpp dflags filename contents = withTempDir $ \dir -> do

180runCpp dflags filename contents = withTempDir $ \dir -> do

179 let out = dir </> takeFileName filename <.> "out"

181 let out = dir </> takeFileName filename <.> "out"

180− dflags <- pure $ modifyOptP ("-D__GHCIDE__":) dflags

182+ dflags <- pure $ addOptP "-D__GHCIDE__" dflags

181

183

182 case contents of

184 case contents of

183 Nothing -> do

185 Nothing -> do

src/Development/IDE/Core/RuleTypes.hs+48−9

@@ -24,7 +24,6 @@ import GHC.Generics (Generic)

24import GHC

25import Module (InstalledUnitId)

26import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)

27−import Development.IDE.GHC.Compat

29import Development.IDE.Spans.Type

28import Development.IDE.Spans.Type

30import Development.IDE.Import.FindImports (ArtifactsLocation)

29import Development.IDE.Import.FindImports (ArtifactsLocation)

@@ -58,6 +57,22 @@ instance Show TcModuleResult where

58instance NFData TcModuleResult where

57instance NFData TcModuleResult where

59 rnf = rwhnf

58 rnf = rwhnf

60+tmrModSummary :: TcModuleResult -> ModSummary

61+tmrModSummary = pm_mod_summary . tm_parsed_module . tmrModule

62+

63+data HiFileResult = HiFileResult

64+ { hirModSummary :: !ModSummary

65+ -- Bang patterns here are important to stop the result retaining

66+ -- a reference to a typechecked module

67+ , hirModIface :: !ModIface

68+ }

69+

70+instance NFData HiFileResult where

71+ rnf = rwhnf

72+

73+instance Show HiFileResult where

74+ show = show . hirModSummary

75+

61-- | The type checked version of this file, requires TypeCheck+

76-- | The type checked version of this file, requires TypeCheck+

62type instance RuleResult TypeCheck = TcModuleResult

77type instance RuleResult TypeCheck = TcModuleResult

@@ -82,9 +97,17 @@ type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe Artifa

82-- we can only report diagnostics for the current file.

97-- we can only report diagnostics for the current file.

83type instance RuleResult ReportImportCycles = ()

98type instance RuleResult ReportImportCycles = ()

85−-- | Read the given HIE file.

100+-- | Read the module interface file

86−type instance RuleResult GetHieFile = HieFile

101+type instance RuleResult GetHiFile = HiFileResult

102+

103+-- | Get a module interface, either from an interface file or a typechecked module

104+type instance RuleResult GetModIface = HiFileResult

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

89data GetParsedModule = GetParsedModule

112data GetParsedModule = GetParsedModule

90 deriving (Eq, Show, Typeable, Generic)

113 deriving (Eq, Show, Typeable, Generic)

@@ -146,10 +169,26 @@ instance Hashable GhcSession

146instance NFData GhcSession

169instance NFData GhcSession

147instance Binary GhcSession

170instance Binary GhcSession

148

171

149−-- Note that we embed the filepath here instead of using the filepath associated with Shake keys.

172+data GetHiFile = GetHiFile

150−-- Otherwise we will garbage collect the result since files in package dependencies will not be declared reachable.

173+ deriving (Eq, Show, Typeable, Generic)

151−data GetHieFile = GetHieFile FilePath

174+instance Hashable GetHiFile

175+instance NFData GetHiFile

176+instance Binary GetHiFile

177+

178+data GetModIface = GetModIface

179+ deriving (Eq, Show, Typeable, Generic)

180+instance Hashable GetModIface

181+instance NFData GetModIface

182+instance Binary GetModIface

183+

184+data IsFileOfInterest = IsFileOfInterest

185+ deriving (Eq, Show, Typeable, Generic)

186+instance Hashable IsFileOfInterest

187+instance NFData IsFileOfInterest

188+instance Binary IsFileOfInterest

189+

190+data GetModSummary = GetModSummary

152 deriving (Eq, Show, Typeable, Generic)

191 deriving (Eq, Show, Typeable, Generic)

153−instance Hashable GetHieFile

192+instance Hashable GetModSummary

154−instance NFData GetHieFile

193+instance NFData GetModSummary

155−instance Binary GetHieFile

194+instance Binary GetModSummary

src/Development/IDE/Core/Rules.hs+415−114

@@ -1,10 +1,11 @@

2-- SPDX-License-Identifier: Apache-2.0

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"

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(

28import Fingerprint

29import Fingerprint

30−import Data.Binary

31+import Data.Binary hiding (get, put)

31−import Data.Bifunctor (second)

32+import Data.Bifunctor (first, second)

32−import Control.Monad

33+import 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,31 +45,37 @@ 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

55+import Data.Ord

53import qualified Data.Set as Set

56import qualified Data.Set as Set

54import qualified Data.Text as T

57import qualified Data.Text as T

55import Development.IDE.GHC.Error

58import Development.IDE.GHC.Error

56import Development.Shake hiding (Diagnostic)

59import Development.Shake hiding (Diagnostic)

57import Development.IDE.Core.RuleTypes

60import Development.IDE.Core.RuleTypes

58import Development.IDE.Spans.Type

61import Development.IDE.Spans.Type

62+import qualified Data.ByteString.Char8 as BS

60import qualified GHC.LanguageExtensions as LangExt

64import qualified GHC.LanguageExtensions as LangExt

61−import UniqSupply

62−import NameCache

63import HscTypes

65import HscTypes

66+import PackageConfig

64−import DynFlags (xopt)

67+import DynFlags (gopt_set, xopt)

65import GHC.Generics(Generic)

68import GHC.Generics(Generic)

67import qualified Development.IDE.Spans.AtPoint as AtPoint

70import qualified Development.IDE.Spans.AtPoint as AtPoint

68import Development.IDE.Core.Service

71import Development.IDE.Core.Service

69import Development.IDE.Core.Shake

72import Development.IDE.Core.Shake

70−import Development.Shake.Classes

73+import Development.Shake.Classes hiding (get, put)

74+import Control.Monad.Trans.Except (runExceptT)

75+import Data.ByteString (ByteString)

76+import Control.Concurrent.Async (concurrently)

77+

78+import Control.Monad.State

72-- | This is useful for rules to convert rules that can only produce errors or

80-- | This is useful for rules to convert rules that can only produce errors or

73-- a result into the more general IdeResult type that supports producing

81-- a result into the more general IdeResult type that supports producing

@@ -81,14 +89,14 @@ useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v

81useE k = MaybeT . use k

89useE k = MaybeT . use k

83useNoFileE :: IdeRule k v => k -> MaybeT Action v

91useNoFileE :: IdeRule k v => k -> MaybeT Action v

84−useNoFileE k = useE k ""

92+useNoFileE k = useE k emptyFilePath

86usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]

94usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]

87usesE k = MaybeT . fmap sequence . uses k

95usesE k = MaybeT . fmap sequence . uses k

89defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()

97defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()

90defineNoFile f = define $ \k file -> do

98defineNoFile f = define $ \k file -> do

91− if file == "" then do res <- f k; return ([], Just res) else

99+ if file == emptyFilePath then do res <- f k; return ([], Just res) else

92 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"

100 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"

101

102

@@ -112,9 +120,58 @@ getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)

112getDefinition file pos = fmap join $ runMaybeT $ do

120getDefinition file pos = fmap join $ runMaybeT $ do

113 opts <- lift getIdeOptions

121 opts <- lift getIdeOptions

114 spans <- useE GetSpanInfo file

122 spans <- useE GetSpanInfo file

115− pkgState <- hscEnv <$> useE GhcSession file

116− let getHieFile x = useNoFile (GetHieFile x)

117− lift $ AtPoint.gotoDefinition getHieFile opts pkgState (spansExprs spans) pos

123+ lift $ AtPoint.gotoDefinition (getHieFile file) opts (spansExprs spans) pos

124+

125+getHieFile

126+ :: NormalizedFilePath -- ^ file we're editing

127+ -> Module -- ^ module dep we want info for

128+ -> Action (Maybe (HieFile, FilePath)) -- ^ hie stuff for the module

129+getHieFile file mod = do

130+ TransitiveDependencies {transitiveNamedModuleDeps} <- use_ GetDependencies file

131+ case find (\x -> nmdModuleName x == moduleName mod) transitiveNamedModuleDeps of

132+ Just NamedModuleDep{nmdFilePath=nfp} -> do

133+ let modPath = fromNormalizedFilePath nfp

134+ (_diags, hieFile) <- getHomeHieFile nfp

135+ return $ (, modPath) <$> hieFile

136+ _ -> getPackageHieFile mod file

137+

138+

139+getHomeHieFile :: NormalizedFilePath -> Action ([a], Maybe HieFile)

140+getHomeHieFile f = do

141+ ms <- use_ GetModSummary f

142+ let normal_hie_f = toNormalizedFilePath' hie_f

143+ hie_f = ml_hie_file $ ms_location ms

144+ mbHieTimestamp <- use GetModificationTime normal_hie_f

145+ srcTimestamp <- use_ GetModificationTime f

146+ let isUpToDate

147+ | Just d <- mbHieTimestamp = comparing modificationTime d srcTimestamp == GT

148+ | otherwise = False

149+

150+ unless isUpToDate $

151+ void $ use_ TypeCheck f

152+

153+ hf <- liftIO $ whenMaybe isUpToDate (loadHieFile hie_f)

154+ return ([], hf)

155+

156+getPackageHieFile :: Module -- ^ Package Module to load .hie file for

157+ -> NormalizedFilePath -- ^ Path of home module importing the package module

158+ -> Action (Maybe (HieFile, FilePath))

159+getPackageHieFile mod file = do

160+ pkgState <- hscEnv <$> use_ GhcSession file

161+ IdeOptions {..} <- getIdeOptions

162+ let unitId = moduleUnitId mod

163+ case lookupPackageConfig unitId pkgState of

164+ Just pkgConfig -> do

165+ -- 'optLocateHieFile' returns Nothing if the file does not exist

166+ hieFile <- liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod

167+ path <- liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod

168+ case (hieFile, path) of

169+ (Just hiePath, Just modPath) ->

170+ -- deliberately loaded outside the Shake graph

171+ -- to avoid dependencies on non-workspace files

172+ liftIO $ Just . (, modPath) <$> loadHieFile hiePath

173+ _ -> return Nothing

174+ _ -> return Nothing

118

175

119-- | Parse the contents of a daml file.

176-- | Parse the contents of a daml file.

120getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)

177getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)

@@ -134,31 +191,60 @@ priorityFilesOfInterest :: Priority

134priorityFilesOfInterest = Priority (-2)

191priorityFilesOfInterest = Priority (-2)

135

192

136getParsedModuleRule :: Rules ()

193getParsedModuleRule :: Rules ()

137−getParsedModuleRule =

138− defineEarlyCutoff $ \GetParsedModule file -> do

194+getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do

139− (_, contents) <- getFileContents file

140− packageState <- hscEnv <$> use_ GhcSession file

195+ sess <- use_ GhcSession file

196+ let hsc = hscEnv sess

197+ -- These packages are used when removing PackageImports from a

198+ -- parsed module

199+ comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)

141− opt <- getIdeOptions

200+ opt <- getIdeOptions

201+ (_, contents) <- getFileContents file

202+

203+ let dflags = hsc_dflags hsc

204+ mainParse = getParsedModuleDefinition hsc opt comp_pkgs file contents

205+

206+ -- Parse again (if necessary) to capture Haddock parse errors

207+ if gopt Opt_Haddock dflags

208+ then

209+ liftIO mainParse

210+ else do

211+ let hscHaddock = hsc{hsc_dflags = gopt_set dflags Opt_Haddock}

212+ haddockParse = do

213+ (_, (!diagsHaddock, _)) <-

214+ getParsedModuleDefinition hscHaddock opt comp_pkgs file contents

215+ return diagsHaddock

216+

217+ ((fingerPrint, (diags, res)), diagsHaddock) <-

218+ -- parse twice, with and without Haddocks, concurrently

219+ -- we cannot ignore Haddock parse errors because files of

220+ -- non-interest are always parsed with Haddocks

221+ liftIO $ concurrently mainParse haddockParse

222+

223+ return (fingerPrint, (mergeDiagnostics diags diagsHaddock, res))

224+

225+getParsedModuleDefinition :: HscEnv -> IdeOptions -> [PackageName] -> NormalizedFilePath -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))

226+getParsedModuleDefinition packageState opt comp_pkgs file contents = do

142− (diag, res) <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) (fmap textToStringBuffer contents)

227+ (diag, res) <- parseModule opt packageState comp_pkgs (fromNormalizedFilePath file) (fmap textToStringBuffer contents)

143− case res of

228+ case res of

144− Nothing -> pure (Nothing, (diag, Nothing))

229+ Nothing -> pure (Nothing, (diag, Nothing))

145− Just (contents, modu) -> do

230+ Just (contents, modu) -> do

146− mbFingerprint <- if isNothing $ optShakeFiles opt

231+ mbFingerprint <- if isNothing $ optShakeFiles opt

147− then pure Nothing

232+ then pure Nothing

148− else liftIO $ Just . fingerprintToBS <$> fingerprintFromStringBuffer contents

233+ else Just . fingerprintToBS <$> fingerprintFromStringBuffer contents

149− pure (mbFingerprint, (diag, Just modu))

234+ pure (mbFingerprint, (diag, Just modu))

150

235

151getLocatedImportsRule :: Rules ()

236getLocatedImportsRule :: Rules ()

152getLocatedImportsRule =

237getLocatedImportsRule =

153 define $ \GetLocatedImports file -> do

238 define $ \GetLocatedImports file -> do

154− pm <- use_ GetParsedModule file

239+ ms <- use_ GetModSummary file

155− let ms = pm_mod_summary pm

156 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]

157− env <- hscEnv <$> use_ GhcSession file

241+ env_eq <- use_ GhcSession file

242+ let env = hscEnv env_eq

243+ let import_dirs = deps env_eq

158− let dflags = addRelativeImport file pm $ hsc_dflags env

244+ let dflags = addRelativeImport file (moduleName $ ms_mod ms) $ hsc_dflags env

159 opt <- getIdeOptions

245 opt <- getIdeOptions

160 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do

246 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do

161− diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource

247+ diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getFileExists modName mbPkgName isSource

162 case diagOrImp of

248 case diagOrImp of

163 Left diags -> pure (diags, Left (modName, Nothing))

249 Left diags -> pure (diags, Left (modName, Nothing))

164 Right (FileImport path) -> pure ([], Left (modName, Just path))

250 Right (FileImport path) -> pure ([], Left (modName, Just path))

@@ -172,48 +258,109 @@ getLocatedImportsRule =

172 Nothing -> pure (concat diags, Nothing)

258 Nothing -> pure (concat diags, Nothing)

173 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))

259 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))

174

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+ )

175

269

176-- | 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

177-- imports recursively.

271-- imports recursively.

178−rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation

272+rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation

179−rawDependencyInformation f = do

273+rawDependencyInformation fs = do

180− let (initialId, initialMap) = getPathId (ArtifactsLocation $ ModLocation (Just $ fromNormalizedFilePath f) "" "") emptyPathIdMap

274+ (rdi, ss) <- execRawDepM (mapM_ go fs)

181− go (IntSet.singleton $ getFilePathId initialId)

275+ let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss

182− (RawDependencyInformation IntMap.empty initialMap)

276+ return (rdi { rawBootMap = bm })

183 where

277 where

184− go fs rawDepInfo =

278+ go :: NormalizedFilePath -- ^ Current module being processed

185− case IntSet.minView fs of

279+ -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId

186− -- Queue is empty

280+ go f = do

187− Nothing -> pure rawDepInfo

281+ -- First check to see if we have already processed the FilePath

188− -- Pop f from the queue and process it

282+ -- If we have, just return its Id but don't update any of the state.

189− Just (f, fs) -> do

283+ -- Otherwise, we need to process its imports.

190− 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

191− importsOrErr <- use GetLocatedImports $ idToPath (rawPathIdMap rawDepInfo) fId

292+ importsOrErr <- lift $ use GetLocatedImports f

192− case importsOrErr of

293+ case importsOrErr of

193− Nothing ->

294+ Nothing -> do

194− -- 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

195− let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo

298+ modifyRawDepInfo (insertImport fId (Left ModuleParseError))

196− in go fs rawDepInfo'

299+ return fId

197− Just (modImports, pkgImports) -> do

300+ Just (modImports, pkgImports) -> do

198− let f :: PathIdMap -> (a, Maybe ArtifactsLocation) -> (PathIdMap, (a, Maybe FilePathId))

301+ -- Get NFPs of the imports which have corresponding files

199− f pathMap (imp, mbPath) = case mbPath of

302+ -- Imports either come locally from a file or from a package.

200− Nothing -> (pathMap, (imp, Nothing))

303+ let (no_file, with_file) = splitImports modImports

201− Just path ->

304+ (mns, ls) = unzip with_file

202− let (pathId, pathMap') = getPathId path pathMap

305+ -- Recursively process all the imports we just learnt about

203− in (pathMap', (imp, Just pathId))

306+ -- and get back a list of their FilePathIds

204− -- Convert paths in imports to ids and update the path map

307+ fids <- mapM (go . artifactFilePath) ls

205− let (pathIdMap, modImports') = mapAccumL f (rawPathIdMap rawDepInfo) modImports

308+ -- Associate together the ModuleName with the FilePathId

206− -- Files that we haven’t seen before are added to the queue.

309+ let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids)

207− let newFiles =

310+ -- Insert into the map the information about this modules

208− IntSet.fromList (coerce $ mapMaybe snd modImports')

311+ -- imports.

209− IntSet.\\ IntMap.keysSet (rawImports rawDepInfo)

210− let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo

312+ modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports' pkgImports)

211− 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"

212

359

213getDependencyInformationRule :: Rules ()

360getDependencyInformationRule :: Rules ()

214getDependencyInformationRule =

361getDependencyInformationRule =

215 define $ \GetDependencyInformation file -> do

362 define $ \GetDependencyInformation file -> do

216− rawDepInfo <- rawDependencyInformation file

363+ rawDepInfo <- rawDependencyInformation [file]

217 pure ([], Just $ processDependencyInformation rawDepInfo)

364 pure ([], Just $ processDependencyInformation rawDepInfo)

218

365

219reportImportCyclesRule :: Rules ()

366reportImportCyclesRule :: Rules ()

@@ -241,12 +388,13 @@ reportImportCyclesRule =

241 , _message = "Cyclic module dependency between " <> showCycle mods

388 , _message = "Cyclic module dependency between " <> showCycle mods

242 , _code = Nothing

389 , _code = Nothing

243 , _relatedInformation = Nothing

390 , _relatedInformation = Nothing

391+ , _tags = Nothing

244 }

392 }

245 where loc = srcSpanToLocation (getLoc imp)

393 where loc = srcSpanToLocation (getLoc imp)

246− fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)

394+ fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp)

247 getModuleName file = do

395 getModuleName file = do

248− pm <- use_ GetParsedModule file

396+ ms <- use_ GetModSummary file

249− pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)

397+ pure (moduleNameString . moduleName . ms_mod $ ms)

250 showCycle mods = T.intercalate ", " (map T.pack mods)

398 showCycle mods = T.intercalate ", " (map T.pack mods)

251

399

252-- returns all transitive dependencies in topological order.

400-- returns all transitive dependencies in topological order.

@@ -266,50 +414,101 @@ getSpanInfoRule :: Rules ()

266getSpanInfoRule =

414getSpanInfoRule =

267 define $ \GetSpanInfo file -> do

415 define $ \GetSpanInfo file -> do

268 tc <- use_ TypeCheck file

416 tc <- use_ TypeCheck file

417+ packageState <- hscEnv <$> use_ GhcSession file

269 deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file

418 deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file

270− 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

271 (fileImports, _) <- use_ GetLocatedImports file

430 (fileImports, _) <- use_ GetLocatedImports file

272− packageState <- hscEnv <$> use_ GhcSession file

431+ let imports = second (fmap artifactFilePath) <$> fileImports

273− x <- liftIO $ getSrcSpanInfos packageState (fmap (second (fmap modLocationToNormalizedFilePath)) fileImports) tc parsedDeps

432+ x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps (map hirModIface ifaces)

274 return ([], Just x)

433 return ([], Just x)

275

434

276-- Typechecks a module.

435-- Typechecks a module.

277typeCheckRule :: Rules ()

436typeCheckRule :: Rules ()

278−typeCheckRule =

279− define $ \TypeCheck file -> do

437+typeCheckRule = define $ \TypeCheck file -> do

280− 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

281− deps <- use_ GetDependencies file

458+ deps <- use_ GetDependencies file

282− packageState <- hscEnv <$> use_ GhcSession file

459+ hsc <- hscEnv <$> use_ GhcSession file

283− -- Figure out whether we need TemplateHaskell or QuasiQuotes support

460+ -- Figure out whether we need TemplateHaskell or QuasiQuotes support

284− let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph packageState

461+ let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc

285− 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)

286− 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)

287− tms <- if any_uses_th_qq

465+ bytecodes <- if any_uses_th_qq

288− -- If we use TH or QQ, we must obtain the bytecode

466+ then -- If we use TH or QQ, we must obtain the bytecode

289− then do

290− bytecodes <- uses_ GenerateByteCode (transitiveModuleDeps deps)

467+ fmap Just <$> uses_ GenerateByteCode (transitiveModuleDeps deps)

291− tmrs <- uses_ TypeCheck (transitiveModuleDeps deps)

468+ else

292− pure (zipWith addByteCode bytecodes tmrs)

469+ pure $ repeat Nothing

293− else uses_ TypeCheck (transitiveModuleDeps deps)

470+

294− setPriority priorityTypeCheck

471+ setPriority priorityTypeCheck

295− IdeOptions{ optDefer = defer} <- getIdeOptions

472+ IdeOptions { optDefer = defer } <- getIdeOptions

473+

474+ addUsageDependencies $ liftIO $ do

296− 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)

297− where

483+ where

484+ unpack HiFileResult{..} bc = (hirModSummary, (hirModIface, bc))

485+ uses_th_qq dflags =

298− uses_th_qq dflags = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags

486+ xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags

487+

299− addByteCode :: Linkable -> TcModuleResult -> TcModuleResult

488+ addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)

300− addByteCode lm tmr = tmr { tmrModInfo = (tmrModInfo tmr) { hm_linkable = Just lm } }

489+ addUsageDependencies a = do

301−

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+

302−generateCore :: NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))

501+generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))

303−generateCore file = do

502+generateCore runSimplifier file = do

304 deps <- use_ GetDependencies file

503 deps <- use_ GetDependencies file

305 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)

504 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)

306 setPriority priorityGenerateCore

505 setPriority priorityGenerateCore

307 packageState <- hscEnv <$> use_ GhcSession file

506 packageState <- hscEnv <$> use_ GhcSession file

308− liftIO $ compileModule packageState tms tm

507+ liftIO $ compileModule runSimplifier packageState [(tmrModSummary x, tmrModInfo x) | x <- tms] tm

309

508

310generateCoreRule :: Rules ()

509generateCoreRule :: Rules ()

311generateCoreRule =

510generateCoreRule =

312− define $ \GenerateCore -> generateCore

511+ define $ \GenerateCore -> generateCore (RunSimplifier True)

313

512

314generateByteCodeRule :: Rules ()

513generateByteCodeRule :: Rules ()

315generateByteCodeRule =

514generateByteCodeRule =

@@ -318,7 +517,7 @@ generateByteCodeRule =

318 (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)

517 (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)

319 session <- hscEnv <$> use_ GhcSession file

518 session <- hscEnv <$> use_ GhcSession file

320 (_, guts, _) <- use_ GenerateCore file

519 (_, guts, _) <- use_ GenerateCore file

321− liftIO $ generateByteCode session tms tm guts

520+ liftIO $ generateByteCode session [(tmrModSummary x, tmrModInfo x) | x <- tms] tm guts

322

521

323-- 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

324-- 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.

@@ -330,7 +529,7 @@ instance Hashable GhcSessionIO

330instance NFData GhcSessionIO

529instance NFData GhcSessionIO

331instance Binary GhcSessionIO

530instance Binary GhcSessionIO

332

531

333−newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq)

532+newtype GhcSessionFun = GhcSessionFun (FilePath -> Action (IdeResult HscEnvEq))

334instance Show GhcSessionFun where show _ = "GhcSessionFun"

533instance Show GhcSessionFun where show _ = "GhcSessionFun"

335instance NFData GhcSessionFun where rnf !_ = ()

534instance NFData GhcSessionFun where rnf !_ = ()

336

535

@@ -340,19 +539,118 @@ loadGhcSession = do

340 defineNoFile $ \GhcSessionIO -> do

539 defineNoFile $ \GhcSessionIO -> do

341 opts <- getIdeOptions

540 opts <- getIdeOptions

342 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

343 defineEarlyCutoff $ \GhcSession file -> do

546 defineEarlyCutoff $ \GhcSession file -> do

344 GhcSessionFun fun <- useNoFile_ GhcSessionIO

547 GhcSessionFun fun <- useNoFile_ GhcSessionIO

548+ alwaysRerun

345 val <- fun $ fromNormalizedFilePath file

549 val <- fun $ fromNormalizedFilePath file

346− opts <- getIdeOptions

347− return ("" <$ optShakeFiles opts, ([], Just val))

348

550

551+ -- TODO: What was this doing before?

552+ opts <- getIdeOptions

553+ let cutoffHash =

554+ case optShakeFiles opts of

555+ -- optShakeFiles is only set in the DAML case.

556+ -- https://github.com/digital-asset/ghcide/pull/522#discussion_r428622915

557+ Just {} -> ""

558+ -- Hash the HscEnvEq returned so cutoff if it didn't change

559+ -- from last time

560+ Nothing -> BS.pack (show (hash (snd val)))

561+ return (Just cutoffHash, val)

562+

563+getHiFileRule :: Rules ()

564+getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do

565+ -- get all dependencies interface files, to check for freshness

566+ (deps,_) <- use_ GetLocatedImports f

567+ depHis <- traverse (use GetHiFile) (mapMaybe (fmap artifactFilePath . snd) deps)

568+

569+ ms <- use_ GetModSummary f

570+ let hiFile = toNormalizedFilePath'

571+ $ case ms_hsc_src ms of

572+ HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)

573+ _ -> ml_hi_file $ ms_location ms

574+

575+ case sequence depHis of

576+ Nothing -> pure (Nothing, ([], Nothing))

577+ Just deps -> do

578+ gotHiFile <- getFileExists hiFile

579+ if not gotHiFile

580+ then pure (Nothing, ([], Nothing))

581+ else do

582+ hiVersion <- use_ GetModificationTime hiFile

583+ modVersion <- use_ GetModificationTime f

584+ let sourceModified = modificationTime hiVersion < modificationTime modVersion

585+ if sourceModified

586+ then do

587+ pure (Nothing, ([], Nothing))

588+ else do

589+ session <- hscEnv <$> use_ GhcSession f

590+ r <- liftIO $ loadInterface session ms deps

591+ case r of

592+ Right iface -> do

593+ let result = HiFileResult ms iface

594+ return (Just (fingerprintToBS (getModuleHash iface)), ([], Just result))

595+ Left err -> do

596+ let diag = ideErrorWithSource (Just "interface file loading") (Just DsError) f . T.pack $ err

597+ return (Nothing, (pure diag, Nothing))

598+

599+getModSummaryRule :: Rules ()

600+getModSummaryRule = define $ \GetModSummary f -> do

601+ dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f

602+ (_, mFileContent) <- getFileContents f

603+ modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $

604+ getModSummaryFromImports (fromNormalizedFilePath f) (textToStringBuffer <$> mFileContent)

605+ return $ either (,Nothing) (([], ) . Just) modS

606+

607+getModIfaceRule :: Rules ()

608+getModIfaceRule = define $ \GetModIface f -> do

609+ fileOfInterest <- use_ IsFileOfInterest f

610+ let useHiFile =

611+ -- Never load interface files for files of interest

612+ not fileOfInterest

613+ mbHiFile <- if useHiFile then use GetHiFile f else return Nothing

614+ case mbHiFile of

615+ Just x ->

616+ return ([], Just x)

617+ Nothing

618+ | fileOfInterest -> do

619+ -- For files of interest only, create a Shake dependency on typecheck

620+ tmr <- use TypeCheck f

621+ return ([], extract tmr)

622+ | otherwise -> do

623+ -- the interface file does not exist or is out of date.

624+ -- Invoke typechecking directly to update it without incurring a dependency

625+ -- on the parsed module and the typecheck rules

626+ sess <- use_ GhcSession f

627+ let hsc = hscEnv sess

628+ -- After parsing the module remove all package imports referring to

629+ -- these packages as we have already dealt with what they map to.

630+ comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)

631+ opt <- getIdeOptions

632+ (_, contents) <- getFileContents f

633+ -- Embed --haddocks in the interface file

634+ hsc <- pure hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock}

635+ (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f contents

636+ case mb_pm of

637+ Nothing -> return (diags, Nothing)

638+ Just pm -> do

639+ (diags', tmr) <- typeCheckRuleDefinition f pm DoGenerateInterfaceFiles

640+ -- Bang pattern is important to avoid leaking 'tmr'

641+ let !res = extract tmr

642+ return (diags <> diags', res)

643+ where

644+ extract Nothing = Nothing

645+ extract (Just tmr) =

646+ -- Bang patterns are important to force the inner fields

647+ Just $! HiFileResult (tmrModSummary tmr) (hm_iface $ tmrModInfo tmr)

349

648

350−getHieFileRule :: Rules ()

649+isFileOfInterestRule :: Rules ()

351−getHieFileRule =

650+isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do

352− defineNoFile $ \(GetHieFile f) -> do

651+ filesOfInterest <- getFilesOfInterest

353− u <- liftIO $ mkSplitUniqSupply 'a'

652+ let res = f `elem` filesOfInterest

354− let nameCache = initNameCache u []

653+ return (Just (if res then "1" else ""), ([], Just res))

355− liftIO $ fmap (hie_file_result . fst) $ readHieFile nameCache f

356

654

357-- | A rule that wires per-file rules together

655-- | A rule that wires per-file rules together

358mainRule :: Rules ()

656mainRule :: Rules ()

@@ -367,4 +665,7 @@ mainRule = do

367 generateCoreRule

665 generateCoreRule

368 generateByteCodeRule

666 generateByteCodeRule

369 loadGhcSession

667 loadGhcSession

370− getHieFileRule

668+ getHiFileRule

669+ getModIfaceRule

670+ isFileOfInterestRule

671+ getModSummaryRule

src/Development/IDE/Core/Shake.hs+53−43

@@ -20,7 +20,7 @@

20-- between runs. To deserialise a Shake value, we just consult Values.

21module Development.IDE.Core.Shake(

22 IdeState, shakeExtras,

23− ShakeExtras(..), getShakeExtras,

23+ ShakeExtras(..), getShakeExtras, getShakeExtrasRules,

24 IdeRule, IdeResult, GetModificationTime(..),

25 shakeOpen, shakeShut,

26 shakeRun,

@@ -53,7 +53,7 @@ import qualified Data.ByteString.Char8 as BS

53import Data.Dynamic

54import Data.Maybe

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

58import qualified Data.Text as T

59import Data.Traversable (for)

@@ -69,7 +69,7 @@ import Development.IDE.Types.Location

69import Development.IDE.Types.Options

70import Control.Concurrent.Async

71import Control.Concurrent.Extra

72−import Control.Exception

72+import Control.Exception.Extra

73import Control.DeepSeq

74import System.Time.Extra

75import Data.Typeable

@@ -97,9 +97,11 @@ data ShakeExtras = ShakeExtras

97 ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])

98 -- ^ This represents the set of diagnostics that we have 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

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,25 +476,25 @@ 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

486 res <- uses key files

489 res <- uses key files

487 case sequence res of

490 case sequence res of

488− Nothing -> liftIO $ throwIO BadDependency

491+ Nothing -> liftIO $ throwIO $ BadDependency (show key)

489 Just v -> return v

492 Just v -> return v

490

493

491

494

492-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency

495-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency

493-- which short-circuits the rest of the action

496-- which short-circuits the rest of the action

494−data BadDependency = BadDependency deriving Show

497+data BadDependency = BadDependency String deriving Show

495instance Exception BadDependency

498instance Exception BadDependency

496

499

497isBadDependency :: SomeException -> Bool

500isBadDependency :: SomeException -> Bool

@@ -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

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

@@ -656,12 +660,12 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $

656needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()

660needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()

657needOnDisk k file = do

661needOnDisk k file = do

658 successfull <- apply1 (QDisk k file)

662 successfull <- apply1 (QDisk k file)

659− liftIO $ unless successfull $ throwIO BadDependency

663+ liftIO $ unless successfull $ throwIO $ BadDependency (show k)

660

664

661needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()

665needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()

662needOnDisks k files = do

666needOnDisks k files = do

663 successfulls <- apply $ map (QDisk k) files

667 successfulls <- apply $ map (QDisk k) files

664− liftIO $ unless (and successfulls) $ throwIO BadDependency

668+ liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k)

665

669

666toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue

670toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue

667toShakeValue = maybe ShakeNoCutoff

671toShakeValue = maybe ShakeNoCutoff

@@ -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/CPP.hs+22−1

@@ -19,7 +19,8 @@

19--

20-----------------------------------------------------------------------------

22−module Development.IDE.GHC.CPP(doCpp) where

22+module Development.IDE.GHC.CPP(doCpp, addOptP)

23+where

24import Development.IDE.GHC.Compat

25import Development.IDE.GHC.Compat

25import Packages

26import Packages

@@ -33,6 +34,10 @@ import LlvmCodeGen (llvmVersionList)

33#elif MIN_GHC_API_VERSION(8,8,0)

34#elif MIN_GHC_API_VERSION(8,8,0)

34import LlvmCodeGen (LlvmVersion (..))

35import LlvmCodeGen (LlvmVersion (..))

35#endif

36#endif

37+#if MIN_GHC_API_VERSION (8,10,0)

38+import Fingerprint

39+import ToolSettings

40+#endif

37import System.Directory

42import System.Directory

38import System.FilePath

43import System.FilePath

@@ -162,6 +167,22 @@ getBackendDefs dflags | hscTarget dflags == HscLlvm = do

162getBackendDefs _ =

167getBackendDefs _ =

163 return []

168 return []

164

169

170+addOptP :: String -> DynFlags -> DynFlags

171+#if MIN_GHC_API_VERSION (8,10,0)

172+addOptP f = alterToolSettings $ \s -> s

173+ { toolSettings_opt_P = f : toolSettings_opt_P s

174+ , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)

175+ }

176+ where

177+ fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss

178+ alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }

179+#else

180+addOptP opt = onSettings (onOptP (opt:))

181+ where

182+ onSettings f x = x{settings = f $ settings x}

183+ onOptP f x = x{sOpt_P = f $ sOpt_P x}

184+#endif

185+

165-- ---------------------------------------------------------------------------

186-- ---------------------------------------------------------------------------

166-- Macros (cribbed from Cabal)

187-- Macros (cribbed from Cabal)

167

188

src/Development/IDE/GHC/Compat.hs+177−17

@@ -7,24 +7,38 @@

8-- | Attempt at hiding the GHC version differences we can.

9module Development.IDE.GHC.Compat(

10+ getHeaderImports,

10 HieFileResult(..),

11 HieFileResult(..),

11− HieFile(..),

12+ HieFile,

13+ hieExportNames,

14+ hie_module,

12 mkHieFile,

15 mkHieFile,

13 writeHieFile,

16 writeHieFile,

14 readHieFile,

17 readHieFile,

18+ supportsHieFiles,

19+ setDefaultHieDir,

20+ dontWriteHieFiles,

21+#if !MIN_GHC_API_VERSION(8,8,0)

22+ ml_hie_file,

23+#endif

15 hPutStringBuffer,

24 hPutStringBuffer,

16 includePathsGlobal,

25 includePathsGlobal,

17 includePathsQuote,

26 includePathsQuote,

18 addIncludePathsQuote,

27 addIncludePathsQuote,

28+ getModuleHash,

29+ getPackageName,

19 pattern DerivD,

30 pattern DerivD,

20 pattern ForD,

31 pattern ForD,

21 pattern InstD,

32 pattern InstD,

22 pattern TyClD,

33 pattern TyClD,

23 pattern ValD,

34 pattern ValD,

24 pattern ClassOpSig,

35 pattern ClassOpSig,

36+ pattern IEThingAll,

25 pattern IEThingWith,

37 pattern IEThingWith,

26 GHC.ModLocation,

38 GHC.ModLocation,

39+ Module.addBootSuffix,

27 pattern ModLocation,

40 pattern ModLocation,

41+ getConArgs,

29 module GHC

43 module GHC

30 ) where

44 ) where

@@ -32,41 +46,62 @@ module Development.IDE.GHC.Compat(

32import StringBuffer

46import StringBuffer

33import DynFlags

47import DynFlags

34import FieldLabel

48import FieldLabel

49+import Fingerprint (Fingerprint)

50+import qualified Module

51+import Packages

36import qualified GHC

53import qualified GHC

54+import GHC hiding (

37−import GHC hiding (ClassOpSig, DerivD, ForD, 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

39#if MIN_GHC_API_VERSION(8,8,0)

69#if MIN_GHC_API_VERSION(8,8,0)

40−import HieAst

70+import Control.Applicative ((<|>))

71+import Development.IDE.GHC.HieAst (mkHieFile)

41import HieBin

72import HieBin

42import HieTypes

73import HieTypes

74+

75+supportsHieFiles :: Bool

76+supportsHieFiles = True

77+

78+hieExportNames :: HieFile -> [(SrcSpan, Name)]

79+hieExportNames = nameListFromAvails . hie_exports

80+

43#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)

44import GhcPlugins hiding (ModLocation)

92import GhcPlugins hiding (ModLocation)

45import NameCache

93import NameCache

46−import Avail

47import TcRnTypes

94import TcRnTypes

48import System.IO

95import System.IO

49import Foreign.ForeignPtr

96import Foreign.ForeignPtr

97+import MkIface

52−#if !MIN_GHC_API_VERSION(8,8,0)

53hPutStringBuffer :: Handle -> StringBuffer -> IO ()

100hPutStringBuffer :: Handle -> StringBuffer -> IO ()

54hPutStringBuffer hdl (StringBuffer buf len cur)

101hPutStringBuffer hdl (StringBuffer buf len cur)

55 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->

102 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->

56 hPutBuf hdl ptr len

103 hPutBuf hdl ptr len

57−#endif

58−

59−mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile

60−mkHieFile _ _ _ = return (HieFile () [])

104

62−writeHieFile :: FilePath -> HieFile -> IO ()

63−writeHieFile _ _ = return ()

64−

65−readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())

66−readHieFile _ _ = return (HieFileResult (HieFile () []), ())

67−

68−data HieFile = HieFile {hie_module :: (), hie_exports :: [AvailInfo]}

69−data HieFileResult = HieFileResult { hie_file_result :: HieFile }

70#endif

105#endif

106

72#if !MIN_GHC_API_VERSION(8,6,0)

107#if !MIN_GHC_API_VERSION(8,6,0)

@@ -147,3 +182,128 @@ pattern ModLocation a b c <-

147#else

182#else

148 GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c

183 GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c

149#endif

184#endif

185+

186+pattern IEThingAll :: LIEWrappedName (IdP pass) -> IE pass

187+pattern IEThingAll a <-

188+#if MIN_GHC_API_VERSION(8,6,0)

189+ GHC.IEThingAll _ a

190+#else

191+ GHC.IEThingAll a

192+#endif

193+

194+setDefaultHieDir :: FilePath -> DynFlags -> DynFlags

195+setDefaultHieDir _f d =

196+#if MIN_GHC_API_VERSION(8,8,0)

197+ d { hieDir = hieDir d <|> Just _f}

198+#else

199+ d

200+#endif

201+

202+dontWriteHieFiles :: DynFlags -> DynFlags

203+dontWriteHieFiles d =

204+#if MIN_GHC_API_VERSION(8,8,0)

205+ gopt_unset d Opt_WriteHie

206+#else

207+ d

208+#endif

209+

210+nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)]

211+nameListFromAvails as =

212+ map (\n -> (nameSrcSpan n, n)) (concatMap availNames as)

213+

214+#if !MIN_GHC_API_VERSION(8,8,0)

215+-- Reimplementations of functions for HIE files for GHC 8.6

216+

217+mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> ByteString -> Hsc HieFile

218+mkHieFile ms ts _ _ = return (HieFile (ms_mod ms) es)

219+ where

220+ es = nameListFromAvails (mkIfaceExports (tcg_exports ts))

221+

222+ml_hie_file :: GHC.ModLocation -> FilePath

223+ml_hie_file ml = ml_hi_file ml ++ ".hie"

224+

225+data HieFile = HieFile {hie_module :: Module, hie_exports :: [(SrcSpan, Name)]}

226+

227+hieExportNames :: HieFile -> [(SrcSpan, Name)]

228+hieExportNames = hie_exports

229+

230+instance Binary HieFile where

231+ put_ bh (HieFile m es) = do

232+ put_ bh m

233+ put_ bh es

234+

235+ get bh = do

236+ mod <- get bh

237+ es <- get bh

238+ return (HieFile mod es)

239+

240+data HieFileResult = HieFileResult { hie_file_result :: HieFile }

241+

242+writeHieFile :: FilePath -> HieFile -> IO ()

243+readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())

244+supportsHieFiles :: Bool

245+

246+#if MIN_GHC_API_VERSION(8,6,0)

247+

248+writeHieFile fp hie = do

249+ bh <- openBinMem (1024 * 1024)

250+ putWithUserData (const $ return ()) bh hie

251+ writeBinMem bh fp

252+

253+readHieFile nc fp = do

254+ bh <- readBinMem fp

255+ nc' <- newIORef nc

256+ hie_file <- getWithUserData (NCU (atomicModifyIORef' nc')) bh

257+ return (HieFileResult hie_file, ())

258+

259+supportsHieFiles = True

260+

261+#else

262+

263+supportsHieFiles = False

264+

265+writeHieFile _ _ = return ()

266+

267+readHieFile _ _ = return undefined

268+

269+#endif

270+

271+#endif

272+

273+getHeaderImports

274+ :: DynFlags

275+ -> StringBuffer

276+ -> FilePath

277+ -> FilePath

278+ -> IO

279+ ( Either

280+ ErrorMessages

281+ ( [(Maybe FastString, Located ModuleName)]

282+ , [(Maybe FastString, Located ModuleName)]

283+ , Located ModuleName

284+ )

285+ )

286+#if MIN_GHC_API_VERSION(8,8,0)

287+getHeaderImports = Hdr.getImports

288+#else

289+getHeaderImports a b c d =

290+ catch (Right <$> Hdr.getImports a b c d)

291+ (return . Left . srcErrorMessages)

292+#endif

293+

294+getModuleHash :: ModIface -> Fingerprint

295+#if MIN_GHC_API_VERSION(8,10,0)

296+getModuleHash = mi_mod_hash . mi_final_exts

297+#else

298+getModuleHash = mi_mod_hash

299+#endif

300+

301+getConArgs :: ConDecl pass -> HsConDeclDetails pass

302+#if MIN_GHC_API_VERSION(8,6,0)

303+getConArgs = GHC.getConArgs

304+#else

305+getConArgs = GHC.getConDetails

306+#endif

307+

308+getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName

309+getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i))

src/Development/IDE/GHC/Error.hs+27−4

@@ -9,6 +9,7 @@ module Development.IDE.GHC.Error

9 , diagFromStrings

10 , diagFromGhcException

11 , catchSrcErrors

12+ , mergeDiagnostics

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)

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 }

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]]

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

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

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)

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 @@

2-- SPDX-License-Identifier: Apache-2.0

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"

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

34−instance NFData InstalledUnitId where rnf = rwhnf

36+instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS

36instance NFData SB.StringBuffer where rnf = rwhnf

38instance NFData SB.StringBuffer where rnf = rwhnf

@@ -40,8 +42,8 @@ instance Show Module where

41instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint

43instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint

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

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

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

src/Development/IDE/GHC/Util.hs+91−20

@@ -4,34 +4,41 @@

4-- | General utility functions, mostly focused around GHC operations.

5module Development.IDE.GHC.Util(

6 -- * HcsEnv and environment

7− HscEnvEq, hscEnv, newHscEnvEq,

7+ HscEnvEq(GhcVersionMismatch, compileTime, runTime), hscEnv, newHscEnvEq,

8 modifyDynFlags,

9+ evalGhcEnv,

9 runGhcEnv,

10 runGhcEnv,

11+ deps,

10 -- * GHC wrappers

12 -- * GHC wrappers

11 prettyPrint,

13 prettyPrint,

14+ printRdrName,

15+ printName,

12 ParseResult(..), runParser,

16 ParseResult(..), runParser,

13 lookupPackageConfig,

17 lookupPackageConfig,

18+ textToStringBuffer,

19+ stringBufferToByteString,

14 moduleImportPath,

20 moduleImportPath,

15 cgGutsToCoreModule,

21 cgGutsToCoreModule,

16 fingerprintToBS,

22 fingerprintToBS,

17 fingerprintFromStringBuffer,

23 fingerprintFromStringBuffer,

18 -- * General utilities

24 -- * General utilities

19− textToStringBuffer,

20 readFileUtf8,

25 readFileUtf8,

21 hDuplicateTo',

26 hDuplicateTo',

27+ setDefaultHieDir,

28+ dontWriteHieFiles

22 ) where

29 ) where

24import Control.Concurrent

31import Control.Concurrent

25import Data.List.Extra

32import Data.List.Extra

33+import Data.ByteString.Internal (ByteString(..))

26import Data.Maybe

34import Data.Maybe

27import Data.Typeable

35import Data.Typeable

28import qualified Data.ByteString.Internal as BS

36import qualified Data.ByteString.Internal as BS

29import Fingerprint

37import Fingerprint

30−import GHC

31import GhcMonad

38import GhcMonad

32−import GhcPlugins hiding (Unique)

33−import Data.IORef

34import Control.Exception

39import Control.Exception

40+import Data.IORef

41+import Data.Version (showVersion, Version)

35import FileCleanup

42import FileCleanup

36import Foreign.Ptr

43import Foreign.Ptr

37import Foreign.ForeignPtr

44import Foreign.ForeignPtr

@@ -51,7 +58,18 @@ import qualified Data.ByteString as BS

51import Lexer

58import Lexer

52import StringBuffer

59import StringBuffer

53import 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)

72+import Development.IDE.GHC.Compat as GHC

55import Development.IDE.Types.Location

73import Development.IDE.Types.Location

@@ -92,62 +110,115 @@ runParser flags str parser = unP parser parseState

92 buffer = stringToStringBuffer str

110 buffer = stringToStringBuffer str

93 parseState = mkPState flags buffer location

111 parseState = mkPState flags buffer location

112

113+stringBufferToByteString :: StringBuffer -> ByteString

114+stringBufferToByteString StringBuffer{..} = PS buf cur len

115+

95-- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.

116-- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.

96prettyPrint :: Outputable a => a -> String

117prettyPrint :: Outputable a => a -> String

97prettyPrint = showSDoc unsafeGlobalDynFlags . ppr

118prettyPrint = showSDoc unsafeGlobalDynFlags . ppr

119

120+-- | Pretty print a 'RdrName' wrapping operators in parens

121+printRdrName :: RdrName -> String

122+printRdrName name = showSDocUnsafe $ parenSymOcc rn (ppr rn)

123+ where

124+ rn = rdrNameOcc name

125+

126+-- | Pretty print a 'Name' wrapping operators in parens

127+printName :: Name -> String

128+printName = printRdrName . nameRdrName

129+

99-- | 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

100-- 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'.

101−runGhcEnv :: HscEnv -> Ghc a -> IO a

137+runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a)

102runGhcEnv env act = do

138runGhcEnv env act = do

103 filesToClean <- newIORef emptyFilesToClean

139 filesToClean <- newIORef emptyFilesToClean

104 dirsToClean <- newIORef mempty

140 dirsToClean <- newIORef mempty

105 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}

141 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}

106 ref <- newIORef env{hsc_dflags=dflags}

142 ref <- newIORef env{hsc_dflags=dflags}

107− unGhc act (Session ref) `finally` do

143+ res <- unGhc act (Session ref) `finally` do

108 cleanTempFiles dflags

144 cleanTempFiles dflags

109 cleanTempDirs dflags

145 cleanTempDirs dflags

146+ (,res) <$> readIORef ref

110

147

111-- | 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.

112-- 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

113-- @\/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.

114−moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath

151+moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath

115-- 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

116-- the file name matches the module name in the last component.

153-- the file name matches the module name in the last component.

117-- Once that has changed we can get rid of this.

154-- Once that has changed we can get rid of this.

118−moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm

155+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn

119 -- This happens for single-component modules since takeDirectory "A" == "."

156 -- This happens for single-component modules since takeDirectory "A" == "."

120 | modDir == "." = Just pathDir

157 | modDir == "." = Just pathDir

121 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir

158 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir

122 where

159 where

123− ms = GHC.pm_mod_summary pm

124− mod' = GHC.ms_mod ms

125 -- A for module A.B

160 -- A for module A.B

126 modDir =

161 modDir =

127 takeDirectory $

162 takeDirectory $

128− fromNormalizedFilePath $ toNormalizedFilePath $

163+ fromNormalizedFilePath $ toNormalizedFilePath' $

129− moduleNameSlashes $ GHC.moduleName mod'

164+ moduleNameSlashes mn

130

165

131-- | An 'HscEnv' with equality. Two values are considered equal

166-- | An 'HscEnv' with equality. Two values are considered equal

132-- if they are created with the same call to 'newHscEnvEq'.

167-- if they are created with the same call to 'newHscEnvEq'.

168+data HscEnvEq

133−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+ }

134

176

135-- | Unwrap an 'HsEnvEq'.

177-- | Unwrap an 'HsEnvEq'.

136hscEnv :: HscEnvEq -> HscEnv

178hscEnv :: HscEnvEq -> HscEnv

179+hscEnv = either error id . hscEnv'

180+

181+hscEnv' :: HscEnvEq -> Either String HscEnv

137−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{} = []

138

195

139-- | Wrap an 'HscEnv' into an 'HscEnvEq'.

196-- | Wrap an 'HscEnv' into an 'HscEnvEq'.

140−newHscEnvEq :: HscEnv -> IO HscEnvEq

197+newHscEnvEq :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq

141−newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e

198+newHscEnvEq e uids = do u <- newUnique; return $ HscEnvEq u e uids

142

199

143instance Show HscEnvEq where

200instance Show HscEnvEq where

144− show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)

201+ show (HscEnvEq a _ _) = "HscEnvEq " ++ show (hashUnique a)

202+ show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)

145

203

146instance Eq HscEnvEq where

204instance Eq HscEnvEq where

147− 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

148

208

149instance NFData HscEnvEq where

209instance NFData HscEnvEq where

150− rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()

210+ rnf (HscEnvEq a b c) = rnf (hashUnique a) `seq` b `seq` c `seq` ()

211+ rnf GhcVersionMismatch{} = rnf runTime

212+

213+instance Hashable HscEnvEq where

214+ hashWithSalt s (HscEnvEq a _b _c) = hashWithSalt s a

215+ hashWithSalt salt GhcVersionMismatch{..} = hashWithSalt salt (compileTime, runTime)

216+

217+-- Fake instance needed to persuade Shake to accept this type as a key.

218+-- No harm done as ghcide never persists these keys currently

219+instance Binary HscEnvEq where

220+ put _ = error "not really"

221+ get = error "not really"

151

222

152-- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error.

223-- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error.

153readFileUtf8 :: FilePath -> IO T.Text

224readFileUtf8 :: FilePath -> IO T.Text

src/Development/IDE/GHC/WithDynFlags.hsnew file+30

@@ -0,0 +1,30 @@

1+module Development.IDE.GHC.WithDynFlags

2+( WithDynFlags

3+, evalWithDynFlags

4+) where

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+60−31

@@ -14,19 +14,23 @@ module Development.IDE.Import.DependencyInformation

14 , PathIdMap

15 , emptyPathIdMap

16 , getPathId

17+ , lookupPathToId

17 , insertImport

18 , insertImport

18 , pathToId

19 , pathToId

19 , idToPath

20 , idToPath

20 , reachableModules

21 , reachableModules

21− , modLocationToNormalizedFilePath

22 , processDependencyInformation

23 , transitiveDeps

24+

25+ , BootIdMap

26+ , insertBootId

24 ) where

27 ) where

26import Control.DeepSeq

29import Control.DeepSeq

27import Data.Bifunctor

30import Data.Bifunctor

28import Data.Coerce

31import Data.Coerce

29import Data.List

32import Data.List

33+import Data.Tuple.Extra hiding (first, second)

30import Development.IDE.GHC.Orphans()

34import Development.IDE.GHC.Orphans()

31import Data.Either

35import Data.Either

32import Data.Graph

36import Data.Graph

@@ -42,7 +46,6 @@ import qualified Data.IntSet as IntSet

42import Data.Maybe

46import Data.Maybe

43import Data.Set (Set)

47import Data.Set (Set)

44import qualified Data.Set as Set

48import qualified Data.Set as Set

45−import Data.Tuple.Extra (fst3)

46import GHC.Generics (Generic)

49import GHC.Generics (Generic)

48import Development.IDE.Types.Diagnostics

51import Development.IDE.Types.Diagnostics

@@ -59,36 +62,34 @@ data ModuleImports = ModuleImports

59 -- that module on disk (if we found it)

62 -- that module on disk (if we found it)

60 , packageImports :: !(Set InstalledUnitId)

63 , packageImports :: !(Set InstalledUnitId)

61 -- ^ Transitive package dependencies unioned for all imports.

64 -- ^ Transitive package dependencies unioned for all imports.

62− }

65+ } deriving Show

64−-- | For processing dependency information, we need lots of maps and sets

67+-- | For processing dependency information, we need lots of maps and sets of

65−-- 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

66−-- instead and only convert at the edges

69+-- instead and only convert at the edges.

67−-- and

68newtype FilePathId = FilePathId { getFilePathId :: Int }

70newtype FilePathId = FilePathId { getFilePathId :: Int }

69 deriving (Show, NFData, Eq, Ord)

71 deriving (Show, NFData, Eq, Ord)

73+-- | Map from 'FilePathId'

74+type FilePathIdMap = IntMap

75+

76+-- | Set of 'FilePathId's

77+type FilePathIdSet = IntSet

78+

71data PathIdMap = PathIdMap

79data PathIdMap = PathIdMap

72− { idToPathMap :: !(IntMap ArtifactsLocation)

80+ { idToPathMap :: !(FilePathIdMap ArtifactsLocation)

73 , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)

81 , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)

74 }

82 }

75 deriving (Show, Generic)

83 deriving (Show, Generic)

77instance NFData PathIdMap

85instance NFData PathIdMap

79−modLocationToNormalizedFilePath :: ArtifactsLocation -> NormalizedFilePath

80−modLocationToNormalizedFilePath (ArtifactsLocation loc) =

81− case ml_hs_file loc of

82− Just filePath -> toNormalizedFilePath filePath

83− -- Since we craete all 'ModLocation' values via 'mkHomeModLocation'

84− Nothing -> error "Has something changed in mkHomeModLocation?"

85−

86emptyPathIdMap :: PathIdMap

87emptyPathIdMap :: PathIdMap

87emptyPathIdMap = PathIdMap IntMap.empty HMS.empty

88emptyPathIdMap = PathIdMap IntMap.empty HMS.empty

89getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap)

90getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap)

90getPathId path m@PathIdMap{..} =

91getPathId path m@PathIdMap{..} =

91− case HMS.lookup (modLocationToNormalizedFilePath path) pathToIdMap of

92+ case HMS.lookup (artifactFilePath path) pathToIdMap of

92 Nothing ->

93 Nothing ->

93 let !newId = FilePathId $ HMS.size pathToIdMap

94 let !newId = FilePathId $ HMS.size pathToIdMap

94 in (newId, insertPathId path newId m)

95 in (newId, insertPathId path newId m)

@@ -96,7 +97,7 @@ getPathId path m@PathIdMap{..} =

97insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap

98insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap

98insertPathId path id PathIdMap{..} =

99insertPathId path id PathIdMap{..} =

99− PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert (modLocationToNormalizedFilePath path) id pathToIdMap)

100+ PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert (artifactFilePath path) id pathToIdMap)

100

101

101insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation

102insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation

102insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }

103insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }

@@ -104,34 +105,49 @@ insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.inse

104pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId

105pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId

105pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path

106pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path

106

107

108+lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId

109+lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap

110+

107idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath

111idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath

108−idToPath pathIdMap filePathId = modLocationToNormalizedFilePath $ idToModLocation pathIdMap filePathId

112+idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId

109

113

110idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation

114idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation

111idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id

115idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id

112

116

117+type BootIdMap = FilePathIdMap FilePathId

118+

119+insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap

120+insertBootId k = IntMap.insert (getFilePathId k)

113

121

114-- | Unprocessed results that we find by following imports recursively.

122-- | Unprocessed results that we find by following imports recursively.

115data RawDependencyInformation = RawDependencyInformation

123data RawDependencyInformation = RawDependencyInformation

116− { rawImports :: !(IntMap (Either ModuleParseError ModuleImports))

124+ { rawImports :: !(FilePathIdMap (Either ModuleParseError ModuleImports))

117 , rawPathIdMap :: !PathIdMap

125 , rawPathIdMap :: !PathIdMap

118− }

126+ -- The rawBootMap maps the FilePathId of a hs-boot file to its

119−

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+

120−pkgDependencies :: RawDependencyInformation -> IntMap (Set InstalledUnitId)

133+pkgDependencies :: RawDependencyInformation -> FilePathIdMap (Set InstalledUnitId)

121pkgDependencies RawDependencyInformation{..} =

134pkgDependencies RawDependencyInformation{..} =

122 IntMap.map (either (const Set.empty) packageImports) rawImports

135 IntMap.map (either (const Set.empty) packageImports) rawImports

123

136

124data DependencyInformation =

137data DependencyInformation =

125 DependencyInformation

138 DependencyInformation

126− { depErrorNodes :: !(IntMap (NonEmpty NodeError))

139+ { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError))

127 -- ^ Nodes that cannot be processed correctly.

140 -- ^ Nodes that cannot be processed correctly.

128− , depModuleNames :: !(IntMap ShowableModuleName)

141+ , depModuleNames :: !(FilePathIdMap ShowableModuleName)

129− , depModuleDeps :: !(IntMap IntSet)

142+ , depModuleDeps :: !(FilePathIdMap FilePathIdSet)

130 -- ^ 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

131 -- in the same package.

144 -- in the same package.

132− , depPkgDeps :: !(IntMap (Set InstalledUnitId))

145+ , depPkgDeps :: !(FilePathIdMap (Set InstalledUnitId))

133 -- ^ 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.

134 , 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

135 } deriving (Show, Generic)

151 } deriving (Show, Generic)

136

152

137newtype ShowableModuleName =

153newtype ShowableModuleName =

@@ -209,6 +225,7 @@ processDependencyInformation rawDepInfo@RawDependencyInformation{..} =

209 , depModuleNames = IntMap.fromList $ coerce moduleNames

225 , depModuleNames = IntMap.fromList $ coerce moduleNames

210 , depPkgDeps = pkgDependencies rawDepInfo

226 , depPkgDeps = pkgDependencies rawDepInfo

211 , depPathIdMap = rawPathIdMap

227 , depPathIdMap = rawPathIdMap

228+ , depBootMap = rawBootMap

212 }

229 }

213 where resultGraph = buildResultGraph rawImports

230 where resultGraph = buildResultGraph rawImports

214 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph

231 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph

@@ -230,7 +247,7 @@ processDependencyInformation rawDepInfo@RawDependencyInformation{..} =

230-- 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.

231-- 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.

232-- 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.

233−buildResultGraph :: IntMap (Either ModuleParseError ModuleImports) -> IntMap NodeResult

250+buildResultGraph :: FilePathIdMap (Either ModuleParseError ModuleImports) -> FilePathIdMap NodeResult

234buildResultGraph g = propagatedErrors

251buildResultGraph g = propagatedErrors

235 where

252 where

236 sccs = stronglyConnComp (graphEdges g)

253 sccs = stronglyConnComp (graphEdges g)

@@ -277,7 +294,7 @@ buildResultGraph g = propagatedErrors

277 Right ModuleImports{moduleImports} ->

294 Right ModuleImports{moduleImports} ->

278 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports

295 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports

279

296

280−graphEdges :: IntMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]

297+graphEdges :: FilePathIdMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]

281graphEdges g =

298graphEdges g =

282 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

283 where deps :: Either e ModuleImports -> [FilePathId]

300 where deps :: Either e ModuleImports -> [FilePathId]

@@ -289,10 +306,12 @@ partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest

289partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest

306partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest

290partitionSCC [] = ([], [])

307partitionSCC [] = ([], [])

291

308

309+

292transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies

310transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies

293transitiveDeps DependencyInformation{..} file = do

311transitiveDeps DependencyInformation{..} file = do

294 let !fileId = pathToId depPathIdMap file

312 let !fileId = pathToId depPathIdMap file

295 reachableVs <-

313 reachableVs <-

314+ -- Delete the starting node

296 IntSet.delete (getFilePathId fileId) .

315 IntSet.delete (getFilePathId fileId) .

297 IntSet.fromList . map (fst3 . fromVertex) .

316 IntSet.fromList . map (fst3 . fromVertex) .

298 reachable g <$> toVertex (getFilePathId fileId)

317 reachable g <$> toVertex (getFilePathId fileId)

@@ -305,17 +324,27 @@ transitiveDeps DependencyInformation{..} file = do

305 let transitiveModuleDeps =

324 let transitiveModuleDeps =

306 map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds

325 map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds

307 let transitiveNamedModuleDeps =

326 let transitiveNamedModuleDeps =

308− [ NamedModuleDep (idToPath depPathIdMap (FilePathId fid)) mn ml

327+ [ NamedModuleDep (idToPath depPathIdMap (FilePathId fid)) mn artifactModLocation

309 | (fid, ShowableModuleName mn) <- IntMap.toList depModuleNames

328 | (fid, ShowableModuleName mn) <- IntMap.toList depModuleNames

310− , let ArtifactsLocation ml = idToPathMap depPathIdMap IntMap.! fid

329+ , let ArtifactsLocation{artifactModLocation} = idToPathMap depPathIdMap IntMap.! fid

311 ]

330 ]

312 pure TransitiveDependencies {..}

331 pure TransitiveDependencies {..}

313 where

332 where

333+ (g, fromVertex, toVertex) = graphFromEdges edges

314− (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+

315 vs = topSort g

342 vs = topSort g

316

343

317data TransitiveDependencies = TransitiveDependencies

344data TransitiveDependencies = TransitiveDependencies

318 { transitiveModuleDeps :: [NormalizedFilePath]

345 { transitiveModuleDeps :: [NormalizedFilePath]

346+ -- ^ Transitive module dependencies in topological order.

347+ -- The module itself is not included.

319 , transitiveNamedModuleDeps :: [NamedModuleDep]

348 , transitiveNamedModuleDeps :: [NamedModuleDep]

320 -- ^ Transitive module dependencies in topological order.

349 -- ^ Transitive module dependencies in topological order.

321 -- The module itself is not included.

350 -- The module itself is not included.

src/Development/IDE/Import/FindImports.hs+52−18

@@ -8,16 +8,18 @@ module Development.IDE.Import.FindImports

8 ( locateModule

9 , Import(..)

10 , ArtifactsLocation(..)

11+ , modSummaryToArtifactsLocation

12+ , isBootLocation

13+ , mkImportDirs

11 ) where

14 ) where

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,74 +30,106 @@ 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

32data Import

36data Import

33 = FileImport !ArtifactsLocation

37 = FileImport !ArtifactsLocation

34 | PackageImport !M.InstalledUnitId

38 | PackageImport !M.InstalledUnitId

35 deriving (Show)

39 deriving (Show)

37−newtype ArtifactsLocation = ArtifactsLocation ModLocation

41+data ArtifactsLocation = ArtifactsLocation

42+ { artifactFilePath :: !NormalizedFilePath

43+ , artifactModLocation :: !ModLocation

44+ , artifactIsSource :: !Bool -- ^ True if a module is a source input

45+ }

38 deriving (Show)

46 deriving (Show)

40instance NFData ArtifactsLocation where

48instance NFData ArtifactsLocation where

41− rnf = const ()

49+ rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource

50+

51+isBootLocation :: ArtifactsLocation -> Bool

52+isBootLocation = not . artifactIsSource

43instance NFData Import where

54instance NFData Import where

44 rnf (FileImport x) = rnf x

55 rnf (FileImport x) = rnf x

45 rnf (PackageImport x) = rnf x

56 rnf (PackageImport x) = rnf x

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+

48-- | 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

49locateModuleFile :: MonadIO m

66locateModuleFile :: MonadIO m

50− => DynFlags

67+ => [[FilePath]]

51 -> [String]

68 -> [String]

52 -> (NormalizedFilePath -> m Bool)

69 -> (NormalizedFilePath -> m Bool)

53 -> Bool

70 -> Bool

54 -> ModuleName

71 -> ModuleName

55 -> m (Maybe NormalizedFilePath)

72 -> m (Maybe NormalizedFilePath)

56−locateModuleFile dflags exts doesExist isSource modName = do

73+locateModuleFile import_dirss exts doesExist isSource modName = do

57− let candidates =

74+ let candidates import_dirs =

58− [ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)

75+ [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)

59− | prefix <- importPaths dflags, ext <- exts]

76+ | prefix <- import_dirs , ext <- exts]

60− findM doesExist candidates

77+ findM doesExist (concatMap candidates import_dirss)

61 where

78 where

62 maybeBoot ext

79 maybeBoot ext

63 | isSource = ext ++ "-boot"

80 | isSource = ext ++ "-boot"

64 | otherwise = ext

81 | otherwise = ext

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+

66-- | 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

67-- Haskell

91-- Haskell

68locateModule

92locateModule

69 :: MonadIO m

93 :: MonadIO m

70 => DynFlags

94 => DynFlags

95+ -> [(M.InstalledUnitId, DynFlags)] -- Sets import directories to look in

71 -> [String]

96 -> [String]

72 -> (NormalizedFilePath -> m Bool)

97 -> (NormalizedFilePath -> m Bool)

73 -> Located ModuleName

98 -> Located ModuleName

74 -> Maybe FastString

99 -> Maybe FastString

75 -> Bool

100 -> Bool

76 -> m (Either [FileDiagnostic] Import)

101 -> m (Either [FileDiagnostic] Import)

77−locateModule dflags exts doesExist modName mbPkgName isSource = do

102+locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do

78 case mbPkgName of

103 case mbPkgName of

79 -- "this" means that we should only look in the current package

104 -- "this" means that we should only look in the current package

80 Just "this" -> do

105 Just "this" -> do

81− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName

106+ lookupLocal [importPaths dflags]

82− case mbFile of

83− Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []

84− Just file -> toModLocation file

85 -- 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]

86− Just _pkgName -> lookupInPackageDB dflags

111+ | otherwise -> lookupInPackageDB dflags

87 Nothing -> do

112 Nothing -> do

88 -- 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

89 -- 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.

90− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName

118+ mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts doesExist isSource $ unLoc modName

91 case mbFile of

119 case mbFile of

92 Nothing -> lookupInPackageDB dflags

120 Nothing -> lookupInPackageDB dflags

93 Just file -> toModLocation file

121 Just file -> toModLocation file

94 where

122 where

123+ import_paths = mapMaybe (mkImportDirs dflags) comp_info

95 toModLocation file = liftIO $ do

124 toModLocation file = liftIO $ do

96 loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)

125 loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)

97− return $ Right $ FileImport $ ArtifactsLocation loc

126+ return $ Right $ FileImport $ ArtifactsLocation file loc (not isSource)

127

128+ lookupLocal dirs = do

129+ mbFile <- locateModuleFile dirs exts doesExist isSource $ unLoc modName

130+ case mbFile of

131+ Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []

132+ Just file -> toModLocation file

133

100 lookupInPackageDB dfs =

134 lookupInPackageDB dfs =

101 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

7 ( setHandlersHover

8 , setHandlersDefinition

9+ -- * For haskell-language-server

10+ , hover

11+ , gotoDefinition

9 ) where

12 ) where

11import Development.IDE.Core.Rules

14import Development.IDE.Core.Rules

@@ -52,7 +55,7 @@ request label getResults notFound found ide (TextDocumentPositionParams (TextDoc

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 ->

145 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

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 ->

150 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

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

157 sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams

158 InitialParams x@RequestMessage{_id, _params} act -> do

@@ -175,16 +175,16 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

175 Left () -> do

176 logDebug (ideLogger ide) $ T.pack $

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

181 ) $ \(e :: SomeException) -> do

182 logError (ideLogger ide) $ T.pack $

183 "Unexpected exception on request, please report!\n" ++

184 "Message: " ++ show msg ++ "\n" ++

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

189initializeRequestHandler :: PartialHandlers config

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,

223 -- but also an additional request to the client.

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 ())

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 ())

229

230modifyOptions :: LSP.Options -> LSP.Options

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

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'

35setHandlersNotifications :: PartialHandlers c

36setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x

@@ -62,7 +62,7 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x

62 let events =

63 mapMaybe

64 (\(FileEvent uri ev) ->

65− (, ev /= FcDeleted) . toNormalizedFilePath

65+ (, ev /= FcDeleted) . toNormalizedFilePath'

66 <$> LSP.uriToFilePath uri

67 )

68 ( F.toList fileEvents )

src/Development/IDE/LSP/Outline.hs+41−6

@@ -4,6 +4,8 @@

5module Development.IDE.LSP.Outline

6 ( setHandlersOutline

7+ -- * For haskell-language-server

8+ , moduleOutline

7 )

9 )

8where

10where

@@ -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) ->

@@ -50,7 +52,9 @@ moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentI

50 , _kind = SkFile

52 , _kind = SkFile

51 , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0

53 , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0

52 }

54 }

55+ importSymbols = maybe [] pure $

56+ documentSymbolForImportSummary

53− importSymbols = mapMaybe documentSymbolForImport hsmodImports

57+ (mapMaybe documentSymbolForImport hsmodImports)

54 allSymbols = case moduleSymbol of

58 allSymbols = case moduleSymbol of

55 Nothing -> importSymbols <> declSymbols

59 Nothing -> importSymbols <> declSymbols

56 Just x ->

60 Just x ->

@@ -104,27 +108,39 @@ documentSymbolForDecl (L l (TyClD DataDecl { tcdLName = L _ name, tcdDataDefn =

104 { _name = showRdrName n

108 { _name = showRdrName n

105 , _kind = SkConstructor

109 , _kind = SkConstructor

106 , _selectionRange = srcSpanToRange l'

110 , _selectionRange = srcSpanToRange l'

111+ , _children = conArgRecordFields (getConArgs x)

107 }

112 }

108 | L l x <- dd_cons

113 | L l x <- dd_cons

109 , L l' n <- getConNames x

114 , L l' n <- getConNames x

110 ]

115 ]

111 }

116 }

117+ where

118+ -- | Extract the record fields of a constructor

119+ conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List

120+ [ (defDocumentSymbol l :: DocumentSymbol)

121+ { _name = showRdrName n

122+ , _kind = SkField

123+ }

124+ | L _ cdf <- lcdfs

125+ , L l n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf

126+ ]

127+ conArgRecordFields _ = Nothing

112documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just

128documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just

113 (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n

129 (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n

114 , _kind = SkTypeParameter

130 , _kind = SkTypeParameter

115 , _selectionRange = srcSpanToRange l'

131 , _selectionRange = srcSpanToRange l'

116 }

132 }

117−documentSymbolForDecl (L l (InstD (ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })))

133+documentSymbolForDecl (L l (InstD ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))

118 = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty

134 = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty

119 , _kind = SkInterface

135 , _kind = SkInterface

120 }

136 }

121−documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) }))

137+documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))

122 = Just (defDocumentSymbol l :: DocumentSymbol)

138 = Just (defDocumentSymbol l :: DocumentSymbol)

123 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

139 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

124 (map pprText feqn_pats)

140 (map pprText feqn_pats)

125 , _kind = SkInterface

141 , _kind = SkInterface

126 }

142 }

127−documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) }))

143+documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))

128 = Just (defDocumentSymbol l :: DocumentSymbol)

144 = Just (defDocumentSymbol l :: DocumentSymbol)

129 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

145 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

130 (map pprText feqn_pats)

146 (map pprText feqn_pats)

@@ -167,6 +183,25 @@ documentSymbolForDecl (L l (ForD x)) = Just

167

183

168documentSymbolForDecl _ = Nothing

184documentSymbolForDecl _ = Nothing

169

185

186+-- | Wrap the Document imports into a hierarchical outline for

187+-- a better overview of symbols in scope.

188+-- If there are no imports, then no hierarchy will be created.

189+documentSymbolForImportSummary :: [DocumentSymbol] -> Maybe DocumentSymbol

190+documentSymbolForImportSummary [] = Nothing

191+documentSymbolForImportSummary importSymbols =

192+ let

193+ -- safe because if we have no ranges then we don't take this branch

194+ mergeRanges xs = Range (minimum $ map _start xs) (maximum $ map _end xs)

195+ importRange = mergeRanges $ map (_range :: DocumentSymbol -> Range) importSymbols

196+ in

197+ Just (defDocumentSymbol empty :: DocumentSymbol)

198+ { _name = "imports"

199+ , _kind = SkModule

200+ , _children = Just (List importSymbols)

201+ , _range = importRange

202+ , _selectionRange = importRange

203+ }

204+

170documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol

205documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol

171documentSymbolForImport (L l ImportDecl { ideclName, ideclQualified }) = Just

206documentSymbolForImport (L l ImportDecl { ideclName, ideclQualified }) = Just

172 (defDocumentSymbol l :: DocumentSymbol)

207 (defDocumentSymbol l :: DocumentSymbol)

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) =>

30 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

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))

34 , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())

35 -> Maybe (LSP.Handler InitializeRequest)

src/Development/IDE/Plugin.hs+28−2

@@ -1,11 +1,13 @@

2−module Development.IDE.Plugin(Plugin(..), codeActionPlugin) where

2+module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules,makeLspCommandId,getPid) where

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

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

@@ -27,8 +29,32 @@ instance Monoid (Plugin c) where

29codeActionPlugin :: (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c

31codeActionPlugin :: (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c

32+codeActionPlugin = codeActionPluginWithRules mempty

33+

34+codeActionPluginWithRules :: Rules () -> (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c

30−codeActionPlugin f = Plugin mempty $ PartialHandlers $ \WithMessage{..} x -> return x{

35+codeActionPluginWithRules rr f = Plugin rr $ PartialHandlers $ \WithMessage{..} x -> return x{

31 LSP.codeActionHandler = withResponse RspCodeAction g

36 LSP.codeActionHandler = withResponse RspCodeAction g

32 }

37 }

33 where

38 where

34 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+125−70

@@ -6,7 +6,16 @@

6#include "ghc-api-version.h"

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

11import Language.Haskell.LSP.Types

20import Language.Haskell.LSP.Types

12import Control.Monad (join)

21import Control.Monad (join)

@@ -19,8 +28,12 @@ import Development.IDE.Core.Shake

19import Development.IDE.GHC.Error

28import Development.IDE.GHC.Error

20import Development.IDE.GHC.Util

29import Development.IDE.GHC.Util

21import Development.IDE.LSP.Server

30import Development.IDE.LSP.Server

31+import Development.IDE.Plugin.CodeAction.PositionIndexed

32+import Development.IDE.Plugin.CodeAction.RuleTypes

33+import Development.IDE.Plugin.CodeAction.Rules

22import Development.IDE.Types.Location

34import Development.IDE.Types.Location

23import Development.IDE.Types.Options

35import Development.IDE.Types.Options

36+import Development.Shake (Rules)

24import qualified Data.HashMap.Strict as Map

37import qualified Data.HashMap.Strict as Map

25import qualified Language.Haskell.LSP.Core as LSP

38import qualified Language.Haskell.LSP.Core as LSP

26import Language.Haskell.LSP.VFS

39import Language.Haskell.LSP.VFS

@@ -34,17 +47,18 @@ import Data.List.Extra

34import qualified Data.Text as T

47import qualified Data.Text as T

35import Data.Tuple.Extra ((&&&))

48import Data.Tuple.Extra ((&&&))

36import HscTypes

49import HscTypes

37−import OccName

38import Parser

50import Parser

39−import RdrName

40import Text.Regex.TDFA ((=~), (=~~))

51import Text.Regex.TDFA ((=~), (=~~))

41import Text.Regex.TDFA.Text()

52import Text.Regex.TDFA.Text()

42−import Outputable (showSDoc, ppr, showSDocUnsafe)

53+import Outputable (ppr, showSDocUnsafe)

43import DynFlags (xFlags, FlagSpec(..))

54import DynFlags (xFlags, FlagSpec(..))

44import GHC.LanguageExtensions.Type (Extension)

55import GHC.LanguageExtensions.Type (Extension)

46plugin :: Plugin c

57plugin :: Plugin c

47−plugin = codeActionPlugin codeAction <> Plugin mempty setHandlersCodeLens

58+plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens

59+

60+rules :: Rules ()

61+rules = rulePackageExports

49-- | Generate code actions.

63-- | Generate code actions.

50codeAction

64codeAction

@@ -59,15 +73,16 @@ codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diag

59 -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg

73 -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg

60 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri

74 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri

61 let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents

75 let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents

62− mbFile = toNormalizedFilePath <$> uriToFilePath uri

76+ mbFile = toNormalizedFilePath' <$> uriToFilePath uri

63− (ideOptions, parsedModule, env) <- runAction state $

77+ (ideOptions, parsedModule, join -> env) <- runAction state $

64 (,,) <$> getIdeOptions

78 (,,) <$> getIdeOptions

65− <*> getParsedModule `traverse` mbFile

79+ <*> getParsedModule `traverse` mbFile

66− <*> use_ GhcSession `traverse` mbFile

80+ <*> use GhcSession `traverse` mbFile

81+ pkgExports <- runAction state $ (useNoFile_ . PackageExports) `traverse` env

67 let dflags = hsc_dflags . hscEnv <$> env

82 let dflags = hsc_dflags . hscEnv <$> env

68 pure $ Right

83 pure $ Right

69 [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing

84 [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing

70− | x <- xs, (title, tedit) <- suggestAction dflags ideOptions ( join parsedModule ) text x

85+ | x <- xs, (title, tedit) <- suggestAction dflags (fromMaybe mempty pkgExports) ideOptions ( join parsedModule ) text x

71 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

86 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

72 ]

87 ]

@@ -78,13 +93,14 @@ codeLens

78 -> CodeLensParams

93 -> CodeLensParams

79 -> IO (Either ResponseError (List CodeLens))

94 -> IO (Either ResponseError (List CodeLens))

80codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do

95codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do

96+ commandId <- makeLspCommandId "typesignature.add"

81 fmap (Right . List) $ case uriToFilePath' uri of

97 fmap (Right . List) $ case uriToFilePath' uri of

82− Just (toNormalizedFilePath -> filePath) -> do

98+ Just (toNormalizedFilePath' -> filePath) -> do

83 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath

99 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath

84 diag <- getDiagnostics ideState

100 diag <- getDiagnostics ideState

85 hDiag <- getHiddenDiagnostics ideState

101 hDiag <- getHiddenDiagnostics ideState

86 pure

102 pure

87− [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing

103+ [ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing

88 | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag

104 | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag

89 , dFile == filePath

105 , dFile == filePath

90 , (title, tedit) <- suggestSignature False dDiag

106 , (title, tedit) <- suggestSignature False dDiag

@@ -97,17 +113,28 @@ executeAddSignatureCommand

97 :: LSP.LspFuncs c

113 :: LSP.LspFuncs c

98 -> IdeState

114 -> IdeState

99 -> ExecuteCommandParams

115 -> ExecuteCommandParams

100− -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

116+ -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

101executeAddSignatureCommand _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.

102− | _command == "typesignature.add"

122+ | T.isSuffixOf "typesignature.add" _command

103 , Just (List [edit]) <- _arguments

123 , Just (List [edit]) <- _arguments

104 , Success wedit <- fromJSON edit

124 , Success wedit <- fromJSON edit

105− = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))

125+ = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))

106 | otherwise

126 | otherwise

107− = return (Null, Nothing)

127+ = return (Right Null, Nothing)

108−

128+

109−suggestAction :: Maybe DynFlags -> IdeOptions -> Maybe ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

129+suggestAction

130+ :: Maybe DynFlags

131+ -> PackageExportsMap

132+ -> IdeOptions

133+ -> Maybe ParsedModule

134+ -> Maybe T.Text

135+ -> Diagnostic

136+ -> [(T.Text, [TextEdit])]

110−suggestAction dflags ideOptions parsedModule text diag = concat

137+suggestAction dflags packageExports ideOptions parsedModule text diag = concat

111 [ suggestAddExtension diag

138 [ suggestAddExtension diag

112 , suggestExtendImport dflags text diag

139 , suggestExtendImport dflags text diag

113 , suggestFillHole diag

140 , suggestFillHole diag

@@ -119,6 +146,7 @@ suggestAction dflags ideOptions parsedModule text diag = concat

119 ] ++ concat

146 ] ++ concat

120 [ suggestNewDefinition ideOptions pm text diag

147 [ suggestNewDefinition ideOptions pm text diag

121 ++ suggestRemoveRedundantImport pm text diag

148 ++ suggestRemoveRedundantImport pm text diag

149+ ++ suggestNewImport packageExports pm diag

122 | Just pm <- [parsedModule]]

150 | Just pm <- [parsedModule]]

123

151

124

152

@@ -130,6 +158,7 @@ suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmod

130 , Just c <- contents

158 , Just c <- contents

131 , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)

159 , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)

132 , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)

160 , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)

161+ , not (null ranges')

133 = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]

162 = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]

134

163

135-- File.hs:16:1: warning:

164-- File.hs:16:1: warning:

@@ -288,9 +317,8 @@ suggestExtendImport (Just dflags) contents Diagnostic{_range=_range,..}

288 in x{_end = (_end x){_character = succ (_character (_end x))}}

317 in x{_end = (_end x){_character = succ (_character (_end x))}}

289 _ -> error "bug in srcspan parser"

318 _ -> error "bug in srcspan parser"

290 importLine = textInRange range c

319 importLine = textInRange range c

291− printedName = let rn = rdrNameOcc name in showSDoc dflags $ parenSymOcc rn (ppr rn)

292 in [("Add " <> binding <> " to the import list of " <> mod

320 in [("Add " <> binding <> " to the import list of " <> mod

293− , [TextEdit range (addBindingToImportList (T.pack printedName) importLine)])]

321+ , [TextEdit range (addBindingToImportList (T.pack $ printRdrName name) importLine)])]

294 | otherwise = []

322 | otherwise = []

295suggestExtendImport Nothing _ _ = []

323suggestExtendImport Nothing _ _ = []

296

324

@@ -332,6 +360,81 @@ suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}

332

360

333suggestSignature _ _ = []

361suggestSignature _ _ = []

334

362

363+-------------------------------------------------------------------------------------------------

364+

365+suggestNewImport :: PackageExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]

366+suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message}

367+ | msg <- unifySpaces _message

368+ , Just name <- extractNotInScopeName msg

369+ , Just insertLine <- case hsmodImports of

370+ [] -> case srcSpanStart $ getLoc (head hsmodDecls) of

371+ RealSrcLoc s -> Just $ srcLocLine s - 1

372+ _ -> Nothing

373+ _ -> case srcSpanEnd $ getLoc (last hsmodImports) of

374+ RealSrcLoc s -> Just $ srcLocLine s

375+ _ -> Nothing

376+ , insertPos <- Position insertLine 0

377+ , extendImportSuggestions <- matchRegex msg

378+ "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"

379+ = [(imp, [TextEdit (Range insertPos insertPos) (imp <> "\n")])

380+ | imp <- constructNewImportSuggestions packageExportsMap name extendImportSuggestions

381+ ]

382+suggestNewImport _ _ _ = []

383+

384+constructNewImportSuggestions

385+ :: PackageExportsMap -> NotInScope -> Maybe [T.Text] -> [T.Text]

386+constructNewImportSuggestions exportsMap thingMissing notTheseModules = nubOrd

387+ [ renderNewImport identInfo m

388+ | (identInfo, m) <- fromMaybe [] $ Map.lookup name exportsMap

389+ , canUseIdent thingMissing identInfo

390+ , m `notElem` fromMaybe [] notTheseModules

391+ ]

392+ where

393+ renderNewImport identInfo m

394+ | Just q <- qual = "import qualified " <> m <> " as " <> q

395+ | otherwise = "import " <> m <> " (" <> importWhat identInfo <> ")"

396+

397+ (qual, name) = case T.splitOn "." (notInScope thingMissing) of

398+ [n] -> (Nothing, n)

399+ segments -> (Just (T.concat $ init segments), last segments)

400+ importWhat IdentInfo {parent, rendered}

401+ | Just p <- parent = p <> "(" <> rendered <> ")"

402+ | otherwise = rendered

403+

404+canUseIdent :: NotInScope -> IdentInfo -> Bool

405+canUseIdent NotInScopeDataConstructor{} = isDatacon

406+canUseIdent _ = const True

407+

408+data NotInScope

409+ = NotInScopeDataConstructor T.Text

410+ | NotInScopeTypeConstructorOrClass T.Text

411+ | NotInScopeThing T.Text

412+ deriving Show

413+

414+notInScope :: NotInScope -> T.Text

415+notInScope (NotInScopeDataConstructor t) = t

416+notInScope (NotInScopeTypeConstructorOrClass t) = t

417+notInScope (NotInScopeThing t) = t

418+

419+extractNotInScopeName :: T.Text -> Maybe NotInScope

420+extractNotInScopeName x

421+ | Just [name] <- matchRegex x "Data constructor not in scope: ([^ ]+)"

422+ = Just $ NotInScopeDataConstructor name

423+ | Just [name] <- matchRegex x "Not in scope: data constructor [^‘]*‘([^’]*)’"

424+ = Just $ NotInScopeDataConstructor name

425+ | Just [name] <- matchRegex x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"

426+ = Just $ NotInScopeTypeConstructorOrClass name

427+ | Just [name] <- matchRegex x "ot in scope: \$([^‘ ]+)\$"

428+ = Just $ NotInScopeThing name

429+ | Just [name] <- matchRegex x "ot in scope: ([^‘ ]+)"

430+ = Just $ NotInScopeThing name

431+ | Just [name] <- matchRegex x "ot in scope:[^‘]*‘([^’]*)’"

432+ = Just $ NotInScopeThing name

433+ | otherwise

434+ = Nothing

435+

436+-------------------------------------------------------------------------------------------------

437+

335topOfHoleFitsMarker :: T.Text

438topOfHoleFitsMarker :: T.Text

336topOfHoleFitsMarker =

439topOfHoleFitsMarker =

337#if MIN_GHC_API_VERSION(8,6,0)

440#if MIN_GHC_API_VERSION(8,6,0)

@@ -424,7 +527,7 @@ rangesForBinding _ _ = []

424rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]

527rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]

425rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]

528rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]

426rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]

529rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]

427−rangesForBinding' b (L l x@IEThingAll{}) | showSDocUnsafe (ppr x) == b = [l]

530+rangesForBinding' b (L l (IEThingAll x)) | showSDocUnsafe (ppr x) == b = [l]

428rangesForBinding' b (L l (IEThingWith thing _ inners labels))

531rangesForBinding' b (L l (IEThingWith thing _ inners labels))

429 | showSDocUnsafe (ppr thing) == b = [l]

532 | showSDocUnsafe (ppr thing) == b = [l]

430 | otherwise =

533 | otherwise =

@@ -465,51 +568,3 @@ filterNewlines = T.concat . T.lines

465

568

466unifySpaces :: T.Text -> T.Text

569unifySpaces :: T.Text -> T.Text

467unifySpaces = T.unwords . T.words

570unifySpaces = T.unwords . T.words

468−

469−--------------------------------------------------------------------------------

470−

471−type PositionIndexedString = [(Position, Char)]

472−

473−indexedByPosition :: String -> PositionIndexedString

474−indexedByPosition = unfoldr f . (Position 0 0,) where

475− f (_, []) = Nothing

476− f (p@(Position l _), '\n' : rest) = Just ((p,'\n'), (Position (l+1) 0, rest))

477− f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c+1), rest))

478−

479−-- | Returns a tuple (before, contents, after)

480−unconsRange :: Range -> PositionIndexedString -> (PositionIndexedString, PositionIndexedString, PositionIndexedString)

481−unconsRange Range {..} indexedString = (before, mid, after)

482− where

483− (before, rest) = span ((/= _start) . fst) indexedString

484− (mid, after) = span ((/= _end) . fst) rest

485−

486−stripRange :: Range -> PositionIndexedString -> PositionIndexedString

487−stripRange r s = case unconsRange r s of

488− (b, _, a) -> b ++ a

489−

490−extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]

491−extendAllToIncludeCommaIfPossible _ [] = []

492−extendAllToIncludeCommaIfPossible indexedString (r : rr) = r' : extendAllToIncludeCommaIfPossible indexedString' rr

493− where

494− r' = case extendToIncludeCommaIfPossible indexedString r of

495− [] -> r

496− r' : _ -> r'

497− indexedString' = stripRange r' indexedString

498−

499−-- | Returns a sorted list of ranges with extended selections includindg preceding or trailing commas

500−extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]

501−extendToIncludeCommaIfPossible indexedString range =

502− -- a, |b|, c ===> a|, b|, c

503− [ range{_start = start'}

504− | (start', ',') : _ <- [before']

505− ]

506− ++

507− -- a, |b|, c ===> a, |b, |c

508− [ range{_end = end'}

509− | (_, ',') : rest <- [after']

510− , let (end', _) : _ = dropWhile (isSpace . snd) rest

511− ]

512− where

513− (before, _, after) = unconsRange range indexedString

514− after' = dropWhile (isSpace . snd) after

515− before' = dropWhile (isSpace . snd) (reverse before)

src/Development/IDE/Plugin/CodeAction/PositionIndexed.hsnew file+112

@@ -0,0 +1,112 @@

1+-- | Position indexed streams of characters

2+module Development.IDE.Plugin.CodeAction.PositionIndexed

3+ ( PositionIndexed

4+ , PositionIndexedString

5+ , indexedByPosition

6+ , indexedByPositionStartingFrom

7+ , extendAllToIncludeCommaIfPossible

8+ , mergeRanges

9+ )

10+where

11+

12+import Data.Char

13+import Data.List

14+import Language.Haskell.LSP.Types

15+

16+type PositionIndexed a = [(Position, a)]

17+

18+type PositionIndexedString = PositionIndexed Char

19+

20+-- | Add position indexing to a String.

21+--

22+-- > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡

23+-- > [ ((0,0),'h')

24+-- > , ((0,1),'e')

25+-- > , ((0,2),'y')

26+-- > , ((0,3),'\n')

27+-- > , ((1,0),' ')

28+-- > , ((1,1),'h')

29+-- > , ((1,2),'o')

30+-- > ]

31+indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString

32+indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where

33+ f (_, []) = Nothing

34+ f (p@(Position l _), '\n' : rest) =

35+ Just ((p, '\n'), (Position (l + 1) 0, rest))

36+ f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest))

37+

38+-- | Add position indexing to a String.

39+--

40+-- > indexedByPosition = indexedByPositionStartingFrom (Position 0 0)

41+indexedByPosition :: String -> PositionIndexedString

42+indexedByPosition = indexedByPositionStartingFrom (Position 0 0)

43+

44+-- | Returns a tuple (before, contents, after) if the range is present.

45+-- The range is present only if both its start and end positions are present

46+unconsRange

47+ :: Range

48+ -> PositionIndexed a

49+ -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a)

50+unconsRange Range {..} indexedString

51+ | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString

52+ , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest

53+ = Just (before, mid, after)

54+ | otherwise

55+ = Nothing

56+

57+-- | Strips out all the positions included in the range.

58+-- Returns 'Nothing' if the start or end of the range are not included in the input.

59+stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a)

60+stripRange r s = case unconsRange r s of

61+ Just (b, _, a) -> Just (b ++ a)

62+ Nothing -> Nothing

63+

64+-- | Returns the smallest possible set of disjoint ranges that is equivalent to the input.

65+-- Assumes input ranges are sorted on the start positions.

66+mergeRanges :: [Range] -> [Range]

67+mergeRanges (r : r' : rest)

68+ |

69+ -- r' is contained in r

70+ _end r > _end r' = mergeRanges (r : rest)

71+ |

72+ -- r and r' are overlapping

73+ _end r > _start r' = mergeRanges (r { _end = _end r' } : rest)

74+

75+ | otherwise = r : mergeRanges (r' : rest)

76+mergeRanges other = other

77+

78+-- | Returns a sorted list of ranges with extended selections including preceding or trailing commas

79+--

80+-- @

81+-- a, |b|, c ===> a|, b|, c

82+-- a, b, |c| ===> a, b|, c|

83+-- a, |b|, |c| ===> a|, b||, c|

84+-- @

85+extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]

86+extendAllToIncludeCommaIfPossible indexedString =

87+ mergeRanges . go indexedString . sortOn _start

88+ where

89+ go _ [] = []

90+ go input (r : rr)

91+ | r' : _ <- extendToIncludeCommaIfPossible input r

92+ , Just input' <- stripRange r' input

93+ = r' : go input' rr

94+ | otherwise

95+ = go input rr

96+

97+extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]

98+extendToIncludeCommaIfPossible indexedString range

99+ | Just (before, _, after) <- unconsRange range indexedString

100+ , after' <- dropWhile (isSpace . snd) after

101+ , before' <- dropWhile (isSpace . snd) (reverse before)

102+ =

103+ -- a, |b|, c ===> a|, b|, c

104+ [ range { _start = start' } | (start', ',') : _ <- [before'] ]

105+ ++

106+ -- a, |b|, c ===> a, |b, |c

107+ [ range { _end = end' }

108+ | (_, ',') : rest <- [after']

109+ , let (end', _) : _ = dropWhile (isSpace . snd) rest

110+ ]

111+ | otherwise

112+ = [range]

src/Development/IDE/Plugin/CodeAction/RuleTypes.hsnew file+61

@@ -0,0 +1,61 @@

1+{-# LANGUAGE TypeFamilies #-}

2+module Development.IDE.Plugin.CodeAction.RuleTypes

3+ (PackageExports(..), PackageExportsMap

4+ ,IdentInfo(..)

5+ ,mkIdentInfos

6+ ) where

8+import Avail (AvailInfo(..))

9+import Data.Hashable (Hashable)

10+import Control.DeepSeq (NFData)

11+import Data.Binary (Binary)

12+import Data.Text (pack, Text)

13+import Development.IDE.GHC.Util

14+import Development.Shake (RuleResult)

15+import Data.HashMap.Strict (HashMap)

16+import Data.Typeable (Typeable)

17+import GHC.Generics (Generic)

18+import Name

19+import FieldLabel (flSelector)

20+

21+type Identifier = Text

22+type ModuleName = Text

23+

24+data IdentInfo = IdentInfo

25+ { name :: !Identifier

26+ , rendered :: Text

27+ , parent :: !(Maybe Text)

28+ , isDatacon :: !Bool

29+ }

30+ deriving (Eq, Generic, Show)

31+

32+instance NFData IdentInfo

33+

34+mkIdentInfos :: AvailInfo -> [IdentInfo]

35+mkIdentInfos (Avail n) =

36+ [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)]

37+mkIdentInfos (AvailTC parent (n:nn) flds)

38+ -- Following the GHC convention that parent == n if parent is exported

39+ | n == parent

40+ = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) True

41+ | n <- nn ++ map flSelector flds

42+ ] ++

43+ [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing False]

44+ where

45+ parentP = pack $ prettyPrint parent

46+

47+mkIdentInfos (AvailTC _ nn flds)

48+ = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing True

49+ | n <- nn ++ map flSelector flds

50+ ]

51+

52+-- Rule type for caching Package Exports

53+type instance RuleResult PackageExports = PackageExportsMap

54+type PackageExportsMap = HashMap Identifier [(IdentInfo,ModuleName)]

55+

56+newtype PackageExports = PackageExports HscEnvEq

57+ deriving (Eq, Show, Typeable, Generic)

58+

59+instance Hashable PackageExports

60+instance NFData PackageExports

61+instance Binary PackageExports

src/Development/IDE/Plugin/CodeAction/Rules.hsnew file+61

@@ -0,0 +1,61 @@

1+module Development.IDE.Plugin.CodeAction.Rules

2+ ( rulePackageExports

3+ )

4+where

6+import Data.HashMap.Strict ( fromListWith )

7+import Data.Text ( Text

8+ , pack

9+ )

10+import Data.Traversable ( forM )

11+import Development.IDE.Core.Rules

12+import Development.IDE.GHC.Util

13+import Development.IDE.Plugin.CodeAction.RuleTypes

14+import Development.Shake

15+import GHC ( DynFlags(pkgState) )

16+import HscTypes ( IfaceExport

17+ , hsc_dflags

18+ , mi_exports

19+ )

20+import LoadIface

21+import Maybes

22+import Module ( Module(..)

23+ , ModuleName

24+ , moduleNameString

25+ )

26+import Packages ( explicitPackages

27+ , exposedModules

28+ , packageConfigId

29+ )

30+import TcRnMonad ( WhereFrom(ImportByUser)

31+ , initIfaceLoad

32+ )

33+

34+rulePackageExports :: Rules ()

35+rulePackageExports = defineNoFile $ \(PackageExports session) -> do

36+ let env = hscEnv session

37+ pkgst = pkgState (hsc_dflags env)

38+ depends = explicitPackages pkgst

39+ targets =

40+ [ (pkg, mn)

41+ | d <- depends

42+ , Just pkg <- [lookupPackageConfig d env]

43+ , (mn, _) <- exposedModules pkg

44+ ]

45+

46+ results <- forM targets $ \(pkg, mn) -> do

47+ modIface <- liftIO $ initIfaceLoad env $ loadInterface

48+ ""

49+ (Module (packageConfigId pkg) mn)

50+ (ImportByUser False)

51+ case modIface of

52+ Failed _err -> return mempty

53+ Succeeded mi -> do

54+ let avails = mi_exports mi

55+ return $ concatMap (unpackAvail mn) avails

56+ return $ fromListWith (++) $ concat results

57+

58+unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])]

59+unpackAvail mod =

60+ map (\id@IdentInfo {..} -> (name, [(id, pack $ moduleNameString mod)]))

61+ . mkIdentInfos

src/Development/IDE/Plugin/Completions.hs+26−11

@@ -1,7 +1,10 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE TypeFamilies #-}

2{-# LANGUAGE TypeFamilies #-}

3+#include "ghc-api-version.h"

3module Development.IDE.Plugin.Completions(plugin) where

5module Development.IDE.Plugin.Completions(plugin) where

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

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

27+#if !MIN_GHC_API_VERSION(8,6,0) || defined(GHC_LIB)

28+import Data.Maybe

29+import Development.IDE.Import.DependencyInformation

30+#endif

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)

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

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

12import Data.Char (isSpace, isUpper)

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

16import Data.Maybe (fromMaybe, mapMaybe)

17import qualified Data.Text as T

@@ -132,7 +132,7 @@ occNameToComKind ty oc

132

133mkCompl :: IdeOptions -> CompItem -> CompletionItem

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')

137 Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)

138 Nothing Nothing Nothing Nothing Nothing

@@ -162,7 +162,7 @@ getArgText typ = argText

162 where

163 argTypes = getArgs typ

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

167 snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"

168 getArgs :: Type -> [Type]

@@ -186,13 +186,13 @@ getArgText typ = argText

186

187mkModCompl :: T.Text -> CompletionItem

188mkModCompl label =

189− CompletionItem label (Just CiModule) Nothing

189+ CompletionItem label (Just CiModule) (List []) Nothing

190 Nothing Nothing Nothing Nothing Nothing Nothing Nothing

191 Nothing Nothing Nothing Nothing Nothing

192

193mkImportCompl :: T.Text -> T.Text -> CompletionItem

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

197 Nothing Nothing Nothing Nothing Nothing

198 where

@@ -200,19 +200,20 @@ mkImportCompl enteredQual label =

200

201mkExtCompl :: T.Text -> CompletionItem

202mkExtCompl label =

203− CompletionItem label (Just CiKeyword) Nothing

203+ CompletionItem label (Just CiKeyword) (List []) Nothing

204 Nothing Nothing Nothing Nothing Nothing Nothing Nothing

205 Nothing Nothing Nothing Nothing Nothing

206

207mkPragmaCompl :: T.Text -> T.Text -> CompletionItem

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)

211 Nothing Nothing Nothing Nothing Nothing

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

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+17−18

@@ -13,15 +13,12 @@ import Development.IDE.GHC.Orphans()

13import Development.IDE.Types.Location

15-- DAML compiler and infrastructure

16−import Development.Shake

17−import Development.IDE.GHC.Util

18import Development.IDE.GHC.Compat

16import Development.IDE.GHC.Compat

19import Development.IDE.Types.Options

17import Development.IDE.Types.Options

20import Development.IDE.Spans.Type as SpanInfo

18import Development.IDE.Spans.Type as SpanInfo

21import Development.IDE.Spans.Common (spanDocToMarkdown)

19import Development.IDE.Spans.Common (spanDocToMarkdown)

23-- GHC API imports

21-- GHC API imports

24−import Avail

25import DynFlags

22import DynFlags

26import FastString

23import FastString

27import Name

24import Name

@@ -40,14 +37,13 @@ import qualified Data.Text as T

40-- | Locate the definition of the name at a given position.

37-- | Locate the definition of the name at a given position.

41gotoDefinition

38gotoDefinition

42 :: MonadIO m

39 :: MonadIO m

43− => (FilePath -> m (Maybe HieFile))

40+ => (Module -> m (Maybe (HieFile, FilePath)))

44 -> IdeOptions

41 -> IdeOptions

45− -> HscEnv

46 -> [SpanInfo]

42 -> [SpanInfo]

47 -> Position

43 -> Position

48 -> m (Maybe Location)

44 -> m (Maybe Location)

49−gotoDefinition getHieFile ideOpts pkgState srcSpans pos =

45+gotoDefinition getHieFile ideOpts srcSpans pos =

50− listToMaybe <$> locationsAtPoint getHieFile ideOpts pkgState pos srcSpans

46+ listToMaybe <$> locationsAtPoint getHieFile ideOpts pos srcSpans

52-- | Synopsis for the name at a given position.

48-- | Synopsis for the name at a given position.

53atPoint

49atPoint

@@ -87,7 +83,7 @@ atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do

87 constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts

83 constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts

88 constraintsT = T.intercalate ", " (map showName constraintsOverFVs)

84 constraintsT = T.intercalate ", " (map showName constraintsOverFVs)

90− typeAnnotation = case constraintsOverFVs of

86+ typeAnnotation = case constraintsOverFVs of

91 [] -> colon <> showName typ

87 [] -> colon <> showName typ

92 [_] -> colon <> constraintsT <> "\n=> " <> showName typ

88 [_] -> colon <> constraintsT <> "\n=> " <> showName typ

93 _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ

89 _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ

@@ -119,8 +115,15 @@ atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do

119 Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]

115 Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]

120 Nothing -> False

116 Nothing -> False

121

117

122−locationsAtPoint :: forall m . MonadIO m => (FilePath -> m (Maybe HieFile)) -> IdeOptions -> HscEnv -> Position -> [SpanInfo] -> m [Location]

118+locationsAtPoint

119+ :: forall m

120+ . MonadIO m

121+ => (Module -> m (Maybe (HieFile, FilePath)))

122+ -> IdeOptions

123+ -> Position

124+ -> [SpanInfo]

125+ -> m [Location]

123−locationsAtPoint getHieFile IdeOptions{..} pkgState pos =

126+locationsAtPoint getHieFile _ideOptions pos =

124 fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos

127 fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos

125 where getSpan :: SpanSource -> m (Maybe SrcSpan)

128 where getSpan :: SpanSource -> m (Maybe SrcSpan)

126 getSpan NoSource = pure Nothing

129 getSpan NoSource = pure Nothing

@@ -130,20 +133,16 @@ locationsAtPoint getHieFile IdeOptions{..} pkgState pos =

130 sp@(RealSrcSpan _) -> pure $ Just sp

133 sp@(RealSrcSpan _) -> pure $ Just sp

131 sp@(UnhelpfulSpan _) -> runMaybeT $ do

134 sp@(UnhelpfulSpan _) -> runMaybeT $ do

132 guard (sp /= wiredInSrcSpan)

135 guard (sp /= wiredInSrcSpan)

133− -- This case usually arises when the definition is in an external package.

136+ -- This case usually arises when the definition is in an external package (DAML only).

134 -- In this case the interface files contain garbage source spans

137 -- In this case the interface files contain garbage source spans

135 -- so we instead read the .hie files to get useful source spans.

138 -- so we instead read the .hie files to get useful source spans.

136 mod <- MaybeT $ return $ nameModule_maybe name

139 mod <- MaybeT $ return $ nameModule_maybe name

137− let unitId = moduleUnitId mod

138− pkgConfig <- MaybeT $ pure $ lookupPackageConfig unitId pkgState

139− hiePath <- MaybeT $ liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod

140− hieFile <- MaybeT $ getHieFile hiePath

140+ (hieFile, srcPath) <- MaybeT $ getHieFile mod

141− avail <- MaybeT $ pure $ listToMaybe (filterAvails (eqName name) $ hie_exports hieFile)

141+ avail <- MaybeT $ pure $ find (eqName name . snd) $ hieExportNames hieFile

142− srcPath <- MaybeT $ liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod

143 -- The location will point to the source file used during compilation.

142 -- The location will point to the source file used during compilation.

144 -- This file might no longer exists and even if it does the path will be relative

143 -- This file might no longer exists and even if it does the path will be relative

145 -- to the compilation directory which we don’t know.

144 -- to the compilation directory which we don’t know.

146− let span = setFileName srcPath $ nameSrcSpan $ availName avail

145+ let span = setFileName srcPath $ fst avail

147 pure span

146 pure span

148 -- We ignore uniques and source spans and only compare the name and the module.

147 -- We ignore uniques and source spans and only compare the name and the module.

149 eqName :: Name -> Name -> Bool

148 eqName :: Name -> Name -> Bool

src/Development/IDE/Spans/Calculate.hs+19−10

@@ -20,6 +20,7 @@ import DataCon

20import Desugar

21import GHC

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

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(..),

7 ShowDiagnostic(..),

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)

31import Development.IDE.Types.Location

33import Development.IDE.Types.Location

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)

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 })

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(..)

11 , showPosition

12 , Range(..)

13− , Uri(..)

13+ , LSP.Uri(..)

14− , NormalizedUri

14+ , LSP.NormalizedUri

15 , LSP.toNormalizedUri

16 , LSP.fromNormalizedUri

17− , NormalizedFilePath

17+ , LSP.NormalizedFilePath

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

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

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)

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

99−fromNormalizedFilePath :: NormalizedFilePath -> FilePath

44+emptyFilePath :: LSP.NormalizedFilePath

100−fromNormalizedFilePath (NormalizedFilePath _ _ fp) = fp

45+emptyFilePath = LSP.NormalizedFilePath emptyPathUri ""

101

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

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

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

64+fromUri :: LSP.NormalizedUri -> LSP.NormalizedFilePath

65+fromUri = fromMaybe (toNormalizedFilePath' noFilePath) . LSP.uriToNormalizedFilePath

158

159noFilePath :: FilePath

67noFilePath :: FilePath

160noFilePath = "<unknown>"

68noFilePath = "<unknown>"

src/Development/IDE/Types/Options.hs+32−2

@@ -12,6 +12,7 @@ module Development.IDE.Types.Options

12 , clientSupportsProgress

13 , IdePkgLocationOptions(..)

14 , defaultIdeOptions

15+ , IdeResult

15 ) where

16 ) where

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

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.

@@ -40,12 +43,17 @@ data IdeOptions = IdeOptions

40 -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds.

43 -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds.

41 , optShakeProfiling :: Maybe FilePath

44 , optShakeProfiling :: Maybe FilePath

42 -- ^ Set to 'Just' to create a directory of profiling reports.

45 -- ^ Set to 'Just' to create a directory of profiling reports.

46+ , optTesting :: Bool

47+ -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants

43 , optReportProgress :: IdeReportProgress

48 , optReportProgress :: IdeReportProgress

44 -- ^ Whether to report progress during long operations.

49 -- ^ Whether to report progress during long operations.

45 , optLanguageSyntax :: String

50 , optLanguageSyntax :: String

46 -- ^ the ```language to use

51 -- ^ the ```language to use

47 , optNewColonConvention :: Bool

52 , optNewColonConvention :: Bool

48 -- ^ 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.

49 , optDefer :: IdeDefer

57 , optDefer :: IdeDefer

50 -- ^ Whether to defer type errors, typed holes and out of scope

58 -- ^ Whether to defer type errors, typed holes and out of scope

51 -- variables. Deferral allows the IDE to continue to provide

59 -- variables. Deferral allows the IDE to continue to provide

@@ -70,7 +78,7 @@ clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress

70clientSupportsProgress caps = IdeReportProgress $ Just True ==

78clientSupportsProgress caps = IdeReportProgress $ Just True ==

71 (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))

79 (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))

73−defaultIdeOptions :: Action (FilePath -> Action HscEnvEq) -> IdeOptions

81+defaultIdeOptions :: Action (FilePath -> Action (IdeResult HscEnvEq)) -> IdeOptions

74defaultIdeOptions session = IdeOptions

82defaultIdeOptions session = IdeOptions

75 {optPreprocessor = IdePreprocessedSource [] []

83 {optPreprocessor = IdePreprocessedSource [] []

76 ,optGhcSession = session

84 ,optGhcSession = session

@@ -82,7 +90,9 @@ defaultIdeOptions session = IdeOptions

82 ,optReportProgress = IdeReportProgress False

90 ,optReportProgress = IdeReportProgress False

83 ,optLanguageSyntax = "haskell"

91 ,optLanguageSyntax = "haskell"

84 ,optNewColonConvention = False

92 ,optNewColonConvention = False

93+ ,optKeywords = haskellKeywords

85 ,optDefer = IdeDefer True

94 ,optDefer = IdeDefer True

95+ ,optTesting = False

86 }

96 }

@@ -100,3 +110,23 @@ data IdePkgLocationOptions = IdePkgLocationOptions

100defaultIdePkgLocationOptions :: IdePkgLocationOptions

110defaultIdePkgLocationOptions :: IdePkgLocationOptions

101defaultIdePkgLocationOptions = IdePkgLocationOptions f f

111defaultIdePkgLocationOptions = IdePkgLocationOptions f f

102 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:

3- .

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

10- ghc-lib-8.8.1

11- fuzzy-0.1.0.0

@@ -13,6 +13,7 @@ extra-deps:

13- regex-base-0.94.0.0

14- regex-tdfa-1.3.1.0

15- haddock-library-1.8.0

16+- ghc-check-0.3.0.1

16nix:

17nix:

17 packages: [zlib]

18 packages: [zlib]

18flags:

19flags:

stack.yaml+6−4

@@ -2,10 +2,10 @@ resolver: nightly-2019-09-21

2packages:

3- .

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

10- regex-pcre-builtin-0.95.1.1.8.43

11- regex-base-0.94.0.0

@@ -13,5 +13,7 @@ extra-deps:

13- shake-0.18.5

14- parser-combinators-1.2.1

15- haddock-library-1.8.0

16+- tasty-rerun-1.1.17

17+- ghc-check-0.3.0.1

16nix:

18nix:

17 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+13−5

@@ -5,13 +5,13 @@ packages:

5extra-deps:

6- aeson-1.4.6.0

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

12- filepattern-0.1.1

13- js-dgtable-0.5.2

14−- hie-bios-0.4.0

14+- hie-bios-0.5.0

15- fuzzy-0.1.0.0

16- shake-0.18.5

17- time-compat-1.9.2.2

@@ -20,6 +20,14 @@ extra-deps:

20- parser-combinators-1.2.1

21- haddock-library-1.8.0

22- unordered-containers-0.2.10.0

23+- file-embed-0.0.11.2

24+- heaps-0.3.6.1

25+- ghc-check-0.3.0.1

26+# For tasty-retun

27+- ansi-terminal-0.10.3

28+- ansi-wl-pprint-0.6.9

29+- tasty-1.2.3

30+- tasty-rerun-1.1.17

31+

23nix:

32nix:

24 packages: [zlib]

33 packages: [zlib]

25−allow-newer: true

stack88.yaml+5

@@ -2,5 +2,10 @@ resolver: nightly-2020-02-13

2packages:

3- .

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

3+data Bar = Bar

test/data/hover/Foo.hsnew file+5

@@ -0,0 +1,5 @@

1+module Foo (Bar, foo) where

3+import Bar

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)

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

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

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

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

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+673−264

@@ -1,6 +1,7 @@

2-- SPDX-License-Identifier: Apache-2.0

4+{-# LANGUAGE AllowAmbiguousTypes #-}

4{-# LANGUAGE DuplicateRecordFields #-}

5{-# LANGUAGE DuplicateRecordFields #-}

5{-# LANGUAGE PatternSynonyms #-}

6{-# LANGUAGE PatternSynonyms #-}

6{-# LANGUAGE CPP #-}

7{-# LANGUAGE CPP #-}

@@ -9,27 +10,32 @@

9module Main (main) where

10module Main (main) where

11import Control.Applicative.Combinators

12import Control.Applicative.Combinators

12−import Control.Exception (catch)

13+import Control.Exception (bracket, catch)

14+import qualified Control.Lens as Lens

13import Control.Monad

15import Control.Monad

14import Control.Monad.IO.Class (liftIO)

16import Control.Monad.IO.Class (liftIO)

15−import Data.Char (toLower)

17+import Data.Aeson (FromJSON, Value)

16import Data.Foldable

18import Data.Foldable

17−import Data.List

19+import Data.List.Extra

18import Data.Rope.UTF16 (Rope)

20import Data.Rope.UTF16 (Rope)

19import qualified Data.Rope.UTF16 as Rope

21import qualified Data.Rope.UTF16 as Rope

20import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)

22import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)

21import Development.IDE.GHC.Util

23import Development.IDE.GHC.Util

22import qualified Data.Text as T

24import qualified Data.Text as T

25+import Data.Typeable

23import Development.IDE.Spans.Common

26import Development.IDE.Spans.Common

24import Development.IDE.Test

27import Development.IDE.Test

25import Development.IDE.Test.Runfiles

28import Development.IDE.Test.Runfiles

26import Development.IDE.Types.Location

29import Development.IDE.Types.Location

27−import qualified Language.Haskell.LSP.Test as LSPTest

30+import Development.Shake (getDirectoryFilesIO)

28−import Language.Haskell.LSP.Test hiding (openDoc')

31+import Language.Haskell.LSP.Test

32+import Language.Haskell.LSP.Messages

29import Language.Haskell.LSP.Types

33import Language.Haskell.LSP.Types

30import Language.Haskell.LSP.Types.Capabilities

34import Language.Haskell.LSP.Types.Capabilities

35+import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)

31import Language.Haskell.LSP.VFS (applyChange)

36import Language.Haskell.LSP.VFS (applyChange)

37+import Network.URI

32−import System.Environment.Blank (setEnv)

38+import System.Environment.Blank (getEnv, setEnv, unsetEnv)

33import System.FilePath

39import System.FilePath

34import System.IO.Extra

40import System.IO.Extra

35import System.Directory

41import System.Directory

@@ -37,35 +43,41 @@ import Test.QuickCheck

37import Test.QuickCheck.Instances ()

43import Test.QuickCheck.Instances ()

38import Test.Tasty

44import Test.Tasty

39import Test.Tasty.ExpectedFailure

45import Test.Tasty.ExpectedFailure

46+import Test.Tasty.Ingredients.Rerun

40import Test.Tasty.HUnit

47import Test.Tasty.HUnit

41import Test.Tasty.QuickCheck

48import Test.Tasty.QuickCheck

42import Data.Maybe

49import Data.Maybe

44main :: IO ()

51main :: IO ()

52+main = do

53+ -- We mess with env vars so run single-threaded.

54+ setEnv "TASTY_NUM_THREADS" "1" True

45−main = defaultMain $ testGroup "HIE"

55+ defaultMainWithRerun $ testGroup "HIE"

46− [ testSession "open close" $ do

56+ [ testSession "open close" $ do

47− doc <- openDoc' "Testing.hs" "haskell" ""

57+ doc <- createDoc "Testing.hs" "haskell" ""

48− void (message :: Session WorkDoneProgressCreateRequest)

58+ void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)

49− void (message :: Session WorkDoneProgressBeginNotification)

59+ void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)

50− closeDoc doc

60+ closeDoc doc

51− void (message :: Session WorkDoneProgressEndNotification)

61+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)

52− , initializeResponseTests

62+ , initializeResponseTests

53− , completionTests

63+ , completionTests

54− , cppTests

64+ , cppTests

55− , diagnosticTests

65+ , diagnosticTests

56− , codeActionTests

66+ , codeActionTests

57− , codeLensesTests

67+ , codeLensesTests

58− , outlineTests

68+ , outlineTests

59− , findDefinitionAndHoverTests

69+ , findDefinitionAndHoverTests

60− , pluginTests

70+ , pluginTests

61− , preprocessorTests

71+ , preprocessorTests

62− , thTests

72+ , thTests

73+ , safeTests

63− , unitTests

74+ , unitTests

64− , haddockTests

75+ , haddockTests

65− , positionMappingTests

76+ , positionMappingTests

66− , watchedFilesTests

77+ , watchedFilesTests

67− , sessionDepsArePickedUp

78+ , cradleTests

79+ , dependentFileTest

68− ]

80+ ]

70initializeResponseTests :: TestTree

82initializeResponseTests :: TestTree

71initializeResponseTests = withResource acquire release tests where

83initializeResponseTests = withResource acquire release tests where

@@ -100,7 +112,7 @@ initializeResponseTests = withResource acquire release tests where

100 , chk "NO doc link" _documentLinkProvider Nothing

112 , chk "NO doc link" _documentLinkProvider Nothing

101 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)

113 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)

102 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)

114 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)

103− , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

115+ , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

104 , 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 )}))

105 , chk "NO experimental" _experimental Nothing

117 , chk "NO experimental" _experimental Nothing

106 ] where

118 ] where

@@ -116,8 +128,17 @@ initializeResponseTests = withResource acquire release tests where

116 chk title getActual expected =

128 chk title getActual expected =

117 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir

129 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir

118

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+

119 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner

140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner

120− innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c

141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c

121 innerCaps _ = error "this test only expects inner capabilities"

142 innerCaps _ = error "this test only expects inner capabilities"

122

143

123 acquire :: IO InitializeResponse

144 acquire :: IO InitializeResponse

@@ -131,7 +152,7 @@ diagnosticTests :: TestTree

131diagnosticTests = testGroup "diagnostics"

152diagnosticTests = testGroup "diagnostics"

132 [ testSessionWait "fix syntax error" $ do

153 [ testSessionWait "fix syntax error" $ do

133 let content = T.unlines [ "module Testing wher" ]

154 let content = T.unlines [ "module Testing wher" ]

134− doc <- openDoc' "Testing.hs" "haskell" content

155+ doc <- createDoc "Testing.hs" "haskell" content

135 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]

156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]

136 let change = TextDocumentContentChangeEvent

157 let change = TextDocumentContentChangeEvent

137 { _range = Just (Range (Position 0 15) (Position 0 19))

158 { _range = Just (Range (Position 0 15) (Position 0 19))

@@ -142,9 +163,9 @@ diagnosticTests = testGroup "diagnostics"

142 expectDiagnostics [("Testing.hs", [])]

163 expectDiagnostics [("Testing.hs", [])]

143 , testSessionWait "introduce syntax error" $ do

164 , testSessionWait "introduce syntax error" $ do

144 let content = T.unlines [ "module Testing where" ]

165 let content = T.unlines [ "module Testing where" ]

145− doc <- openDoc' "Testing.hs" "haskell" content

166+ doc <- createDoc "Testing.hs" "haskell" content

146− void (message :: Session WorkDoneProgressCreateRequest)

167+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)

147− void (message :: Session WorkDoneProgressBeginNotification)

168+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)

148 let change = TextDocumentContentChangeEvent

169 let change = TextDocumentContentChangeEvent

149 { _range = Just (Range (Position 0 15) (Position 0 18))

170 { _range = Just (Range (Position 0 15) (Position 0 18))

150 , _rangeLength = Nothing

171 , _rangeLength = Nothing

@@ -160,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"

160 , "bar :: Int -> Int -> Int"

181 , "bar :: Int -> Int -> Int"

161 , "bar a b = cd + b"

182 , "bar a b = cd + b"

162 ]

183 ]

163− _ <- openDoc' "Testing.hs" "haskell" content

184+ _ <- createDoc "Testing.hs" "haskell" content

164 expectDiagnostics

185 expectDiagnostics

165 [ ( "Testing.hs"

186 [ ( "Testing.hs"

166 , [ (DsError, (2, 14), "Variable not in scope: ab")

187 , [ (DsError, (2, 14), "Variable not in scope: ab")

@@ -174,7 +195,7 @@ diagnosticTests = testGroup "diagnostics"

174 , "foo :: Int -> String -> Int"

195 , "foo :: Int -> String -> Int"

175 , "foo a b = a + b"

196 , "foo a b = a + b"

176 ]

197 ]

177− _ <- openDoc' "Testing.hs" "haskell" content

198+ _ <- createDoc "Testing.hs" "haskell" content

178 expectDiagnostics

199 expectDiagnostics

179 [ ( "Testing.hs"

200 [ ( "Testing.hs"

180 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]

201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]

@@ -186,7 +207,7 @@ diagnosticTests = testGroup "diagnostics"

186 , "foo :: Int -> String"

207 , "foo :: Int -> String"

187 , "foo a = _ a"

208 , "foo a = _ a"

188 ]

209 ]

189− _ <- openDoc' "Testing.hs" "haskell" content

210+ _ <- createDoc "Testing.hs" "haskell" content

190 expectDiagnostics

211 expectDiagnostics

191 [ ( "Testing.hs"

212 [ ( "Testing.hs"

192 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]

213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]

@@ -208,24 +229,23 @@ diagnosticTests = testGroup "diagnostics"

208 [ ("A.hs", [(DsError, (2,4), aMessage)])

229 [ ("A.hs", [(DsError, (2,4), aMessage)])

209 , ("B.hs", [(DsError, (3,4), bMessage)])]

230 , ("B.hs", [(DsError, (3,4), bMessage)])]

210 deferralTest title binding msg = testSessionWait title $ do

231 deferralTest title binding msg = testSessionWait title $ do

211− _ <- openDoc' "A.hs" "haskell" $ sourceA binding

232+ _ <- createDoc "A.hs" "haskell" $ sourceA binding

212− _ <- openDoc' "B.hs" "haskell" sourceB

233+ _ <- createDoc "B.hs" "haskell" sourceB

213 expectDiagnostics $ expectedDs msg

234 expectDiagnostics $ expectedDs msg

214 in

235 in

215 [ deferralTest "type error" "True" "Couldn't match expected type"

236 [ deferralTest "type error" "True" "Couldn't match expected type"

216 , deferralTest "typed hole" "_" "Found hole"

237 , deferralTest "typed hole" "_" "Found hole"

217 , deferralTest "out of scope var" "unbound" "Variable not in scope"

238 , deferralTest "out of scope var" "unbound" "Variable not in scope"

218− , deferralTest "message shows error" "True" "A.hs:3:5: error:"

219 ]

239 ]

220

240

221 , testSessionWait "remove required module" $ do

241 , testSessionWait "remove required module" $ do

222 let contentA = T.unlines [ "module ModuleA where" ]

242 let contentA = T.unlines [ "module ModuleA where" ]

223− docA <- openDoc' "ModuleA.hs" "haskell" contentA

243+ docA <- createDoc "ModuleA.hs" "haskell" contentA

224 let contentB = T.unlines

244 let contentB = T.unlines

225 [ "module ModuleB where"

245 [ "module ModuleB where"

226 , "import ModuleA"

246 , "import ModuleA"

227 ]

247 ]

228− _ <- openDoc' "ModuleB.hs" "haskell" contentB

248+ _ <- createDoc "ModuleB.hs" "haskell" contentB

229 let change = TextDocumentContentChangeEvent

249 let change = TextDocumentContentChangeEvent

230 { _range = Just (Range (Position 0 0) (Position 0 20))

250 { _range = Just (Range (Position 0 0) (Position 0 20))

231 , _rangeLength = Nothing

251 , _rangeLength = Nothing

@@ -238,20 +258,20 @@ diagnosticTests = testGroup "diagnostics"

238 [ "module ModuleB where"

258 [ "module ModuleB where"

239 , "import ModuleA"

259 , "import ModuleA"

240 ]

260 ]

241− _ <- openDoc' "ModuleB.hs" "haskell" contentB

261+ _ <- createDoc "ModuleB.hs" "haskell" contentB

242 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

243 let contentA = T.unlines [ "module ModuleA where" ]

263 let contentA = T.unlines [ "module ModuleA where" ]

244− _ <- openDoc' "ModuleA.hs" "haskell" contentA

264+ _ <- createDoc "ModuleA.hs" "haskell" contentA

245 expectDiagnostics [("ModuleB.hs", [])]

265 expectDiagnostics [("ModuleB.hs", [])]

246 , testSessionWait "add missing module (non workspace)" $ do

266 , testSessionWait "add missing module (non workspace)" $ do

247 let contentB = T.unlines

267 let contentB = T.unlines

248 [ "module ModuleB where"

268 [ "module ModuleB where"

249 , "import ModuleA"

269 , "import ModuleA"

250 ]

270 ]

251− _ <- openDoc'' "/tmp/ModuleB.hs" "haskell" contentB

271+ _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB

252 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

272 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

253 let contentA = T.unlines [ "module ModuleA where" ]

273 let contentA = T.unlines [ "module ModuleA where" ]

254− _ <- openDoc'' "/tmp/ModuleA.hs" "haskell" contentA

274+ _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA

255 expectDiagnostics [("/tmp/ModuleB.hs", [])]

275 expectDiagnostics [("/tmp/ModuleB.hs", [])]

256 , testSessionWait "cyclic module dependency" $ do

276 , testSessionWait "cyclic module dependency" $ do

257 let contentA = T.unlines

277 let contentA = T.unlines

@@ -262,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"

262 [ "module ModuleB where"

282 [ "module ModuleB where"

263 , "import ModuleA"

283 , "import ModuleA"

264 ]

284 ]

265− _ <- openDoc' "ModuleA.hs" "haskell" contentA

285+ _ <- createDoc "ModuleA.hs" "haskell" contentA

266− _ <- openDoc' "ModuleB.hs" "haskell" contentB

286+ _ <- createDoc "ModuleB.hs" "haskell" contentB

267 expectDiagnostics

287 expectDiagnostics

268 [ ( "ModuleA.hs"

288 [ ( "ModuleA.hs"

269 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]

289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]

@@ -284,9 +304,9 @@ diagnosticTests = testGroup "diagnostics"

284 let contentBboot = T.unlines

304 let contentBboot = T.unlines

285 [ "module ModuleB where"

305 [ "module ModuleB where"

286 ]

306 ]

287− _ <- openDoc' "ModuleA.hs" "haskell" contentA

307+ _ <- createDoc "ModuleA.hs" "haskell" contentA

288− _ <- openDoc' "ModuleB.hs" "haskell" contentB

308+ _ <- createDoc "ModuleB.hs" "haskell" contentB

289− _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot

309+ _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot

290 expectDiagnostics []

310 expectDiagnostics []

291 , testSessionWait "correct reference used with hs-boot" $ do

311 , testSessionWait "correct reference used with hs-boot" $ do

292 let contentB = T.unlines

312 let contentB = T.unlines

@@ -308,10 +328,10 @@ diagnosticTests = testGroup "diagnostics"

308 -- resolved to the hs-boot file

328 -- resolved to the hs-boot file

309 , "y = x"

329 , "y = x"

310 ]

330 ]

311− _ <- openDoc' "ModuleB.hs" "haskell" contentB

331+ _ <- createDoc "ModuleB.hs" "haskell" contentB

312− _ <- openDoc' "ModuleA.hs" "haskell" contentA

332+ _ <- createDoc "ModuleA.hs" "haskell" contentA

313− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot

333+ _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot

314− _ <- openDoc' "ModuleC.hs" "haskell" contentC

334+ _ <- createDoc "ModuleC.hs" "haskell" contentC

315 expectDiagnostics []

335 expectDiagnostics []

316 , testSessionWait "redundant import" $ do

336 , testSessionWait "redundant import" $ do

317 let contentA = T.unlines ["module ModuleA where"]

337 let contentA = T.unlines ["module ModuleA where"]

@@ -320,8 +340,8 @@ diagnosticTests = testGroup "diagnostics"

320 , "module ModuleB where"

340 , "module ModuleB where"

321 , "import ModuleA"

341 , "import ModuleA"

322 ]

342 ]

323− _ <- openDoc' "ModuleA.hs" "haskell" contentA

343+ _ <- createDoc "ModuleA.hs" "haskell" contentA

324− _ <- openDoc' "ModuleB.hs" "haskell" contentB

344+ _ <- createDoc "ModuleB.hs" "haskell" contentB

325 expectDiagnostics

345 expectDiagnostics

326 [ ( "ModuleB.hs"

346 [ ( "ModuleB.hs"

327 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]

347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]

@@ -343,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"

343 , "wrong1 = ThisList.map"

363 , "wrong1 = ThisList.map"

344 , "wrong2 = BaseList.x"

364 , "wrong2 = BaseList.x"

345 ]

365 ]

346− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent

366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent

347− _ <- openDoc' "Main.hs" "haskell" mainContent

367+ _ <- createDoc "Main.hs" "haskell" mainContent

348 expectDiagnostics

368 expectDiagnostics

349 [ ( "Main.hs"

369 [ ( "Main.hs"

350 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")

370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")

@@ -359,7 +379,7 @@ diagnosticTests = testGroup "diagnostics"

359 , "foo :: Ord a => a -> Int"

379 , "foo :: Ord a => a -> Int"

360 , "foo a = 1"

380 , "foo a = 1"

361 ]

381 ]

362− _ <- openDoc' "Foo.hs" "haskell" fooContent

382+ _ <- createDoc "Foo.hs" "haskell" fooContent

363 expectDiagnostics

383 expectDiagnostics

364 [ ( "Foo.hs"

384 [ ( "Foo.hs"

365 -- The test is to make sure that warnings contain unqualified names

385 -- The test is to make sure that warnings contain unqualified names

@@ -384,18 +404,18 @@ diagnosticTests = testGroup "diagnostics"

384 Just pathB <- pure $ uriToFilePath uriB

404 Just pathB <- pure $ uriToFilePath uriB

385 uriB <- pure $

405 uriB <- pure $

386 let (drive, suffix) = splitDrive pathB

406 let (drive, suffix) = splitDrive pathB

387− in filePathToUri (joinDrive (map toLower drive ) suffix)

407+ in filePathToUri (joinDrive (lower drive) suffix)

388 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)

408 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)

389 liftIO $ writeFileUTF8 pathB $ T.unpack bContent

409 liftIO $ writeFileUTF8 pathB $ T.unpack bContent

390 uriA <- getDocUri "A/A.hs"

410 uriA <- getDocUri "A/A.hs"

391 Just pathA <- pure $ uriToFilePath uriA

411 Just pathA <- pure $ uriToFilePath uriA

392 uriA <- pure $

412 uriA <- pure $

393 let (drive, suffix) = splitDrive pathA

413 let (drive, suffix) = splitDrive pathA

394− in filePathToUri (joinDrive (map toLower drive ) suffix)

414+ in filePathToUri (joinDrive (lower drive) suffix)

395 let itemA = TextDocumentItem uriA "haskell" 0 aContent

415 let itemA = TextDocumentItem uriA "haskell" 0 aContent

396 let a = TextDocumentIdentifier uriA

416 let a = TextDocumentIdentifier uriA

397 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)

417 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)

398− diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification

418+ diagsNot <- skipManyTill anyMessage diagnostic

399 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)

419 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)

400 -- 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

401 -- the diagnostics for A.B will also be lower-case.

421 -- the diagnostics for A.B will also be lower-case.

@@ -404,6 +424,38 @@ diagnosticTests = testGroup "diagnostics"

404 liftIO $ unless ("redundant" `T.isInfixOf` msg) $

424 liftIO $ unless ("redundant" `T.isInfixOf` msg) $

405 assertFailure ("Expected redundant import but got " <> T.unpack msg)

425 assertFailure ("Expected redundant import but got " <> T.unpack msg)

406 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

407 ]

459 ]

408

460

409codeActionTests :: TestTree

461codeActionTests :: TestTree

@@ -412,6 +464,7 @@ codeActionTests = testGroup "code actions"

412 , typeWildCardActionTests

464 , typeWildCardActionTests

413 , removeImportTests

465 , removeImportTests

414 , extendImportTests

466 , extendImportTests

467+ , suggestImportTests

415 , addExtensionTests

468 , addExtensionTests

416 , fixConstructorImportTests

469 , fixConstructorImportTests

417 , importRenameActionTests

470 , importRenameActionTests

@@ -427,21 +480,28 @@ codeLensesTests = testGroup "code lenses"

427

480

428watchedFilesTests :: TestTree

481watchedFilesTests :: TestTree

429watchedFilesTests = testGroup "watched files"

482watchedFilesTests = testGroup "watched files"

430− [ testSession "workspace file" $ do

483+ [ testSession' "workspace files" $ \sessionDir -> do

431− _ <- openDoc' "A.hs" "haskell" "module A where"

484+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"

432− RequestMessage{_params = RegistrationParams (List regs)} <- skipManyTill anyMessage (message @RegisterCapabilityRequest)

485+ _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"

433− let watchedFileRegs =

486+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

434− [ args | Registration _id WorkspaceDidChangeWatchedFiles args <- regs ]

487+

435− liftIO $ assertBool "watches workspace files" $ not $ null watchedFileRegs

488+ -- Expect 4 subscriptions (A does not get any because it's VFS):

489+ -- - /path-to-workspace/WatchedFilesMissingModule.hs

490+ -- - /path-to-workspace/WatchedFilesMissingModule.lhs

491+ -- - /path-to-workspace/src/WatchedFilesMissingModule.hs

492+ -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs

493+ liftIO $ length watchedFileRegs @?= 4

494+

436− , testSession "non workspace file" $ do

495+ , testSession' "non workspace file" $ \sessionDir -> do

437− _ <- openDoc' "/tmp/A.hs" "haskell" "module A where"

496+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"

438− msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @WorkDoneProgressEndNotification)

497+ _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"

439− let watchedFileRegs =

498+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

440− [ args

499+

441− | Just (RequestMessage{_params = RegistrationParams (List regs)}) <- msgs

500+ -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):

442− , Registration _id WorkspaceDidChangeWatchedFiles args <- regs

501+ -- - /path-to-workspace/WatchedFilesMissingModule.hs

443− ]

502+ -- - /path-to-workspace/WatchedFilesMissingModule.lhs

444− liftIO $ watchedFileRegs @?= []

503+ liftIO $ length watchedFileRegs @?= 2

504+

445 -- TODO add a test for didChangeWorkspaceFolder

505 -- TODO add a test for didChangeWorkspaceFolder

446 ]

506 ]

447

507

@@ -453,7 +513,7 @@ renameActionTests = testGroup "rename actions"

453 , "foo :: Int -> Int"

513 , "foo :: Int -> Int"

454 , "foo argName = argNme"

514 , "foo argName = argNme"

455 ]

515 ]

456− doc <- openDoc' "Testing.hs" "haskell" content

516+ doc <- createDoc "Testing.hs" "haskell" content

457 _ <- waitForDiagnostics

517 _ <- waitForDiagnostics

458 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’"

459 executeCodeAction action

519 executeCodeAction action

@@ -471,7 +531,7 @@ renameActionTests = testGroup "rename actions"

471 , "foo :: Maybe a -> [a]"

531 , "foo :: Maybe a -> [a]"

472 , "foo = maybToList"

532 , "foo = maybToList"

473 ]

533 ]

474− doc <- openDoc' "Testing.hs" "haskell" content

534+ doc <- createDoc "Testing.hs" "haskell" content

475 _ <- waitForDiagnostics

535 _ <- waitForDiagnostics

476 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’"

477 executeCodeAction action

537 executeCodeAction action

@@ -489,7 +549,7 @@ renameActionTests = testGroup "rename actions"

489 , "foo :: Char -> Char -> Char -> Char"

549 , "foo :: Char -> Char -> Char -> Char"

490 , "foo argument1 argument2 argument3 = argumentX"

550 , "foo argument1 argument2 argument3 = argumentX"

491 ]

551 ]

492− doc <- openDoc' "Testing.hs" "haskell" content

552+ doc <- createDoc "Testing.hs" "haskell" content

493 _ <- waitForDiagnostics

553 _ <- waitForDiagnostics

494 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))

554 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))

495 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]

555 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]

@@ -501,7 +561,7 @@ renameActionTests = testGroup "rename actions"

501 , "monus x y = max 0 (x - y)"

561 , "monus x y = max 0 (x - y)"

502 , "foo x y = x `monnus` y"

562 , "foo x y = x `monnus` y"

503 ]

563 ]

504− doc <- openDoc' "Testing.hs" "haskell" content

564+ doc <- createDoc "Testing.hs" "haskell" content

505 _ <- waitForDiagnostics

565 _ <- waitForDiagnostics

506 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))

566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))

507 [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 ]

@@ -524,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

524 , "func :: _"

584 , "func :: _"

525 , "func x = x"

585 , "func x = x"

526 ]

586 ]

527− doc <- openDoc' "Testing.hs" "haskell" content

587+ doc <- createDoc "Testing.hs" "haskell" content

528 _ <- waitForDiagnostics

588 _ <- waitForDiagnostics

529 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

530 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -544,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

544 , "func :: _"

604 , "func :: _"

545 , "func x y = x + y"

605 , "func x y = x + y"

546 ]

606 ]

547− doc <- openDoc' "Testing.hs" "haskell" content

607+ doc <- createDoc "Testing.hs" "haskell" content

548 _ <- waitForDiagnostics

608 _ <- waitForDiagnostics

549 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

550 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -567,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

567 , " y = x * 2"

627 , " y = x * 2"

568 , " in y"

628 , " in y"

569 ]

629 ]

570− doc <- openDoc' "Testing.hs" "haskell" content

630+ doc <- createDoc "Testing.hs" "haskell" content

571 _ <- waitForDiagnostics

631 _ <- waitForDiagnostics

572 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))

632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))

573 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -592,7 +652,7 @@ removeImportTests = testGroup "remove import actions"

592 let contentA = T.unlines

652 let contentA = T.unlines

593 [ "module ModuleA where"

653 [ "module ModuleA where"

594 ]

654 ]

595− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

596 let contentB = T.unlines

656 let contentB = T.unlines

597 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

598 , "module ModuleB where"

658 , "module ModuleB where"

@@ -600,7 +660,7 @@ removeImportTests = testGroup "remove import actions"

600 , "stuffB :: Integer"

660 , "stuffB :: Integer"

601 , "stuffB = 123"

661 , "stuffB = 123"

602 ]

662 ]

603− docB <- openDoc' "ModuleB.hs" "haskell" contentB

663+ docB <- createDoc "ModuleB.hs" "haskell" contentB

604 _ <- waitForDiagnostics

664 _ <- waitForDiagnostics

605 [CACodeAction action@CodeAction { _title = actionTitle }]

665 [CACodeAction action@CodeAction { _title = actionTitle }]

606 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -618,7 +678,7 @@ removeImportTests = testGroup "remove import actions"

618 let contentA = T.unlines

678 let contentA = T.unlines

619 [ "module ModuleA where"

679 [ "module ModuleA where"

620 ]

680 ]

621− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

622 let contentB = T.unlines

682 let contentB = T.unlines

623 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

624 , "module ModuleB where"

684 , "module ModuleB where"

@@ -626,7 +686,7 @@ removeImportTests = testGroup "remove import actions"

626 , "stuffB :: Integer"

686 , "stuffB :: Integer"

627 , "stuffB = 123"

687 , "stuffB = 123"

628 ]

688 ]

629− docB <- openDoc' "ModuleB.hs" "haskell" contentB

689+ docB <- createDoc "ModuleB.hs" "haskell" contentB

630 _ <- waitForDiagnostics

690 _ <- waitForDiagnostics

631 [CACodeAction action@CodeAction { _title = actionTitle }]

691 [CACodeAction action@CodeAction { _title = actionTitle }]

632 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -648,14 +708,14 @@ removeImportTests = testGroup "remove import actions"

648 , "stuffB = 123"

708 , "stuffB = 123"

649 , "stuffC = ()"

709 , "stuffC = ()"

650 ]

710 ]

651− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

652 let contentB = T.unlines

712 let contentB = T.unlines

653 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

713 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

654 , "module ModuleB where"

714 , "module ModuleB where"

655 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"

715 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"

656 , "main = print stuffB"

716 , "main = print stuffB"

657 ]

717 ]

658− docB <- openDoc' "ModuleB.hs" "haskell" contentB

718+ docB <- createDoc "ModuleB.hs" "haskell" contentB

659 _ <- waitForDiagnostics

719 _ <- waitForDiagnostics

660 [CACodeAction action@CodeAction { _title = actionTitle }]

720 [CACodeAction action@CodeAction { _title = actionTitle }]

661 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

721 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -669,29 +729,26 @@ removeImportTests = testGroup "remove import actions"

669 , "main = print stuffB"

729 , "main = print stuffB"

670 ]

730 ]

671 liftIO $ expectedContentAfterAction @=? contentAfterAction

731 liftIO $ expectedContentAfterAction @=? contentAfterAction

672− , testSession "redundant symbol binding" $ do

732+ , testSession "redundant operator" $ do

673 let contentA = T.unlines

733 let contentA = T.unlines

674 [ "module ModuleA where"

734 [ "module ModuleA where"

675 , "a !! b = a"

735 , "a !! b = a"

736+ , "a <?> b = a"

676 , "stuffB :: Integer"

737 , "stuffB :: Integer"

677 , "stuffB = 123"

738 , "stuffB = 123"

678 ]

739 ]

679− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

680 let contentB = T.unlines

741 let contentB = T.unlines

681 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

742 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

682 , "module ModuleB where"

743 , "module ModuleB where"

683− , "import qualified ModuleA as A ((!!), stuffB, (!!))"

744+ , "import qualified ModuleA as A ((<?>), stuffB, (!!))"

684 , "main = print A.stuffB"

745 , "main = print A.stuffB"

685 ]

746 ]

686− docB <- openDoc' "ModuleB.hs" "haskell" contentB

747+ docB <- createDoc "ModuleB.hs" "haskell" contentB

687 _ <- waitForDiagnostics

748 _ <- waitForDiagnostics

688 [CACodeAction action@CodeAction { _title = actionTitle }]

749 [CACodeAction action@CodeAction { _title = actionTitle }]

689 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

750 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

690−#if MIN_GHC_API_VERSION(8,6,0)

691− liftIO $ "Remove !! from import" @=? actionTitle

692−#else

693− liftIO $ "Remove A.!! from import" @=? actionTitle

751+ liftIO $ "Remove !!, <?> from import" @=? actionTitle

694−#endif

695 executeCodeAction action

752 executeCodeAction action

696 contentAfterAction <- documentContents docB

753 contentAfterAction <- documentContents docB

697 let expectedContentAfterAction = T.unlines

754 let expectedContentAfterAction = T.unlines

@@ -701,21 +758,21 @@ removeImportTests = testGroup "remove import actions"

701 , "main = print A.stuffB"

758 , "main = print A.stuffB"

702 ]

759 ]

703 liftIO $ expectedContentAfterAction @=? contentAfterAction

760 liftIO $ expectedContentAfterAction @=? contentAfterAction

704− , (`xfail` "known broken (#299)") $ testSession "redundant hierarchical import" $ do

761+ , testSession "redundant all import" $ do

705 let contentA = T.unlines

762 let contentA = T.unlines

706 [ "module ModuleA where"

763 [ "module ModuleA where"

707 , "data A = A"

764 , "data A = A"

708 , "stuffB :: Integer"

765 , "stuffB :: Integer"

709 , "stuffB = 123"

766 , "stuffB = 123"

710 ]

767 ]

711− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

712 let contentB = T.unlines

769 let contentB = T.unlines

713 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

770 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

714 , "module ModuleB where"

771 , "module ModuleB where"

715 , "import ModuleA (A(..), stuffB)"

772 , "import ModuleA (A(..), stuffB)"

716 , "main = print stuffB"

773 , "main = print stuffB"

717 ]

774 ]

718− docB <- openDoc' "ModuleB.hs" "haskell" contentB

775+ docB <- createDoc "ModuleB.hs" "haskell" contentB

719 _ <- waitForDiagnostics

776 _ <- waitForDiagnostics

720 [CACodeAction action@CodeAction { _title = actionTitle }]

777 [CACodeAction action@CodeAction { _title = actionTitle }]

721 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

778 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -729,6 +786,33 @@ removeImportTests = testGroup "remove import actions"

729 , "main = print stuffB"

786 , "main = print stuffB"

730 ]

787 ]

731 liftIO $ expectedContentAfterAction @=? contentAfterAction

788 liftIO $ expectedContentAfterAction @=? contentAfterAction

789+ , testSession "redundant constructor import" $ do

790+ let contentA = T.unlines

791+ [ "module ModuleA where"

792+ , "data D = A | B"

793+ , "data E = F"

794+ ]

795+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

796+ let contentB = T.unlines

797+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"

798+ , "module ModuleB where"

799+ , "import ModuleA (D(A,B), E(F))"

800+ , "main = B"

801+ ]

802+ docB <- createDoc "ModuleB.hs" "haskell" contentB

803+ _ <- waitForDiagnostics

804+ [CACodeAction action@CodeAction { _title = actionTitle }]

805+ <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

806+ liftIO $ "Remove A, E, F from import" @=? actionTitle

807+ executeCodeAction action

808+ contentAfterAction <- documentContents docB

809+ let expectedContentAfterAction = T.unlines

810+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"

811+ , "module ModuleB where"

812+ , "import ModuleA (D(B))"

813+ , "main = B"

814+ ]

815+ liftIO $ expectedContentAfterAction @=? contentAfterAction

732 ]

816 ]

733

817

734extendImportTests :: TestTree

818extendImportTests :: TestTree

@@ -856,8 +940,8 @@ extendImportTests = testGroup "extend import actions"

856 ]

940 ]

857 where

941 where

858 template contentA contentB range expectedAction expectedContentB = do

942 template contentA contentB range expectedAction expectedContentB = do

859− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

860− docB <- openDoc' "ModuleB.hs" "haskell" contentB

944+ docB <- createDoc "ModuleB.hs" "haskell" contentB

861 _ <- waitForDiagnostics

945 _ <- waitForDiagnostics

862 CACodeAction action@CodeAction { _title = actionTitle } : _

946 CACodeAction action@CodeAction { _title = actionTitle } : _

863 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

947 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -867,6 +951,61 @@ extendImportTests = testGroup "extend import actions"

867 contentAfterAction <- documentContents docB

951 contentAfterAction <- documentContents docB

868 liftIO $ expectedContentB @=? contentAfterAction

952 liftIO $ expectedContentB @=? contentAfterAction

869

953

954+suggestImportTests :: TestTree

955+suggestImportTests = testGroup "suggest import actions"

956+ [ testGroup "Dont want suggestion"

957+ [ -- extend import

958+ test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"

959+ -- data constructor

960+ , test False [] "f = First" [] "import Data.Monoid (First)"

961+ -- internal module

962+ , test False [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable.Internal (Typeable)"

963+ -- package not in scope

964+ , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)"

965+ ]

966+ , testGroup "want suggestion"

967+ [ test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"

968+ , test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))"

969+ , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)"

970+ , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (NonEmpty)"

971+ , test True [] "f = First" [] "import Data.Monoid (First(First))"

972+ , test True [] "f = Endo" [] "import Data.Monoid (Endo(Endo))"

973+ , test True [] "f = Version" [] "import Data.Version (Version(Version))"

974+ , test True [] "f ExitSuccess = ()" [] "import System.Exit (ExitCode(ExitSuccess))"

975+ , test True [] "f = AssertionFailed" [] "import Control.Exception (AssertionFailed(AssertionFailed))"

976+ , test True ["Prelude"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"

977+ , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)"

978+ , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))"

979+ , test True [] "f = (&)" [] "import Data.Function ((&))"

980+ , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE"

981+ , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"

982+ , test True [] "f = pack" [] "import Data.Text (pack)"

983+ , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)"

984+ , test True [] "f = [] & id" [] "import Data.Function ((&))"

985+ , test True [] "f = (&) [] id" [] "import Data.Function ((&))"

986+ ]

987+ ]

988+ where

989+ test wanted imps def other newImp = testSession' (T.unpack def) $ \dir -> do

990+ let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other

991+ after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other

992+ cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"

993+ liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle

994+ doc <- createDoc "Test.hs" "haskell" before

995+ _diags <- waitForDiagnostics

996+ let defLine = length imps + 1

997+ range = Range (Position defLine 0) (Position defLine maxBound)

998+ actions <- getCodeActions doc range

999+ if wanted

1000+ then do

1001+ action <- liftIO $ pickActionWithTitle newImp actions

1002+ executeCodeAction action

1003+ contentAfterAction <- documentContents doc

1004+ liftIO $ after @=? contentAfterAction

1005+ else

1006+ liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []

1007+

1008+

870addExtensionTests :: TestTree

1009addExtensionTests :: TestTree

871addExtensionTests = testGroup "add language extension actions"

1010addExtensionTests = testGroup "add language extension actions"

872 [ testSession "add NamedFieldPuns language extension" $ template

1011 [ testSession "add NamedFieldPuns language extension" $ template

@@ -912,7 +1051,7 @@ addExtensionTests = testGroup "add language extension actions"

912 ]

1051 ]

913 where

1052 where

914 template initialContent range expectedAction expectedContents = do

1053 template initialContent range expectedAction expectedContents = do

915− doc <- openDoc' "Module.hs" "haskell" initialContent

1054+ doc <- createDoc "Module.hs" "haskell" initialContent

916 _ <- waitForDiagnostics

1055 _ <- waitForDiagnostics

917 CACodeAction action@CodeAction { _title = actionTitle } : _

1056 CACodeAction action@CodeAction { _title = actionTitle } : _

918 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1057 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -935,7 +1074,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"

935 [""

1074 [""

936 ,"someOtherCode = ()"

1075 ,"someOtherCode = ()"

937 ]

1076 ]

938− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

939 _ <- waitForDiagnostics

1078 _ <- waitForDiagnostics

940 CACodeAction action@CodeAction { _title = actionTitle } : _

1079 CACodeAction action@CodeAction { _title = actionTitle } : _

941 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1080 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -959,7 +1098,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"

959 [""

1098 [""

960 ,"someOtherCode = ()"

1099 ,"someOtherCode = ()"

961 ]

1100 ]

962− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

963 _ <- waitForDiagnostics

1102 _ <- waitForDiagnostics

964 CACodeAction action@CodeAction { _title = actionTitle } : _

1103 CACodeAction action@CodeAction { _title = actionTitle } : _

965 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1104 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -998,8 +1137,8 @@ fixConstructorImportTests = testGroup "fix import actions"

998 ]

1137 ]

999 where

1138 where

1000 template contentA contentB range expectedAction expectedContentB = do

1139 template contentA contentB range expectedAction expectedContentB = do

1001− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

1002− docB <- openDoc' "ModuleB.hs" "haskell" contentB

1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB

1003 _diags <- waitForDiagnostics

1142 _diags <- waitForDiagnostics

1004 CACodeAction action@CodeAction { _title = actionTitle } : _

1143 CACodeAction action@CodeAction { _title = actionTitle } : _

1005 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1144 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -1018,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"

1018 [ "module Testing where"

1157 [ "module Testing where"

1019 , "import Data.Mape"

1158 , "import Data.Mape"

1020 ]

1159 ]

1021− doc <- openDoc' "Testing.hs" "haskell" content

1160+ doc <- createDoc "Testing.hs" "haskell" content

1022 _ <- waitForDiagnostics

1161 _ <- waitForDiagnostics

1023 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))

1162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))

1024 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 ]

@@ -1055,10 +1194,10 @@ fillTypedHoleTests = let

1055 newA newB newC = testSession (T.unpack actionTitle) $ do

1194 newA newB newC = testSession (T.unpack actionTitle) $ do

1056 let originalCode = sourceCode oldA oldB oldC

1195 let originalCode = sourceCode oldA oldB oldC

1057 let expectedCode = sourceCode newA newB newC

1196 let expectedCode = sourceCode newA newB newC

1058− doc <- openDoc' "Testing.hs" "haskell" originalCode

1197+ doc <- createDoc "Testing.hs" "haskell" originalCode

1059 _ <- waitForDiagnostics

1198 _ <- waitForDiagnostics

1060 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))

1199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))

1061− let chosenAction = pickActionWithTitle actionTitle actionsOrCommands

1200+ chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands

1062 executeCodeAction chosenAction

1201 executeCodeAction chosenAction

1063 modifiedCode <- documentContents doc

1202 modifiedCode <- documentContents doc

1064 liftIO $ expectedCode @=? modifiedCode

1203 liftIO $ expectedCode @=? modifiedCode

@@ -1103,10 +1242,10 @@ addSigActionTests = let

1103 def >:: sig = testSession (T.unpack def) $ do

1242 def >:: sig = testSession (T.unpack def) $ do

1104 let originalCode = before def

1243 let originalCode = before def

1105 let expectedCode = after' def sig

1244 let expectedCode = after' def sig

1106− doc <- openDoc' "Sigs.hs" "haskell" originalCode

1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode

1107 _ <- waitForDiagnostics

1246 _ <- waitForDiagnostics

1108 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))

1247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))

1109− let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

1248+ chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

1110 executeCodeAction chosenAction

1249 executeCodeAction chosenAction

1111 modifiedCode <- documentContents doc

1250 modifiedCode <- documentContents doc

1112 liftIO $ expectedCode @=? modifiedCode

1251 liftIO $ expectedCode @=? modifiedCode

@@ -1135,7 +1274,7 @@ addSigLensesTests = let

1135 sigSession withMissing def sig = testSession (T.unpack def) $ do

1274 sigSession withMissing def sig = testSession (T.unpack def) $ do

1136 let originalCode = before withMissing def

1275 let originalCode = before withMissing def

1137 let expectedCode = after' withMissing def sig

1276 let expectedCode = after' withMissing def sig

1138− doc <- openDoc' "Sigs.hs" "haskell" originalCode

1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode

1139 [CodeLens {_command = Just c}] <- getCodeLenses doc

1278 [CodeLens {_command = Just c}] <- getCodeLenses doc

1140 executeCommand c

1279 executeCommand c

1141 modifiedCode <- getDocumentEdit doc

1280 modifiedCode <- getDocumentEdit doc

@@ -1157,24 +1296,19 @@ addSigLensesTests = let

1157 ]

1296 ]

1158 ]

1297 ]

1159

1298

1160−findDefinitionAndHoverTests :: TestTree

1161−findDefinitionAndHoverTests = let

1162−

1163− tst (get, check) pos targetRange title = testSession title $ do

1164− doc <- openTestDataDoc sourceFilePath

1165− found <- get doc pos

1166− check found targetRange

1167−

1168− checkDefs :: [Location] -> [Expect] -> Session ()

1299+checkDefs :: [Location] -> Session [Expect] -> Session ()

1169− checkDefs defs expectations = traverse_ check expectations where

1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where

1170

1301

1171− check (ExpectRange expectedRange) = do

1302+ check (ExpectRange expectedRange) = do

1172− assertNDefinitionsFound 1 defs

1303+ assertNDefinitionsFound 1 defs

1173− assertRangeCorrect (head defs) expectedRange

1304+ assertRangeCorrect (head defs) expectedRange

1305+ check (ExpectLocation expectedLocation) = do

1306+ assertNDefinitionsFound 1 defs

1307+ liftIO $ head defs @?= expectedLocation

1174− check ExpectNoDefinitions = do

1308+ check ExpectNoDefinitions = do

1175− assertNDefinitionsFound 0 defs

1309+ assertNDefinitionsFound 0 defs

1176− 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"

1177− check _ = pure () -- all other expectations not relevant to getDefinition

1311+ check _ = pure () -- all other expectations not relevant to getDefinition

1178

1312

1179 assertNDefinitionsFound :: Int -> [a] -> Session ()

1313 assertNDefinitionsFound :: Int -> [a] -> Session ()

1180 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)

1314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)

@@ -1182,8 +1316,19 @@ findDefinitionAndHoverTests = let

1182 assertRangeCorrect Location{_range = foundRange} expectedRange =

1316 assertRangeCorrect Location{_range = foundRange} expectedRange =

1183 liftIO $ expectedRange @=? foundRange

1317 liftIO $ expectedRange @=? foundRange

1184

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+

1185− checkHover :: Maybe Hover -> [Expect] -> Session ()

1330+ checkHover :: Maybe Hover -> Session [Expect] -> Session ()

1186− checkHover hover expectations = traverse_ check expectations where

1331+ checkHover hover expectations = traverse_ check =<< expectations where

1187

1332

1188 check expected =

1333 check expected =

1189 case hover of

1334 case hover of

@@ -1226,9 +1371,12 @@ findDefinitionAndHoverTests = let

1226

1371

1227 mkFindTests tests = testGroup "get"

1372 mkFindTests tests = testGroup "get"

1228 [ testGroup "definition" $ mapMaybe fst tests

1373 [ testGroup "definition" $ mapMaybe fst tests

1229− , 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)

1230

1378

1231− test runDef runHover look expect title =

1379+ testM runDef runHover look expect title =

1232 ( runDef $ tst def look expect title

1380 ( runDef $ tst def look expect title

1233 , runHover $ tst hover look expect title ) where

1381 , runHover $ tst hover look expect title ) where

1234 def = (getDefinitions, checkDefs)

1382 def = (getDefinitions, checkDefs)

@@ -1236,87 +1384,100 @@ findDefinitionAndHoverTests = let

1236 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out

1384 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out

1237

1385

1238 -- search locations expectations on results

1386 -- search locations expectations on results

1239− 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]

1240− fffL8 = Position 8 4 ;

1388+ fffL8 = Position 12 4 ;

1241− fffL14 = Position 14 7 ;

1389+ fffL14 = Position 18 7 ;

1242− aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]

1390+ aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]

1243− dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]

1391+ dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]

1244− dcL12 = Position 12 11 ;

1392+ dcL12 = Position 16 11 ;

1245− 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’"]]

1246− 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"]]

1247− vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]

1395+ vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6]

1248− opL16 = Position 16 15 ; op = [mkR 17 2 17 4]

1396+ opL16 = Position 20 15 ; op = [mkR 21 2 21 4]

1249− opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]

1397+ opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]

1250− aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]

1398+ aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]

1251− b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]

1399+ b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]

1252− 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"]]

1253− 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"]]

1254− clL25 = Position 25 9

1402+ clL25 = Position 29 9

1255− 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’"]]

1256− dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]

1404+ dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21]

1257− dnbL30 = Position 30 23

1405+ dnbL30 = Position 34 23

1258− 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]

1259− lclL33 = Position 33 22

1407+ lclL33 = Position 37 22

1260− mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14]

1408+ mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14]

1261− mclL37 = Position 37 1

1409+ mclL37 = Position 41 1

1262− spaceL37 = Position 37 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]

1410+ spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]

1263− docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]

1411+ docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]

1264 ; constr = [ExpectHoverText ["Monad m"]]

1412 ; constr = [ExpectHoverText ["Monad m"]]

1265− eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]

1413+ eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]

1266− intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]]

1414+ intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]]

1267− tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]

1415+ tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]

1268− intL41 = Position 41 20 ; litI = [ExpectHoverText ["7518"]]

1416+ intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]]

1269− chrL36 = Position 37 24 ; litC = [ExpectHoverText ["'f'"]]

1417+ chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]]

1270− txtL8 = Position 8 14 ; litT = [ExpectHoverText ["\"dfgy\""]]

1418+ txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]]

1271− lstL43 = Position 43 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]

1419+ lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]

1272− 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]

1273− 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]

1274 in

1424 in

1275 mkFindTests

1425 mkFindTests

1276− -- def hover look expect

1426+ -- def hover look expect

1277− [ test yes yes fffL4 fff "field in record definition"

1427+ [ test yes yes fffL4 fff "field in record definition"

1278− , test broken broken fffL8 fff "field in record construction #71"

1428+ , test broken broken fffL8 fff "field in record construction #71"

1279− , 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

1280− , test yes yes aaaL14 aaa "top-level name" -- 120

1430+ , test yes yes aaaL14 aaa "top-level name" -- 120

1281− , test yes yes dcL7 tcDC "data constructor record #247"

1431+ , test yes yes dcL7 tcDC "data constructor record #247"

1282− , test yes yes dcL12 tcDC "data constructor plain" -- 121

1432+ , test yes yes dcL12 tcDC "data constructor plain" -- 121

1283− , test yes yes tcL6 tcData "type constructor #248" -- 147

1433+ , test yes yes tcL6 tcData "type constructor #248" -- 147

1284− , test broken yes xtcL5 xtc "type constructor external #248,249"

1434+ , test broken yes xtcL5 xtc "type constructor external #248,249"

1285− , test broken yes xvL20 xvMsg "value external package #249" -- 120

1435+ , test broken yes xvL20 xvMsg "value external package #249" -- 120

1286− , test yes yes vvL16 vv "plain parameter" -- 120

1436+ , test yes yes vvL16 vv "plain parameter" -- 120

1287− , test yes yes aL18 apmp "pattern match name" -- 120

1437+ , test yes yes aL18 apmp "pattern match name" -- 120

1288− , test yes yes opL16 op "top-level operator" -- 120, 123

1438+ , test yes yes opL16 op "top-level operator" -- 120, 123

1289− , test yes yes opL18 opp "parameter operator" -- 120

1439+ , test yes yes opL18 opp "parameter operator" -- 120

1290− , test yes yes b'L19 bp "name in backticks" -- 120

1440+ , test yes yes b'L19 bp "name in backticks" -- 120

1291− , test yes yes clL23 cls "class in instance declaration #250"

1441+ , test yes yes clL23 cls "class in instance declaration #250"

1292− , test yes yes clL25 cls "class in signature #250" -- 147

1442+ , test yes yes clL25 cls "class in signature #250" -- 147

1293− , test broken yes eclL15 ecls "external class in signature #249,250"

1443+ , test broken yes eclL15 ecls "external class in signature #249,250"

1294− , test yes yes dnbL29 dnb "do-notation bind" -- 137

1444+ , test yes yes dnbL29 dnb "do-notation bind" -- 137

1295− , test yes yes dnbL30 dnb "do-notation lookup"

1445+ , test yes yes dnbL30 dnb "do-notation lookup"

1296− , test yes yes lcbL33 lcb "listcomp bind" -- 137

1446+ , test yes yes lcbL33 lcb "listcomp bind" -- 137

1297− , test yes yes lclL33 lcb "listcomp lookup"

1447+ , test yes yes lclL33 lcb "listcomp lookup"

1298− , test yes yes mclL36 mcl "top-level fn 1st clause"

1448+ , test yes yes mclL36 mcl "top-level fn 1st clause"

1299− , test yes yes mclL37 mcl "top-level fn 2nd clause #246"

1449+ , test yes yes mclL37 mcl "top-level fn 2nd clause #246"

1300− , test yes yes spaceL37 space "top-level fn on space #315"

1450+ , test yes yes spaceL37 space "top-level fn on space #315"

1301− , test no broken docL41 doc "documentation #7"

1451+ , test no broken docL41 doc "documentation #7"

1302− , test no yes eitL40 kindE "kind of Either #273"

1452+ , test no yes eitL40 kindE "kind of Either #273"

1303− , test no yes intL40 kindI "kind of Int #273"

1453+ , test no yes intL40 kindI "kind of Int #273"

1304− , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"

1454+ , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"

1305− , test no yes intL41 litI "literal Int in hover info #274"

1455+ , test no yes intL41 litI "literal Int in hover info #274"

1306− , test no yes chrL36 litC "literal Char in hover info #274"

1456+ , test no yes chrL36 litC "literal Char in hover info #274"

1307− , test no yes txtL8 litT "literal Text in hover info #274"

1457+ , test no yes txtL8 litT "literal Text in hover info #274"

1308− , test no yes lstL43 litL "literal List in hover info #274"

1458+ , test no yes lstL43 litL "literal List in hover info #274"

1309− , test no yes docL41 constr "type constraint in hover info #283"

1459+ , test no yes docL41 constr "type constraint in hover info #283"

1310− , test broken broken outL45 outSig "top-level signature #310"

1460+ , test broken broken outL45 outSig "top-level signature #310"

1311− , 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)"

1312 ]

1464 ]

1313 where yes, broken :: (TestTree -> Maybe TestTree)

1465 where yes, broken :: (TestTree -> Maybe TestTree)

1314 yes = Just -- test should run and pass

1466 yes = Just -- test should run and pass

1315 broken = Just . (`xfail` "known broken")

1467 broken = Just . (`xfail` "known broken")

1316 no = const Nothing -- don't run this test at all

1468 no = const Nothing -- don't run this test at all

1317

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+

1318pluginTests :: TestTree

1478pluginTests :: TestTree

1479+pluginTests = (`xfail8101` "known broken (#556)")

1319−pluginTests = testSessionWait "plugins" $ do

1480+ $ testSessionWait "plugins" $ do

1320 let content =

1481 let content =

1321 T.unlines

1482 T.unlines

1322 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"

1483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"

@@ -1330,7 +1491,7 @@ pluginTests = testSessionWait "plugins" $ do

1330 , "foo :: Int -> Int -> Int"

1491 , "foo :: Int -> Int -> Int"

1331 , "foo a b = a + c"

1492 , "foo a b = a + c"

1332 ]

1493 ]

1333− _ <- openDoc' "Testing.hs" "haskell" content

1494+ _ <- createDoc "Testing.hs" "haskell" content

1334 expectDiagnostics

1495 expectDiagnostics

1335 [ ( "Testing.hs",

1496 [ ( "Testing.hs",

1336 [(DsError, (8, 14), "Variable not in scope: c")]

1497 [(DsError, (8, 14), "Variable not in scope: c")]

@@ -1357,7 +1518,7 @@ cppTests =

1357 run $ expectError content (2, 1)

1518 run $ expectError content (2, 1)

1358 )

1519 )

1359 , testSessionWait "cpp-ghcide" $ do

1520 , testSessionWait "cpp-ghcide" $ do

1360− _ <- openDoc' "A.hs" "haskell" $ T.unlines

1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines

1361 ["{-# LANGUAGE CPP #-}"

1522 ["{-# LANGUAGE CPP #-}"

1362 ,"main ="

1523 ,"main ="

1363 ,"#ifdef __GHCIDE__"

1524 ,"#ifdef __GHCIDE__"

@@ -1371,7 +1532,7 @@ cppTests =

1371 where

1532 where

1372 expectError :: T.Text -> Cursor -> Session ()

1533 expectError :: T.Text -> Cursor -> Session ()

1373 expectError content cursor = do

1534 expectError content cursor = do

1374− _ <- openDoc' "Testing.hs" "haskell" content

1535+ _ <- createDoc "Testing.hs" "haskell" content

1375 expectDiagnostics

1536 expectDiagnostics

1376 [ ( "Testing.hs",

1537 [ ( "Testing.hs",

1377 [(DsError, cursor, "error: unterminated")]

1538 [(DsError, cursor, "error: unterminated")]

@@ -1387,13 +1548,43 @@ preprocessorTests = testSessionWait "preprocessor" $ do

1387 , "module Testing where"

1548 , "module Testing where"

1388 , "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

1389 ]

1550 ]

1390− _ <- openDoc' "Testing.hs" "haskell" content

1551+ _ <- createDoc "Testing.hs" "haskell" content

1391 expectDiagnostics

1552 expectDiagnostics

1392 [ ( "Testing.hs",

1553 [ ( "Testing.hs",

1393 [(DsError, (2, 8), "Variable not in scope: z")]

1554 [(DsError, (2, 8), "Variable not in scope: z")]

1394 )

1555 )

1395 ]

1556 ]

1396

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+

1397thTests :: TestTree

1588thTests :: TestTree

1398thTests =

1589thTests =

1399 testGroup

1590 testGroup

@@ -1419,8 +1610,8 @@ thTests =

1419 "b :: Integer",

1610 "b :: Integer",

1420 "b = $(litE $ IntegerL $ a) + n"

1611 "b = $(litE $ IntegerL $ a) + n"

1421 ]

1612 ]

1422− _ <- openDoc' "A.hs" "haskell" sourceA

1613+ _ <- createDoc "A.hs" "haskell" sourceA

1423− _ <- openDoc' "B.hs" "haskell" sourceB

1614+ _ <- createDoc "B.hs" "haskell" sourceB

1424 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]

1615 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]

1425 , testSessionWait "newtype-closure" $ do

1616 , testSessionWait "newtype-closure" $ do

1426 let sourceA =

1617 let sourceA =

@@ -1440,8 +1631,8 @@ thTests =

1440 ,"import A"

1631 ,"import A"

1441 ,"b :: Int"

1632 ,"b :: Int"

1442 ,"b = $( a )" ]

1633 ,"b = $( a )" ]

1443− _ <- openDoc' "A.hs" "haskell" sourceA

1634+ _ <- createDoc "A.hs" "haskell" sourceA

1444− _ <- openDoc' "B.hs" "haskell" sourceB

1635+ _ <- createDoc "B.hs" "haskell" sourceB

1445 return ()

1636 return ()

1446 ]

1637 ]

1447

1638

@@ -1450,7 +1641,7 @@ completionTests

1450 = testGroup "completion"

1641 = testGroup "completion"

1451 [ testSessionWait "variable" $ do

1642 [ testSessionWait "variable" $ do

1452 let source = T.unlines ["module A where", "f = hea"]

1643 let source = T.unlines ["module A where", "f = hea"]

1453− docId <- openDoc' "A.hs" "haskell" source

1644+ docId <- createDoc "A.hs" "haskell" source

1454 compls <- getCompletions docId (Position 1 7)

1645 compls <- getCompletions docId (Position 1 7)

1455 liftIO $ map dropDocs compls @?=

1646 liftIO $ map dropDocs compls @?=

1456 [complItem "head" (Just CiFunction) (Just "[a] -> a")]

1647 [complItem "head" (Just CiFunction) (Just "[a] -> a")]

@@ -1462,7 +1653,7 @@ completionTests

1462 ]

1653 ]

1463 , testSessionWait "constructor" $ do

1654 , testSessionWait "constructor" $ do

1464 let source = T.unlines ["module A where", "f = Tru"]

1655 let source = T.unlines ["module A where", "f = Tru"]

1465− docId <- openDoc' "A.hs" "haskell" source

1656+ docId <- createDoc "A.hs" "haskell" source

1466 compls <- getCompletions docId (Position 1 7)

1657 compls <- getCompletions docId (Position 1 7)

1467 liftIO $ map dropDocs compls @?=

1658 liftIO $ map dropDocs compls @?=

1468 [ complItem "True" (Just CiConstructor) (Just "Bool")

1659 [ complItem "True" (Just CiConstructor) (Just "Bool")

@@ -1474,7 +1665,7 @@ completionTests

1474 ]

1665 ]

1475 , testSessionWait "type" $ do

1666 , testSessionWait "type" $ do

1476 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 = ()"]

1477− docId <- openDoc' "A.hs" "haskell" source

1668+ docId <- createDoc "A.hs" "haskell" source

1478 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]

1669 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]

1479 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"]]

1480 compls <- getCompletions docId (Position 2 7)

1671 compls <- getCompletions docId (Position 2 7)

@@ -1491,7 +1682,7 @@ completionTests

1491 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]

1682 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]

1492 , testSessionWait "qualified" $ do

1683 , testSessionWait "qualified" $ do

1493 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 = ()"]

1494− docId <- openDoc' "A.hs" "haskell" source

1685+ docId <- createDoc "A.hs" "haskell" source

1495 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]

1686 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]

1496 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"]]

1497 compls <- getCompletions docId (Position 2 15)

1688 compls <- getCompletions docId (Position 2 15)

@@ -1505,9 +1696,30 @@ completionTests

1505 ]

1696 ]

1506 , testSessionWait "keyword" $ do

1697 , testSessionWait "keyword" $ do

1507 let source = T.unlines ["module A where", "f = newty"]

1698 let source = T.unlines ["module A where", "f = newty"]

1508− docId <- openDoc' "A.hs" "haskell" source

1699+ docId <- createDoc "A.hs" "haskell" source

1509 compls <- getCompletions docId (Position 1 9)

1700 compls <- getCompletions docId (Position 1 9)

1510 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 "*")]

1511 ]

1723 ]

1512 where

1724 where

1513 dropDocs :: CompletionItem -> CompletionItem

1725 dropDocs :: CompletionItem -> CompletionItem

@@ -1515,6 +1727,7 @@ completionTests

1515 complItem label kind ty = CompletionItem

1727 complItem label kind ty = CompletionItem

1516 { _label = label

1728 { _label = label

1517 , _kind = kind

1729 , _kind = kind

1730+ , _tags = List []

1518 , _detail = (":: " <>) <$> ty

1731 , _detail = (":: " <>) <$> ty

1519 , _documentation = Nothing

1732 , _documentation = Nothing

1520 , _deprecated = Nothing

1733 , _deprecated = Nothing

@@ -1532,6 +1745,7 @@ completionTests

1532 keywordItem label = CompletionItem

1745 keywordItem label = CompletionItem

1533 { _label = label

1746 { _label = label

1534 , _kind = Just CiKeyword

1747 , _kind = Just CiKeyword

1748+ , _tags = List []

1535 , _detail = Nothing

1749 , _detail = Nothing

1536 , _documentation = Nothing

1750 , _documentation = Nothing

1537 , _deprecated = Nothing

1751 , _deprecated = Nothing

@@ -1559,7 +1773,7 @@ outlineTests = testGroup

1559 "outline"

1773 "outline"

1560 [ testSessionWait "type class" $ do

1774 [ testSessionWait "type class" $ do

1561 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"]

1562− docId <- openDoc' "A.hs" "haskell" source

1776+ docId <- createDoc "A.hs" "haskell" source

1563 symbols <- getDocumentSymbols docId

1777 symbols <- getDocumentSymbols docId

1564 liftIO $ symbols @?= Left

1778 liftIO $ symbols @?= Left

1565 [ moduleSymbol

1779 [ moduleSymbol

@@ -1572,7 +1786,7 @@ outlineTests = testGroup

1572 ]

1786 ]

1573 , testSessionWait "type class instance " $ do

1787 , testSessionWait "type class instance " $ do

1574 let source = T.unlines ["class A a where", "instance A () where"]

1788 let source = T.unlines ["class A a where", "instance A () where"]

1575− docId <- openDoc' "A.hs" "haskell" source

1789+ docId <- createDoc "A.hs" "haskell" source

1576 symbols <- getDocumentSymbols docId

1790 symbols <- getDocumentSymbols docId

1577 liftIO $ symbols @?= Left

1791 liftIO $ symbols @?= Left

1578 [ classSymbol "A a" (R 0 0 0 15) []

1792 [ classSymbol "A a" (R 0 0 0 15) []

@@ -1580,7 +1794,7 @@ outlineTests = testGroup

1580 ]

1794 ]

1581 , testSessionWait "type family" $ do

1795 , testSessionWait "type family" $ do

1582 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]

1796 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]

1583− docId <- openDoc' "A.hs" "haskell" source

1797+ docId <- createDoc "A.hs" "haskell" source

1584 symbols <- getDocumentSymbols docId

1798 symbols <- getDocumentSymbols docId

1585 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)]

1586 , testSessionWait "type family instance " $ do

1800 , testSessionWait "type family instance " $ do

@@ -1589,7 +1803,7 @@ outlineTests = testGroup

1589 , "type family A a"

1803 , "type family A a"

1590 , "type instance A () = ()"

1804 , "type instance A () = ()"

1591 ]

1805 ]

1592− docId <- openDoc' "A.hs" "haskell" source

1806+ docId <- createDoc "A.hs" "haskell" source

1593 symbols <- getDocumentSymbols docId

1807 symbols <- getDocumentSymbols docId

1594 liftIO $ symbols @?= Left

1808 liftIO $ symbols @?= Left

1595 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)

1809 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)

@@ -1597,7 +1811,7 @@ outlineTests = testGroup

1597 ]

1811 ]

1598 , testSessionWait "data family" $ do

1812 , testSessionWait "data family" $ do

1599 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]

1813 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]

1600− docId <- openDoc' "A.hs" "haskell" source

1814+ docId <- createDoc "A.hs" "haskell" source

1601 symbols <- getDocumentSymbols docId

1815 symbols <- getDocumentSymbols docId

1602 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)]

1603 , testSessionWait "data family instance " $ do

1817 , testSessionWait "data family instance " $ do

@@ -1606,7 +1820,7 @@ outlineTests = testGroup

1606 , "data family A a"

1820 , "data family A a"

1607 , "data instance A () = A ()"

1821 , "data instance A () = A ()"

1608 ]

1822 ]

1609− docId <- openDoc' "A.hs" "haskell" source

1823+ docId <- createDoc "A.hs" "haskell" source

1610 symbols <- getDocumentSymbols docId

1824 symbols <- getDocumentSymbols docId

1611 liftIO $ symbols @?= Left

1825 liftIO $ symbols @?= Left

1612 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)

1826 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)

@@ -1614,36 +1828,36 @@ outlineTests = testGroup

1614 ]

1828 ]

1615 , testSessionWait "constant" $ do

1829 , testSessionWait "constant" $ do

1616 let source = T.unlines ["a = ()"]

1830 let source = T.unlines ["a = ()"]

1617− docId <- openDoc' "A.hs" "haskell" source

1831+ docId <- createDoc "A.hs" "haskell" source

1618 symbols <- getDocumentSymbols docId

1832 symbols <- getDocumentSymbols docId

1619 liftIO $ symbols @?= Left

1833 liftIO $ symbols @?= Left

1620 [docSymbol "a" SkFunction (R 0 0 0 6)]

1834 [docSymbol "a" SkFunction (R 0 0 0 6)]

1621 , testSessionWait "pattern" $ do

1835 , testSessionWait "pattern" $ do

1622 let source = T.unlines ["Just foo = Just 21"]

1836 let source = T.unlines ["Just foo = Just 21"]

1623− docId <- openDoc' "A.hs" "haskell" source

1837+ docId <- createDoc "A.hs" "haskell" source

1624 symbols <- getDocumentSymbols docId

1838 symbols <- getDocumentSymbols docId

1625 liftIO $ symbols @?= Left

1839 liftIO $ symbols @?= Left

1626 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]

1840 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]

1627 , testSessionWait "pattern with type signature" $ do

1841 , testSessionWait "pattern with type signature" $ do

1628 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]

1842 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]

1629− docId <- openDoc' "A.hs" "haskell" source

1843+ docId <- createDoc "A.hs" "haskell" source

1630 symbols <- getDocumentSymbols docId

1844 symbols <- getDocumentSymbols docId

1631 liftIO $ symbols @?= Left

1845 liftIO $ symbols @?= Left

1632 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]

1846 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]

1633 , testSessionWait "function" $ do

1847 , testSessionWait "function" $ do

1634 let source = T.unlines ["a x = ()"]

1848 let source = T.unlines ["a x = ()"]

1635− docId <- openDoc' "A.hs" "haskell" source

1849+ docId <- createDoc "A.hs" "haskell" source

1636 symbols <- getDocumentSymbols docId

1850 symbols <- getDocumentSymbols docId

1637 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]

1851 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]

1638 , testSessionWait "type synonym" $ do

1852 , testSessionWait "type synonym" $ do

1639 let source = T.unlines ["type A = Bool"]

1853 let source = T.unlines ["type A = Bool"]

1640− docId <- openDoc' "A.hs" "haskell" source

1854+ docId <- createDoc "A.hs" "haskell" source

1641 symbols <- getDocumentSymbols docId

1855 symbols <- getDocumentSymbols docId

1642 liftIO $ symbols @?= Left

1856 liftIO $ symbols @?= Left

1643 [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)]

1644 , testSessionWait "datatype" $ do

1858 , testSessionWait "datatype" $ do

1645 let source = T.unlines ["data A = C"]

1859 let source = T.unlines ["data A = C"]

1646− docId <- openDoc' "A.hs" "haskell" source

1860+ docId <- createDoc "A.hs" "haskell" source

1647 symbols <- getDocumentSymbols docId

1861 symbols <- getDocumentSymbols docId

1648 liftIO $ symbols @?= Left

1862 liftIO $ symbols @?= Left

1649 [ docSymbolWithChildren "A"

1863 [ docSymbolWithChildren "A"

@@ -1651,18 +1865,47 @@ outlineTests = testGroup

1651 (R 0 0 0 10)

1865 (R 0 0 0 10)

1652 [docSymbol "C" SkConstructor (R 0 9 0 10)]

1866 [docSymbol "C" SkConstructor (R 0 9 0 10)]

1653 ]

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+ ]

1654 , testSessionWait "import" $ do

1880 , testSessionWait "import" $ do

1655 let source = T.unlines ["import Data.Maybe"]

1881 let source = T.unlines ["import Data.Maybe"]

1882+ docId <- createDoc "A.hs" "haskell" source

1883+ symbols <- getDocumentSymbols docId

1884+ liftIO $ symbols @?= Left

1885+ [docSymbolWithChildren "imports"

1886+ SkModule

1887+ (R 0 0 0 17)

1888+ [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)

1889+ ]

1890+ ]

1891+ , testSessionWait "multiple import" $ do

1892+ let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]

1656− docId <- openDoc' "A.hs" "haskell" source

1893+ docId <- createDoc "A.hs" "haskell" source

1657 symbols <- getDocumentSymbols docId

1894 symbols <- getDocumentSymbols docId

1658 liftIO $ symbols @?= Left

1895 liftIO $ symbols @?= Left

1896+ [docSymbolWithChildren "imports"

1897+ SkModule

1898+ (R 1 0 3 24)

1659− [docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)]

1899+ [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 17)

1900+ , docSymbol "import Control.Exception" SkModule (R 3 0 3 24)

1901+ ]

1902+ ]

1660 , testSessionWait "foreign import" $ do

1903 , testSessionWait "foreign import" $ do

1661 let source = T.unlines

1904 let source = T.unlines

1662 [ "{-# language ForeignFunctionInterface #-}"

1905 [ "{-# language ForeignFunctionInterface #-}"

1663 , "foreign import ccall \"a\" a :: Int"

1906 , "foreign import ccall \"a\" a :: Int"

1664 ]

1907 ]

1665− docId <- openDoc' "A.hs" "haskell" source

1908+ docId <- createDoc "A.hs" "haskell" source

1666 symbols <- getDocumentSymbols docId

1909 symbols <- getDocumentSymbols docId

1667 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)]

1668 , testSessionWait "foreign export" $ do

1911 , testSessionWait "foreign export" $ do

@@ -1670,7 +1913,7 @@ outlineTests = testGroup

1670 [ "{-# language ForeignFunctionInterface #-}"

1913 [ "{-# language ForeignFunctionInterface #-}"

1671 , "foreign export ccall odd :: Int -> Bool"

1914 , "foreign export ccall odd :: Int -> Bool"

1672 ]

1915 ]

1673− docId <- openDoc' "A.hs" "haskell" source

1916+ docId <- createDoc "A.hs" "haskell" source

1674 symbols <- getDocumentSymbols docId

1917 symbols <- getDocumentSymbols docId

1675 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)]

1676 ]

1919 ]

@@ -1683,6 +1926,8 @@ outlineTests = testGroup

1683 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing

1926 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing

1684 docSymbolWithChildren name kind loc cc =

1927 docSymbolWithChildren name kind loc cc =

1685 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)

1686 moduleSymbol name loc cc = DocumentSymbol name

1931 moduleSymbol name loc cc = DocumentSymbol name

1687 Nothing

1932 Nothing

1688 SkFile

1933 SkFile

@@ -1704,8 +1949,16 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')

1704xfail :: TestTree -> String -> TestTree

1949xfail :: TestTree -> String -> TestTree

1705xfail = flip expectFailBecause

1950xfail = flip expectFailBecause

1706

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+

1707data Expect

1959data Expect

1708 = ExpectRange Range -- Both gotoDef and hover should report this range

1960 = ExpectRange Range -- Both gotoDef and hover should report this range

1961+ | ExpectLocation Location

1709-- | ExpectDefRange Range -- Only gotoDef should report this range

1962-- | ExpectDefRange Range -- Only gotoDef should report this range

1710 | ExpectHoverRange Range -- Only hover should report this range

1963 | ExpectHoverRange Range -- Only hover should report this range

1711 | ExpectHoverText [T.Text] -- the hover message must contain these snippets

1964 | ExpectHoverText [T.Text] -- the hover message must contain these snippets

@@ -1718,6 +1971,9 @@ data Expect

1718mkR :: Int -> Int -> Int -> Int -> Expect

1971mkR :: Int -> Int -> Int -> Int -> Expect

1719mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn

1972mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn

1720

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+

1721haddockTests :: TestTree

1977haddockTests :: TestTree

1722haddockTests

1978haddockTests

1723 = testGroup "haddock"

1979 = testGroup "haddock"

@@ -1773,6 +2029,129 @@ haddockTests

1773 where

2029 where

1774 checkHaddock s txt = spanDocToMarkdownForTest s @?= txt

2030 checkHaddock s txt = spanDocToMarkdownForTest s @?= txt

1775

2031

2032+cradleTests :: TestTree

2033+cradleTests = testGroup "cradle"

2034+ [testGroup "dependencies" [sessionDepsArePickedUp]

2035+ ,testGroup "loading" [loadCradleOnlyonce]

2036+ ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]

2037+ ]

2038+

2039+loadCradleOnlyonce :: TestTree

2040+loadCradleOnlyonce = testGroup "load cradle only once"

2041+ [ testSession' "implicit" implicit

2042+ , testSession' "direct" direct

2043+ ]

2044+ where

2045+ direct dir = do

2046+ liftIO $ writeFileUTF8 (dir </> "hie.yaml")

2047+ "cradle: {direct: {arguments: []}}"

2048+ test dir

2049+ implicit dir = test dir

2050+ test _dir = do

2051+ doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"

2052+ msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

2053+ liftIO $ length msgs @?= 1

2054+ changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]

2055+ msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

2056+ liftIO $ length msgs @?= 0

2057+ _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"

2058+ msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

2059+ liftIO $ length msgs @?= 0

2060+

2061+

2062+dependentFileTest :: TestTree

2063+dependentFileTest = testGroup "addDependentFile"

2064+ [testGroup "file-changed" [testSession' "test" test]

2065+ ]

2066+ where

2067+ test dir = do

2068+ -- If the file contains B then no type error

2069+ -- otherwise type error

2070+ liftIO $ writeFile (dir </> "dep-file.txt") "A"

2071+ let fooContent = T.unlines

2072+ [ "{-# LANGUAGE TemplateHaskell #-}"

2073+ , "module Foo where"

2074+ , "import Language.Haskell.TH.Syntax"

2075+ , "foo :: Int"

2076+ , "foo = 1 + $(do"

2077+ , " qAddDependentFile \"dep-file.txt\""

2078+ , " f <- qRunIO (readFile \"dep-file.txt\")"

2079+ , " if f == \"B\" then [| 1 |] else lift f)"

2080+ ]

2081+ let bazContent = T.unlines ["module Baz where", "import Foo"]

2082+ _ <-createDoc "Foo.hs" "haskell" fooContent

2083+ doc <- createDoc "Baz.hs" "haskell" bazContent

2084+ expectDiagnostics

2085+ [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]

2086+ -- Now modify the dependent file

2087+ liftIO $ writeFile (dir </> "dep-file.txt") "B"

2088+ let change = TextDocumentContentChangeEvent

2089+ { _range = Just (Range (Position 2 0) (Position 2 6))

2090+ , _rangeLength = Nothing

2091+ , _text = "f = ()"

2092+ }

2093+ -- Modifying Baz will now trigger Foo to be rebuilt as well

2094+ changeDoc doc [change]

2095+ expectDiagnostics [("Foo.hs", [])]

2096+

2097+

2098+cradleLoadedMessage :: Session FromServerMessage

2099+cradleLoadedMessage = satisfy $ \case

2100+ NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod

2101+ _ -> False

2102+

2103+cradleLoadedMethod :: T.Text

2104+cradleLoadedMethod = "ghcide/cradle/loaded"

2105+

2106+-- Stack sets this which trips up cabal in the multi-component tests.

2107+-- However, our plugin tests rely on those env vars so we unset it locally.

2108+withoutStackEnv :: IO a -> IO a

2109+withoutStackEnv s =

2110+ bracket

2111+ (mapM getEnv vars >>= \prevState -> mapM_ unsetEnv vars >> pure prevState)

2112+ (\prevState -> mapM_ (\(var, value) -> restore var value) (zip vars prevState))

2113+ (const s)

2114+ where vars =

2115+ [ "GHC_PACKAGE_PATH"

2116+ , "GHC_ENVIRONMENT"

2117+ , "HASKELL_DIST_DIR"

2118+ , "HASKELL_PACKAGE_SANDBOX"

2119+ , "HASKELL_PACKAGE_SANDBOXES"

2120+ ]

2121+ restore var Nothing = unsetEnv var

2122+ restore var (Just val) = setEnv var val True

2123+

2124+simpleMultiTest :: TestTree

2125+simpleMultiTest = testCase "simple-multi-test" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do

2126+ let aPath = dir </> "a/A.hs"

2127+ bPath = dir </> "b/B.hs"

2128+ aSource <- liftIO $ readFileUtf8 aPath

2129+ (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource

2130+ expectNoMoreDiagnostics 0.5

2131+ bSource <- liftIO $ readFileUtf8 bPath

2132+ bdoc <- createDoc bPath "haskell" bSource

2133+ expectNoMoreDiagnostics 0.5

2134+ locs <- getDefinitions bdoc (Position 2 7)

2135+ let fooL = mkL adoc 2 0 2 3

2136+ checkDefs locs (pure [fooL])

2137+ expectNoMoreDiagnostics 0.5

2138+

2139+-- Like simpleMultiTest but open the files in the other order

2140+simpleMultiTest2 :: TestTree

2141+simpleMultiTest2 = testCase "simple-multi-test2" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do

2142+ let aPath = dir </> "a/A.hs"

2143+ bPath = dir </> "b/B.hs"

2144+ bSource <- liftIO $ readFileUtf8 bPath

2145+ bdoc <- createDoc bPath "haskell" bSource

2146+ expectNoMoreDiagnostics 5

2147+ aSource <- liftIO $ readFileUtf8 aPath

2148+ (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource

2149+ -- Need to have some delay here or the test fails

2150+ expectNoMoreDiagnostics 5

2151+ locs <- getDefinitions bdoc (Position 2 7)

2152+ let fooL = mkL adoc 2 0 2 3

2153+ checkDefs locs (pure [fooL])

2154+ expectNoMoreDiagnostics 0.5

1776

2155

1777sessionDepsArePickedUp :: TestTree

2156sessionDepsArePickedUp :: TestTree

1778sessionDepsArePickedUp = testSession'

2157sessionDepsArePickedUp = testSession'

@@ -1783,7 +2162,7 @@ sessionDepsArePickedUp = testSession'

1783 (dir </> "hie.yaml")

2162 (dir </> "hie.yaml")

1784 "cradle: {direct: {arguments: []}}"

2163 "cradle: {direct: {arguments: []}}"

1785 -- Open without OverloadedStrings and expect an error.

2164 -- Open without OverloadedStrings and expect an error.

1786− doc <- openDoc' "Foo.hs" "haskell" fooContent

2165+ doc <- createDoc "Foo.hs" "haskell" fooContent

1787 expectDiagnostics

2166 expectDiagnostics

1788 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]

2167 [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]

1789 -- Update hie.yaml to enable OverloadedStrings.

2168 -- Update hie.yaml to enable OverloadedStrings.

@@ -1818,6 +2197,9 @@ sessionDepsArePickedUp = testSession'

1818testSession :: String -> Session () -> TestTree

2197testSession :: String -> Session () -> TestTree

1819testSession name = testCase name . run

2198testSession name = testCase name . run

1820

2199

2200+testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree

2201+testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix

2202+

1821testSession' :: String -> (FilePath -> Session ()) -> TestTree

2203testSession' :: String -> (FilePath -> Session ()) -> TestTree

1822testSession' name = testCase name . run'

2204testSession' name = testCase name . run'

1823

2205

@@ -1831,11 +2213,20 @@ testSessionWait name = testSession name .

1831 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.

2213 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.

1832 ( >> expectNoMoreDiagnostics 0.5)

2214 ( >> expectNoMoreDiagnostics 0.5)

1833

2215

1834−pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction

2216+pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction

1835−pickActionWithTitle title actions = head

2217+pickActionWithTitle title actions = do

2218+ assertBool ("Found no matching actions: " <> show titles) (not $ null matches)

2219+ return $ head matches

2220+ where

2221+ titles =

2222+ [ actionTitle

2223+ | CACodeAction CodeAction { _title = actionTitle } <- actions

2224+ ]

2225+ matches =

1836− [ action

2226+ [ action

1837− | CACodeAction action@CodeAction{ _title = actionTitle } <- actions

2227+ | CACodeAction action@CodeAction { _title = actionTitle } <- actions

1838− , title == actionTitle ]

2228+ , title == actionTitle

2229+ ]

1839

2230

1840mkRange :: Int -> Int -> Int -> Int -> Range

2231mkRange :: Int -> Int -> Int -> Int -> Range

1841mkRange a b c d = Range (Position a b) (Position c d)

2232mkRange a b c d = Range (Position a b) (Position c d)

@@ -1843,6 +2234,19 @@ mkRange a b c d = Range (Position a b) (Position c d)

1843run :: Session a -> IO a

2234run :: Session a -> IO a

1844run s = withTempDir $ \dir -> runInDir dir s

2235run s = withTempDir $ \dir -> runInDir dir s

1845

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+

1846run' :: (FilePath -> Session a) -> IO a

2250run' :: (FilePath -> Session a) -> IO a

1847run' s = withTempDir $ \dir -> runInDir dir (s dir)

2251run' s = withTempDir $ \dir -> runInDir dir (s dir)

1848

2252

@@ -1854,7 +2258,8 @@ runInDir dir s = do

1854 -- 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

1855 createDirectoryIfMissing True $ dir ++ "/Data"

2259 createDirectoryIfMissing True $ dir ++ "/Data"

1856

2260

2261+

1857− let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]

2262+ let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]

1858 -- HIE calls getXgdDirectory which assumes that HOME is set.

2263 -- HIE calls getXgdDirectory which assumes that HOME is set.

1859 -- Only sets HOME if it wasn't already set.

2264 -- Only sets HOME if it wasn't already set.

1860 setEnv "HOME" "/homeless-shelter" False

2265 setEnv "HOME" "/homeless-shelter" False

@@ -1871,7 +2276,7 @@ runInDir dir s = do

1871openTestDataDoc :: FilePath -> Session TextDocumentIdentifier

2276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier

1872openTestDataDoc path = do

2277openTestDataDoc path = do

1873 source <- liftIO $ readFileUtf8 $ "test/data" </> path

2278 source <- liftIO $ readFileUtf8 $ "test/data" </> path

1874− openDoc' path "haskell" source

2279+ createDoc path "haskell" source

1875

2280

1876findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]

2281findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]

1877findCodeActions doc range expectedTitles = do

2282findCodeActions doc range expectedTitles = do

@@ -1886,7 +2291,7 @@ findCodeActions doc range expectedTitles = do

1886 [ actionTitle

2291 [ actionTitle

1887 | CACodeAction CodeAction { _title = actionTitle } <- actions

2292 | CACodeAction CodeAction { _title = actionTitle } <- actions

1888 ]

2293 ]

1889− ++ "is not a superset of "

2294+ ++ " is not a superset of "

1890 ++ show expectedTitles

2295 ++ show expectedTitles

1891 liftIO $ case matches of

2296 liftIO $ case matches of

1892 Nothing -> assertFailure msg

2297 Nothing -> assertFailure msg

@@ -1899,24 +2304,19 @@ findCodeAction doc range t = head <$> findCodeActions doc range [t]

1899unitTests :: TestTree

2304unitTests :: TestTree

1900unitTests = do

2305unitTests = do

1901 testGroup "Unit"

2306 testGroup "Unit"

1902− [ testCase "empty file path" $

2307+ [ testCase "empty file path does NOT work with the empty String literal" $

1903− 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 ""

1904 ]

2318 ]

1905

2319

1906−-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events

1907−openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier

1908−openDoc' fp name contents = do

1909− res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents

1910− -- Needed as ghcide sets up and relies on WatchedFiles but lsp-test does not track them

1911− sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])

1912− return res

1913−

1914−-- | Version of 'LSPTest.openDoc'' that does not send WatchedFiles events for files outside the workspace

1915−openDoc'' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier

1916−-- At the moment this is just LSPTest.openDoc' but it may change in the future

1917−-- when/if lsp-test implements WatchedFiles

1918−openDoc'' = LSPTest.openDoc'

1919−

1920positionMappingTests :: TestTree

2320positionMappingTests :: TestTree

1921positionMappingTests =

2321positionMappingTests =

1922 testGroup "position mapping"

2322 testGroup "position mapping"

@@ -2085,3 +2485,12 @@ nthLine i r

2085 | i == 0 && Rope.rows r == 0 = r

2485 | i == 0 && Rope.rows r == 0 = r

2086 | 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)

2087 | 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

2488+

2489+getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]

2490+getWatchedFilesSubscriptionsUntil = do

2491+ msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)

2492+ return

2493+ [ args

2494+ | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs

2495+ , Registration _id WorkspaceDidChangeWatchedFiles args <- regs

2496+ ]

test/src/Development/IDE/Test.hs+8−2

@@ -1,10 +1,13 @@

2-- SPDX-License-Identifier: Apache-2.0

4+{-# LANGUAGE DuplicateRecordFields #-}

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

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 '‘' = '\''