master..b78efe3 · ghcide

git.iko.soy/ghcide

on b78efe3 help sign in

.azure/linux-stack.ymldeleted−63

since splitsnapshots

unifiedsplit

@@ -1,63 +0,0 @@

1−jobs:

2−- job: ghcide_stack_linux

3− timeoutInMinutes: 60

4− pool:

5− vmImage: 'ubuntu-latest'

6− strategy:

7− matrix:

8− stack_810:

9− STACK_YAML: "stack810.yaml"

10− stack_88:

11− STACK_YAML: "stack88.yaml"

12− stack_86:

13− STACK_YAML: "stack.yaml"

14− stack_84:

15− STACK_YAML: "stack84.yaml"

16− stack_ghc_lib_88:

17− STACK_YAML: "stack-ghc-lib.yaml"

18− steps:

19− - checkout: self

20− - task: Cache@2

21− inputs:

22− key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/$(STACK_YAML) | $(Build.SourcesDirectory)/ghcide.cabal

23− path: .azure-cache

24− cacheHitVar: CACHE_RESTORED

25− displayName: "Cache stack artifacts"

26− - bash: |

27− mkdir -p ~/.stack

28− tar xzf .azure-cache/stack-root.tar.gz -C $HOME

29− displayName: "Unpack cache"

30− condition: eq(variables.CACHE_RESTORED, 'true')

31− - bash: |

32− ./fmt.sh

33− displayName: "HLint via ./fmt.sh"

34− - bash: |

35− sudo add-apt-repository ppa:hvr/ghc

36− sudo apt-get update

37− sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev cabal-install-3.2

38− if ! which stack >/dev/null 2>&1; then

39− curl -sSL https://get.haskellstack.org/ | sh

40− fi

41− displayName: 'Install Stack'

42− - bash: stack setup --stack-yaml=$STACK_YAML

43− displayName: 'stack setup'

44− - bash: stack build --only-dependencies --stack-yaml=$STACK_YAML

45− displayName: 'stack build --only-dependencies'

46− - bash: |

47− export PATH=/opt/cabal/bin:$PATH

48− stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML || stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML|| stack test --ghc-options=-Werror --stack-yaml=$STACK_YAML

49− # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.

50− displayName: 'stack test --ghc-options=-Werror'

51− - bash: |

52− mkdir -p .azure-cache

53− tar czf .azure-cache/stack-root.tar.gz -C $HOME .stack

54− displayName: "Pack cache"

55− - bash: |

56− set -euo pipefail

57− MESSAGE=$(git log --pretty=format:%s -n1)

58− curl -XPOST \

59− -i \

60− -H 'Content-type: application/json' \

61− --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \

62− $(Slack.URL)

63− condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))

.azure/windows-stack.ymldeleted−68

@@ -1,68 +0,0 @@

1−jobs:

2−- job: ghcide_stack_windows

3− timeoutInMinutes: 60

4− pool:

5− vmImage: 'windows-2019'

6− strategy:

7− matrix:

8− stack_810:

9− STACK_YAML: "stack810.yaml"

10− stack_88:

11− STACK_YAML: "stack88.yaml"

12− stack_86:

13− STACK_YAML: "stack.yaml"

14− stack_84:

15− STACK_YAML: "stack84.yaml"

16− stack_ghc_lib_88:

17− STACK_YAML: "stack-ghc-lib.yaml"

18− variables:

19− STACK_ROOT: "C:\\sr"

20− steps:

21− - checkout: self

22− - task: Cache@2

23− inputs:

24− key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/$(STACK_YAML) | $(Build.SourcesDirectory)/ghcide.cabal

25− path: .azure-cache

26− cacheHitVar: CACHE_RESTORED

27− displayName: "Cache stack artifacts"

28− - bash: |

29− mkdir -p $STACK_ROOT

30− tar -vxzf .azure-cache/stack-root.tar.gz -C /c

31− mkdir -p .stack-work

32− tar -vxzf .azure-cache/stack-work.tar.gz

33− displayName: "Unpack cache"

34− condition: eq(variables.CACHE_RESTORED, 'true')

35− - bash: |

36− ./fmt.sh

37− displayName: "HLint via ./fmt.sh"

38− - bash: |

39− curl -sSkL http://www.stackage.org/stack/windows-x86_64 -o /usr/bin/stack.zip

40− unzip -o /usr/bin/stack.zip -d /usr/bin/

41− mkdir -p "$STACK_ROOT"

42− displayName: 'Install Stack'

43− - bash: stack setup --stack-yaml $STACK_YAML

44− displayName: 'stack setup'

45− - bash: |

46− # Installing happy and alex standalone to avoid error "strip.exe: unable to rename ../*.exe; reason: File exists"

47− stack install happy --stack-yaml $STACK_YAML

48− stack install alex --stack-yaml $STACK_YAML

49− stack install cabal-install --stack-yaml $STACK_YAML

50− stack build --only-dependencies --stack-yaml $STACK_YAML

51− displayName: 'stack build --only-dependencies'

52− - bash: stack test --no-run-tests --ghc-options=-Werror --stack-yaml $STACK_YAML

53− displayName: 'stack test --ghc-options=-Werror'

54− # TODO: run test suite when failing tests are fixed or marked as broken. See https://github.com/digital-asset/ghcide/issues/474

55− - bash: |

56− mkdir -p .azure-cache

57− tar -vczf .azure-cache/stack-root.tar.gz $(cygpath $STACK_ROOT)

58− tar -vczf .azure-cache/stack-work.tar.gz .stack-work

59− displayName: "Pack cache"

60− - bash: |

61− set -euo pipefail

62− MESSAGE=$(git log --pretty=format:%s -n1)

63− curl -XPOST \

64− -i \

65− -H 'Content-type: application/json' \

66− --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \

67− $(Slack.URL)

68− condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))

.editorconfigdeleted−11

@@ -1,11 +0,0 @@

1−; This file is for unifying the coding style for different editors and IDEs.

2−; More information at https://EditorConfig.org

3−

4−root = true

5−

6−[*]

7−end_of_line = LF

8−indent_style = space

9−indent_size = 4

10−trim_trailing_whitespace = true

11−insert_final_newline = true

.ghcinew file+24

@@ -0,0 +1,24 @@

1+:set -Wunused-binds -Wunused-imports -Worphans -Wunused-matches -Wincomplete-patterns

3+:set -XBangPatterns

4+:set -XDeriveFunctor

5+:set -XDeriveGeneric

6+:set -XGeneralizedNewtypeDeriving

7+:set -XLambdaCase

8+:set -XNamedFieldPuns

9+:set -XOverloadedStrings

10+:set -XRecordWildCards

11+:set -XScopedTypeVariables

12+:set -XStandaloneDeriving

13+:set -XTupleSections

14+:set -XTypeApplications

15+:set -XViewPatterns

16+

17+:set -package=ghc

18+:set -hide-package=ghc-lib-parser

19+:set -DGHC_STABLE

20+:set -Iinclude

21+:set -isrc

22+:set -iexe

23+

24+:load Main

.gitignore−4

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

4cabal.project.local

5*~

6*.lock

7−/.tasty-rerun-log

8−.vscode

9−/.hlint-*

10−bench/example

.hlint.yaml+2−12

@@ -73,23 +73,16 @@

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

75 # Shady extensions

76+ - {name: ImplicitParams, within: []}

76 - name: CPP

77 - name: CPP

77 within:

78 within:

78− - Development.IDE.Compat

79 - Development.IDE.Core.FileStore

80 - Development.IDE.Core.Compile

81− - Development.IDE.Core.Rules

82 - Development.IDE.GHC.Compat

81 - Development.IDE.GHC.Compat

83− - Development.IDE.GHC.Orphans

84 - Development.IDE.GHC.Util

82 - Development.IDE.GHC.Util

85 - Development.IDE.Import.FindImports

83 - Development.IDE.Import.FindImports

86− - Development.IDE.LSP.Outline

84+ - Development.IDE.LSP.CodeAction

87 - Development.IDE.Spans.Calculate

85 - Development.IDE.Spans.Calculate

88− - Development.IDE.Spans.Documentation

89− - Development.IDE.Spans.Common

90− - Development.IDE.Plugin.CodeAction

91− - Development.IDE.Plugin.Completions

92− - Development.IDE.Plugin.Completions.Logic

93 - Main

86 - Main

95- flags:

88- flags:

@@ -101,12 +94,9 @@

101# - {name: Control.Arrow, within: []} # Certain modules are banned entirely

94# - {name: Control.Arrow, within: []} # Certain modules are banned entirely

102#

95#

103- functions:

96- functions:

104− # Things that are unsafe in Haskell base library

105 - {name: unsafeInterleaveIO, within: []}

97 - {name: unsafeInterleaveIO, within: []}

106 - {name: unsafeDupablePerformIO, within: []}

98 - {name: unsafeDupablePerformIO, within: []}

107 - {name: unsafeCoerce, within: []}

99 - {name: unsafeCoerce, within: []}

108− # Things that are a bit dangerous in the GHC API

109− - {name: nameModule, within: []}

110

100

111# Add custom hints for this project

101# Add custom hints for this project

112#

102#

CHANGELOG.md−57

@@ -1,62 +1,5 @@

1### unreleased

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

4−

5−* Multi-component support (thanks @mpickering)

6−* Support for GHC 8.10 (thanks @sheaf and @chshersh)

7−* Fix some TH issues (thanks @mpickering)

8−* Automatically pick up changes to cradle dependencies (e.g. cabal

9− files) (thanks @jinwoo)

10−* Track dependencies when using `qAddDependentFile` (thanks @mpickering)

11−* Add record fields to document symbols outline (thanks @bubba)

12−* Fix some space leaks (thanks @mpickering)

13−* Strip redundant path information from diagnostics (thanks @tek)

14−* Fix import suggestions for operators (thanks @eddiemundo)

15−* Significant reductions in memory usage by using interfaces and `.hie` files (thanks

16− @pepeiborra)

17−* Minor improvements to completions

18−* More comprehensive suggestions for missing imports (thanks @pepeiborra)

19−* Group imports in document outline (thanks @fendor)

20−* Upgrade to haskell-lsp-0.22 (thanks @bubba)

21−* Upgrade to hie-bios 0.5 (thanks @fendor)

22−

23−### 0.1.0 (2020-02-04)

24−

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

26−* Better default GC settings (see #329 and #333).

27−* Various performance improvements (see #322 and #384).

28−* Improvements to hover information (see #317 and #338).

29−* Support GHC 8.8.2 (see #355).

30−* Include keywords in completions (see #351).

31−* Fix some issues with aborted requests (see #353).

32−* Use hie-bios 0.4.0 (see #382).

33−* Avoid stuck progress reporting (see #400).

34−* Only show progress notifications after 0.1s (see #392).

35−* Progress reporting is now in terms of the number of files rather

36− than the number of shake rules (see #379).

37−

38−### 0.0.6 (2020-01-10)

39−

40−* Fix type in hover information for do-notation and list

41− comprehensions (see #243).

42−* Fix hover and goto-definition for multi-clause definitions (see #252).

43−* Upgrade to `hie-bios-0.3` (see #257)

44−* Upgrade to `haskell-lsp-0.19` (see #254)

45−* Code lenses for missing signatures are displayed even if the warning

46− has not been enabled. The warning itself will not be shown if it is

47− not enabled. (see #232)

48−* Define `__GHCIDE__` when running CPP to allow for `ghcide`-specific

49− workarounds. (see #264)

50−* Fix some filepath normalization issues. (see #266)

51−* Fix build with `shake-0.18.4` (see #272)

52−* Fix hover for type constructors and type classes. (see #267)

53−* Support custom preprocessors (see #282)

54−* Add support for code completions (see #227)

55−* Code action for removing redundant symbols from imports (see #290)

56−* Support document symbol requests (see #293)

57−* Show CPP errors as diagnostics (see #296)

58−* Code action for adding suggested imports (see #295)

59−

60### 0.0.5 (2019-12-12)

3### 0.0.5 (2019-12-12)

62* Support for GHC plugins (see #192)

5* Support for GHC plugins (see #192)

README.md+6−63

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

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

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−

45## Using it

28## Using it

47### Install `ghcide`

30### Install `ghcide`

49#### With Nix

32#### 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−

60−2. If your `ghc` does not match nixpkgs you should try the [ghcide-nix repository](https://github.com/cachix/ghcide-nix)

34+[See ghcide-nix repository](https://github.com/hercules-ci/ghcide-nix)

61− which provides a `ghcide` via the `haskell.nix` infrastructure.

63#### With Cabal or Stack

36#### With Cabal or Stack

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

92If you can't get `ghcide` working outside the editor, see [this setup troubleshooting guide](docs/Setup.md). Once you have got `ghcide` working outside the editor, the next step is to pick which editor to integrate with.

65If you can't get `ghcide` working outside the editor, see [this setup troubleshooting guide](docs/Setup.md). Once you have got `ghcide` working outside the editor, the next step is to pick which editor to integrate with.

94−### Optimal project setup

95−

96−`ghcide` has been designed to handle projects with hundreds or thousands of modules. If `ghci` can handle it, then `ghcide` should be able to handle it. The only caveat is that this currently requires GHC >= 8.6, and that the first time a module is loaded in the editor will trigger generation of support files in the background if those do not already exist.

97−

98### Using with VS Code

67### Using with VS Code

100You can install the VSCode extension from the [VSCode

69You can install the VSCode extension from the [VSCode

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

234```

203```

235

204

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

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

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

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

238−

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

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

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

242

207

243### SpaceVim

208### SpaceVim

244

209

@@ -259,8 +224,10 @@ Add this to your coc-settings.json (which you can edit with :CocConfig):

259{

224{

260 "languageserver": {

225 "languageserver": {

261 "haskell": {

226 "haskell": {

262− "command": "ghcide",

227+ "command": "stack",

263 "args": [

228 "args": [

229+ "exec",

230+ "ghcide",

264 "--lsp"

231 "--lsp"

265 ],

232 ],

266 "rootPatterns": [

233 "rootPatterns": [

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

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

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

284using `stack install ghcide` within a project.

251using `stack install ghcide` within a project.

285

252

286−### Using with Kakoune

287−

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

289−

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

291−

292−```toml

293−[language.haskell]

294−filetypes = ["haskell"]

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

296−command = "ghcide"

297−args = ["--lsp"]

298−```

299−

300## Hacking on ghcide

253## Hacking on ghcide

301

254

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

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

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

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

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

305−

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

307−

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

309−

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

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

312

257

313### Building the extension

258### Building the extension

314

259

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

325

270

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

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

327

272

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

329−

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

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

331

274

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.

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

333

276

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

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

azure-pipelines.yml+184−3

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

4 branches:

5 include:

6 - master

7− - azure*

9# Enable PR triggers that target the master branch

8# Enable PR triggers that target the master branch

10pr:

9pr:

@@ -14,5 +13,187 @@ pr:

14 - master

13 - master

16jobs:

15jobs:

17− - template: ./.azure/linux-stack.yml

16+ - job: ghcide_stack_86

18− - template: ./.azure/windows-stack.yml

17+ timeoutInMinutes: 60

18+ pool:

19+ vmImage: 'ubuntu-latest'

20+ steps:

21+ - checkout: self

22+ - task: CacheBeta@0

23+ inputs:

24+ key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/stack.yaml | $(Build.SourcesDirectory)/ghcide.cabal

25+ path: .azure-cache

26+ cacheHitVar: CACHE_RESTORED

27+ displayName: "Cache stack artifacts"

28+ - bash: |

29+ mkdir -p ~/.stack

30+ tar xzf .azure-cache/stack-root.tar.gz -C $HOME

31+ displayName: "Unpack cache"

32+ condition: eq(variables.CACHE_RESTORED, 'true')

33+ - bash: |

34+ ./fmt.sh

35+ displayName: "HLint via ./fmt.sh"

36+ - bash: |

37+ sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev

38+ if ! which stack >/dev/null 2>&1; then

39+ curl -sSL https://get.haskellstack.org/ | sh

40+ fi

41+ displayName: 'Install Stack'

42+ - bash: stack setup

43+ displayName: 'stack setup'

44+ - bash: stack build --only-dependencies

45+ displayName: 'stack build --only-dependencies'

46+ - bash: stack test --ghc-options=-Werror || stack test --ghc-options=-Werror || stack test --ghc-options=-Werror

47+ # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.

48+ displayName: 'stack test --ghc-options=-Werror'

49+ - bash: |

50+ mkdir -p .azure-cache

51+ tar czf .azure-cache/stack-root.tar.gz -C $HOME .stack

52+ displayName: "Pack cache"

53+ - bash: |

54+ set -euo pipefail

55+ MESSAGE=$(git log --pretty=format:%s -n1)

56+ curl -XPOST \

57+ -i \

58+ -H 'Content-type: application/json' \

59+ --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \

60+ $(Slack.URL)

61+ condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))

62+ - job: ghcide_stack_84

63+ timeoutInMinutes: 60

64+ pool:

65+ vmImage: 'ubuntu-latest'

66+ steps:

67+ - checkout: self

68+ - task: CacheBeta@0

69+ inputs:

70+ key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/stack84.yaml | $(Build.SourcesDirectory)/ghcide.cabal

71+ path: .azure-cache

72+ cacheHitVar: CACHE_RESTORED

73+ displayName: "Cache stack artifacts"

74+ - bash: |

75+ mkdir -p ~/.stack

76+ tar xzf .azure-cache/stack-root.tar.gz -C $HOME

77+ displayName: "Unpack cache"

78+ condition: eq(variables.CACHE_RESTORED, 'true')

79+ - bash: |

80+ ./fmt.sh

81+ displayName: "HLint via ./fmt.sh"

82+ - bash: |

83+ sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev

84+ if ! which stack >/dev/null 2>&1; then

85+ curl -sSL https://get.haskellstack.org/ | sh

86+ fi

87+ displayName: 'Install Stack'

88+ - bash: stack setup --stack-yaml=stack84.yaml

89+ displayName: 'stack setup --stack-yaml=stack84.yaml'

90+ - bash: stack build --only-dependencies --stack-yaml=stack84.yaml

91+ displayName: 'stack build --only-dependencies --stack-yaml=stack84.yaml'

92+ - bash: stack test --stack-yaml=stack84.yaml --ghc-options=-Werror || stack test --stack-yaml=stack84.yaml --ghc-options=-Werror || stack test --stack-yaml=stack84.yaml --ghc-options=-Werror

93+ # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.

94+ displayName: 'stack test --stack-yaml=stack84.yaml --ghc-options=-Werror'

95+ - bash: |

96+ mkdir -p .azure-cache

97+ tar czf .azure-cache/stack-root.tar.gz -C $HOME .stack

98+ displayName: "Pack cache"

99+ - bash: |

100+ set -euo pipefail

101+ MESSAGE=$(git log --pretty=format:%s -n1)

102+ curl -XPOST \

103+ -i \

104+ -H 'Content-type: application/json' \

105+ --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \

106+ $(Slack.URL)

107+ condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))

108+ - job: ghcide_stack_88

109+ timeoutInMinutes: 60

110+ pool:

111+ vmImage: 'ubuntu-latest'

112+ steps:

113+ - checkout: self

114+ - task: CacheBeta@0

115+ inputs:

116+ key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/stack88.yaml | $(Build.SourcesDirectory)/ghcide.cabal

117+ path: .azure-cache

118+ cacheHitVar: CACHE_RESTORED

119+ displayName: "Cache stack artifacts"

120+ - bash: |

121+ mkdir -p ~/.stack

122+ tar xzf .azure-cache/stack-root.tar.gz -C $HOME

123+ displayName: "Unpack cache"

124+ condition: eq(variables.CACHE_RESTORED, 'true')

125+ - bash: |

126+ ./fmt.sh

127+ displayName: "HLint via ./fmt.sh"

128+ - bash: |

129+ sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev

130+ if ! which stack >/dev/null 2>&1; then

131+ curl -sSL https://get.haskellstack.org/ | sh

132+ fi

133+ displayName: 'Install Stack'

134+ - bash: stack setup --stack-yaml=stack88.yaml

135+ displayName: 'stack setup --stack-yaml=stack88.yaml'

136+ - bash: stack build --only-dependencies --stack-yaml=stack88.yaml

137+ displayName: 'stack build --only-dependencies --stack-yaml=stack88.yaml'

138+ - bash: stack test --stack-yaml=stack88.yaml --ghc-options=-Werror || stack test --stack-yaml=stack88.yaml --ghc-options=-Werror || stack test --stack-yaml=stack88.yaml --ghc-options=-Werror

139+ # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.

140+ displayName: 'stack test --stack-yaml=stack88.yaml --ghc-options=-Werror'

141+ - bash: |

142+ mkdir -p .azure-cache

143+ tar czf .azure-cache/stack-root.tar.gz -C $HOME .stack

144+ displayName: "Pack cache"

145+ - bash: |

146+ set -euo pipefail

147+ MESSAGE=$(git log --pretty=format:%s -n1)

148+ curl -XPOST \

149+ -i \

150+ -H 'Content-type: application/json' \

151+ --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \

152+ $(Slack.URL)

153+ condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))

154+ - job: ghcide_stack_ghc_lib_88

155+ timeoutInMinutes: 60

156+ pool:

157+ vmImage: 'ubuntu-latest'

158+ steps:

159+ - checkout: self

160+ - task: CacheBeta@0

161+ inputs:

162+ key: stack-cache-v2 | $(Agent.OS) | $(Build.SourcesDirectory)/stack-ghc-lib.yaml | $(Build.SourcesDirectory)/ghcide.cabal

163+ path: .azure-cache

164+ cacheHitVar: CACHE_RESTORED

165+ displayName: "Cache stack artifacts"

166+ - bash: |

167+ mkdir -p ~/.stack

168+ tar xzf .azure-cache/stack-root.tar.gz -C $HOME

169+ displayName: "Unpack cache"

170+ condition: eq(variables.CACHE_RESTORED, 'true')

171+ - bash: |

172+ ./fmt.sh

173+ displayName: "HLint via ./fmt.sh"

174+ - bash: |

175+ sudo apt-get install -y g++ gcc libc6-dev libffi-dev libgmp-dev make zlib1g-dev

176+ if ! which stack >/dev/null 2>&1; then

177+ curl -sSL https://get.haskellstack.org/ | sh

178+ fi

179+ displayName: 'Install Stack'

180+ - bash: stack setup --stack-yaml=stack-ghc-lib.yaml

181+ displayName: 'stack setup --stack-yaml=stack-ghc-lib.yaml'

182+ - bash: stack build --only-dependencies --stack-yaml=stack-ghc-lib.yaml

183+ displayName: 'stack build --only-dependencies --stack-yaml=stack-ghc-lib.yaml'

184+ - bash: stack test --stack-yaml=stack-ghc-lib.yaml --ghc-options=-Werror || stack test --stack-yaml=stack-ghc-lib.yaml --ghc-options=-Werror || stack test --stack-yaml=stack-ghc-lib.yaml --ghc-options=-Werror

185+ # ghcide stack tests are flaky, see https://github.com/digital-asset/daml/issues/2606.

186+ displayName: 'stack test --stack-yaml=stack-ghc-lib.yaml --ghc-options=-Werror'

187+ - bash: |

188+ mkdir -p .azure-cache

189+ tar czf .azure-cache/stack-root.tar.gz -C $HOME .stack

190+ displayName: "Pack cache"

191+ - bash: |

192+ set -euo pipefail

193+ MESSAGE=$(git log --pretty=format:%s -n1)

194+ curl -XPOST \

195+ -i \

196+ -H 'Content-type: application/json' \

197+ --data "{\"text\":\"<!here> *FAILED* $(Agent.JobName): <https://dev.azure.com/digitalasset/ghcide/_build/results?buildId=$(Build.BuildId)|$MESSAGE>\n\"}" \

198+ $(Slack.URL)

199+ condition: and(failed(), eq(variables['Build.SourceBranchName'], 'master'))

bench/Main.hsdeleted−287

@@ -1,287 +0,0 @@

1−{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE ExistentialQuantification #-}

3−{-# LANGUAGE ImplicitParams #-}

4−

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

6−

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

8−

9− As an example project, it unpacks Cabal-3.2.0.0 in the local filesystem and

10− loads the module 'Distribution.Simple'. The rationale for this choice is:

11−

12− - It's convenient to download with `cabal unpack Cabal-3.2.0.0`

13− - It has very few dependencies, and all are already needed to build ghcide

14− - Distribution.Simple has 235 transitive module dependencies, so non trivial

15−

16− The experiments are sequences of lsp commands scripted using lsp-test.

17− A more refined approach would be to record and replay real IDE interactions,

18− once the replay functionality is available in lsp-test.

19− A more declarative approach would be to reuse ide-debug-driver:

20−

21− > https://github.com/digital-asset/daml/blob/master/compiler/damlc/ide-debug-driver/README.md

22−

23− The result of an experiment is a total duration in seconds after a preset

24− number of iterations. There is ample room for improvement:

25− - Statistical analysis to detect outliers and auto infer the number of iterations needed

26− - GC stats analysis (currently -S is printed as part of the experiment)

27− - Analyisis of performance over the commit history of the project

28−

29− How to run:

30− 1. `cabal bench`

31− 2. `cabal exec <absolute-path-to-ghcide-bench> -- ghcide-bench-options`

32−

33− Note that the package database influences the response times of certain actions,

34− e.g. code actions, and therefore the two methods above do not necessarily

35− produce the same results.

36−

37− -}

38−

39−import Control.Applicative.Combinators

40−import Control.Concurrent

41−import Control.Exception.Safe

42−import Control.Monad.Extra

43−import Control.Monad.IO.Class

44−import Data.Aeson

45−import Data.List

46−import Data.Maybe

47−import Data.Version

48−import Language.Haskell.LSP.Test

49−import Language.Haskell.LSP.Types

50−import Language.Haskell.LSP.Types.Capabilities

51−import Numeric.Natural

52−import Options.Applicative

53−import System.Directory

54−import System.FilePath ((</>))

55−import System.Process

56−import System.Time.Extra

57−

58−-- Points to a string in the target file,

59−-- convenient for hygienic edits

60−hygienicP :: Position

61−hygienicP = Position 854 23

62−

63−-- Points to the middle of an identifier,

64−-- convenient for requesting goto-def, hover and completions

65−identifierP :: Position

66−identifierP = Position 853 12

67−

68−main :: IO ()

69−main = do

70− config <- execParser $ info configP fullDesc

71− let ?config = config

72−

73− output "starting test"

74−

75− cleanUp <- setup

76−

77− runBenchmarks

78− [ ---------------------------------------------------------------------------------------

79− bench "hover" 10 $ \doc ->

80− isJust <$> getHover doc identifierP,

81− ---------------------------------------------------------------------------------------

82− bench "getDefinition" 10 $ \doc ->

83− not . null <$> getDefinitions doc identifierP,

84− ---------------------------------------------------------------------------------------

85− bench "documentSymbols" 100 $

86− fmap (either (not . null) (not . null)) . getDocumentSymbols,

87− ---------------------------------------------------------------------------------------

88− bench "documentSymbols after edit" 100 $ \doc -> do

89− let change =

90− TextDocumentContentChangeEvent

91− { _range = Just (Range hygienicP hygienicP),

92− _rangeLength = Nothing,

93− _text = " "

94− }

95− changeDoc doc [change]

96− either (not . null) (not . null) <$> getDocumentSymbols doc,

97− ---------------------------------------------------------------------------------------

98− bench "completions after edit" 10 $ \doc -> do

99− let change =

100− TextDocumentContentChangeEvent

101− { _range = Just (Range hygienicP hygienicP),

102− _rangeLength = Nothing,

103− _text = " "

104− }

105− changeDoc doc [change]

106− not . null <$> getCompletions doc identifierP,

107− ---------------------------------------------------------------------------------------

108− benchWithSetup

109− "code actions"

110− 10

111− ( \doc -> do

112− let p = identifierP

113− let change =

114− TextDocumentContentChangeEvent

115− { _range = Just (Range p p),

116− _rangeLength = Nothing,

117− _text = "a"

118− }

119− changeDoc doc [change]

120− void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)

121− return p

122− )

123− ( \p doc -> do

124− not . null <$> getCodeActions doc (Range p p)

125− ),

126− ---------------------------------------------------------------------------------------

127− bench "code actions after edit" 10 $ \doc -> do

128− let p = identifierP

129− let change =

130− TextDocumentContentChangeEvent

131− { _range = Just (Range p p),

132− _rangeLength = Nothing,

133− _text = "a"

134− }

135− changeDoc doc [change]

136− void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)

137− not . null <$> getCodeActions doc (Range p p)

138− ]

139− `finally` cleanUp

140−

141−---------------------------------------------------------------------------------------------

142−

143−examplePackageName :: String

144−examplePackageName = "Cabal"

145−

146−examplePackageVersion :: Version

147−examplePackageVersion = makeVersion [3, 2, 0, 0]

148−

149−examplePackage :: String

150−examplePackage = examplePackageName <> "-" <> showVersion examplePackageVersion

151−

152−exampleModulePath :: FilePath

153−exampleModulePath = "Distribution" </> "Simple.hs"

154−

155−examplesPath :: FilePath

156−examplesPath = "bench/example"

157−

158−data Config = Config

159− { verbose :: !Bool,

160− -- For some reason, the Shake profile files are truncated and won't load

161− shakeProfiling :: !(Maybe FilePath),

162− outputCSV :: !Bool

163− }

164−

165−type HasConfig = (?config :: Config)

166−

167−configP :: Parser Config

168−configP = Config

169− <$> (not <$> switch (long "quiet"))

170− <*> optional (strOption (long "shake-profiling" <> metavar "PATH"))

171− <*> switch (long "csv")

172−

173−output :: (MonadIO m, HasConfig) => String -> m ()

174−output = if verbose ?config then liftIO . putStrLn else (\_ -> pure ())

175−

176−---------------------------------------------------------------------------------------

177−

178−type Experiment = TextDocumentIdentifier -> Session Bool

179−

180−data Bench = forall setup.

181− Bench

182− { name :: !String,

183− samples :: !Natural,

184− benchSetup :: TextDocumentIdentifier -> Session setup,

185− experiment :: setup -> Experiment

186− }

187−

188−bench :: String -> Natural -> Experiment -> Bench

189−bench name samples userExperiment = Bench {..}

190− where

191− experiment () = userExperiment

192− benchSetup _ = return ()

193−

194−benchWithSetup ::

195− String ->

196− Natural ->

197− (TextDocumentIdentifier -> Session p) ->

198− (p -> Experiment) ->

199− Bench

200−benchWithSetup = Bench

201−

202−runBenchmarks :: HasConfig => [Bench] -> IO ()

203−runBenchmarks benchmarks = do

204− results <- forM benchmarks $ \b -> (b,) <$> runBench b

205−

206− forM_ results $ \(Bench {name, samples}, duration) ->

207− output $

208− "TOTAL "

209− <> name

210− <> " = "

211− <> showDuration duration

212− <> " ("

213− <> show samples

214− <> " repetitions)"

215−

216− when (outputCSV ?config) $ do

217− putStrLn $ intercalate ", " $ map name benchmarks

218− putStrLn $ intercalate ", " $ map (showDuration . snd) results

219−

220−runBench :: HasConfig => Bench -> IO Seconds

221−runBench Bench {..} = handleAny (\e -> print e >> return (-1))

222− $ runSessionWithConfig conf cmd lspTestCaps dir

223− $ do

224− doc <- openDoc exampleModulePath "haskell"

225− void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)

226−

227− liftIO $ output $ "Running " <> name <> " benchmark"

228− userState <- benchSetup doc

229− let loop 0 = return True

230− loop n = do

231− (t, res) <- duration $ experiment userState doc

232− if not res

233− then return False

234− else do

235− output (showDuration t)

236− loop (n -1)

237−

238− (t, res) <- duration $ loop samples

239−

240− exitServer

241− -- sleeep to give ghcide a chance to print the RTS stats

242− liftIO $ threadDelay 50000

243−

244− return $ if res then t else -1

245− where

246− cmd =

247− unwords $

248− [ "ghcide",

249− "--lsp",

250− "--cwd",

251− dir,

252− "+RTS",

253− "-S",

254− "-RTS"

255− ]

256− ++ concat

257− [ ["--shake-profiling", path]

258− | Just path <- [shakeProfiling ?config]

259− ]

260− dir = "bench/example/" <> examplePackage

261− lspTestCaps =

262− fullCaps {_window = Just $ WindowClientCapabilities $ Just True}

263− conf =

264− defaultConfig

265− { logStdErr = verbose ?config,

266− logMessages = False,

267− logColor = False

268− }

269−

270−setup :: HasConfig => IO (IO ())

271−setup = do

272− alreadyExists <- doesDirectoryExist examplesPath

273− when alreadyExists $ removeDirectoryRecursive examplesPath

274− callCommand $ "cabal get -v0 " <> examplePackage <> " -d " <> examplesPath

275− writeFile

276− (examplesPath </> examplePackage </> "hie.yaml")

277− ("cradle: {cabal: {component: " <> show examplePackageName <> "}}")

278−

279− whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True

280−

281− return $ removeDirectoryRecursive examplesPath

282−

283−-- | Asks the server to shutdown and exit politely

284−exitServer :: Session ()

285−exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams

286−

287−--------------------------------------------------------------------------------------------

docs/Setup.md+1−38

@@ -54,21 +54,8 @@ with the following content:

54cradle: {cabal: {component: "mylibrary"}}

55```

57−If you are using stack, find the list of names you can use:

58−

59− $ stack ide targets

60− mypackage:lib

61− mypackage:exe:mypackage-exe

62− mypackage:test:mypackage-test

63−

64−and create a `hie.yaml` file as follows:

65−

66− {stack: {component: "mypackage:lib"}}

67−

68## ghc: readCreateProcess: does not exist

57## ghc: readCreateProcess: does not exist

70−On Linux: try `stack exec ghcide`` instead of `ghcide` directly.

71−

72I was getting this in Windows: `ghcide.exe: ghc: readCreateProcess: does not exist (No such file or directory)`

59I was getting this in Windows: `ghcide.exe: ghc: readCreateProcess: does not exist (No such file or directory)`

74And we figured a hack around for this:

61And we figured a hack around for this:

@@ -82,21 +69,7 @@ Since I use stack. Required if you don't have a `ghc` on your path.

83## Could not find module ...

70## Could not find module ...

85−Try adding an explicit `hie.yaml` file and see if that helps.

72+Try adding an explicit hie.yaml file and see if that helps.

86−

87−## Ambiguous main module

88−

89−```console

90−$ stack exec ghcide

91−

92−...

93−

94−ghcide: CradleError (ExitFailure 1) ["Failed to parse result of calling stack","","* * * * * * * *","The main module to load is ambiguous. Candidates are: ","1. Package `mypackage' component mypackage:exe:mypackage-exe with main-is file: /home/user/mypackage/app/Main.hs","2. Package `mypackage' component mypackage:exe:otherbin-exe with main-is file: /home/user/mypackage/app/otherbin.hs","You can specify which one to pick by: "," * Specifying targets to stack ghci e.g. stack ghci mypackage:exe:mypackage-exe"," * Specifying what the main is e.g. stack ghci --main-is mypackage:exe:mypackage-exe"," * Choosing from the candidate above [1..2]","* * * * * * * *","","<stdin>: hGetLine: end of file"]

95−```

96−

97−Add a `hie.yaml` file to specify the module, e.g.

98−

99− cradle: {stack: {component: "mypackage:exe:mypackage-exe"}}

100

101## Works in `ghcide` but not my editor

74## Works in `ghcide` but not my editor

102

@@ -133,13 +106,3 @@ find ~/.emacs.d -name '*.elc' -exec rm {} \;

133## Docker stack builds

106## Docker stack builds

134

107

135You're likely to see `ghcide: (ExitFailure 1,"","")`. Because ghcide can't get at the ghc installed inside Docker, your best bet is to `stack exec ghcide` and make sure `ghcide` is installed within the container. Full details at [issue 221](https://github.com/digital-asset/ghcide/issues/221).

108You're likely to see `ghcide: (ExitFailure 1,"","")`. Because ghcide can't get at the ghc installed inside Docker, your best bet is to `stack exec ghcide` and make sure `ghcide` is installed within the container. Full details at [issue 221](https://github.com/digital-asset/ghcide/issues/221).

136−

137−## stty error on Windows + Stack

138−

139−If you get an error like:

140−

141−```

142−ghcide.exe: CradleError (ExitFailure 1) ["Failed to parse result of calling stack","'stty' is not recognized as an internal or external command,","operable program or batch file."

143−```

144−

145−Then the workaround from https://github.com/haskell/haskell-ide-engine/issues/1428#issuecomment-547530794 might help.

exe/Arguments.hs−6

@@ -11,9 +11,6 @@ data Arguments = Arguments

11 ,argsCwd :: Maybe FilePath

12 ,argFiles :: [FilePath]

13 ,argsVersion :: Bool

14− ,argsShakeProfiling :: Maybe FilePath

15− ,argsTesting :: Bool

16− ,argsThreads :: Int

17 }

14 }

19getArguments :: IO Arguments

16getArguments :: IO Arguments

@@ -30,6 +27,3 @@ arguments = Arguments

30 <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")

27 <*> optional (strOption $ long "cwd" <> metavar "DIR" <> help "Change to this directory")

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

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

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

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

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

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

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

exe/Main.hs+80−549

@@ -3,31 +3,19 @@

3{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above

4{-# LANGUAGE CPP #-} -- To get precise GHC version

5{-# LANGUAGE TemplateHaskell #-}

6−{-# LANGUAGE TypeFamilies #-}

8module Main(main) where

7module Main(main) where

10−import Linker (initDynLinker)

11−import Data.IORef

12−import NameCache

13−import Packages

14−import Module

15import Arguments

9import Arguments

16−import Control.Concurrent.Async

10+import Data.Maybe

11+import Data.List.Extra

12+import System.FilePath

17import Control.Concurrent.Extra

13import Control.Concurrent.Extra

18import Control.Exception

14import Control.Exception

19import Control.Monad.Extra

15import Control.Monad.Extra

20import Control.Monad.IO.Class

16import Control.Monad.IO.Class

21import Data.Default

17import Data.Default

22−import Data.Either

18+import System.Time.Extra

23−import Data.Function

24−import Data.List.Extra

25−import Data.Maybe

26−import qualified Data.Text as T

27−import qualified Data.Text.IO as T

28−import Data.Time.Clock (UTCTime)

29−import Data.Version

30−import Development.IDE.Core.Debouncer

31import Development.IDE.Core.FileStore

19import Development.IDE.Core.FileStore

32import Development.IDE.Core.OfInterest

20import Development.IDE.Core.OfInterest

33import Development.IDE.Core.Service

21import Development.IDE.Core.Service

@@ -40,42 +28,31 @@ import Development.IDE.Types.Diagnostics

40import Development.IDE.Types.Options

28import Development.IDE.Types.Options

41import Development.IDE.Types.Logger

29import Development.IDE.Types.Logger

42import Development.IDE.GHC.Util

30import Development.IDE.GHC.Util

43−import Development.IDE.Plugin

31+import qualified Data.Text as T

44−import Development.IDE.Plugin.Completions as Completions

45−import Development.IDE.Plugin.CodeAction as CodeAction

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

32+import qualified Data.Text.IO as T

47import Language.Haskell.LSP.Messages

33import Language.Haskell.LSP.Messages

48−import Language.Haskell.LSP.Types

34+import Language.Haskell.LSP.Types (LspId(IdInt))

35+import Linker

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

36+import Data.Version

50import Development.IDE.LSP.LanguageServer

37import Development.IDE.LSP.LanguageServer

51−import qualified System.Directory.Extra as IO

38+import System.Directory.Extra as IO

52import System.Environment

39import System.Environment

53import System.IO

40import System.IO

54import System.Exit

41import System.Exit

55−import System.FilePath

56−import System.Directory

57−import System.Time.Extra

58−import HIE.Bios.Environment (addCmdOpts, makeDynFlagsAbsolute)

59import Paths_ghcide

42import Paths_ghcide

60import Development.GitRev

43import Development.GitRev

61import Development.Shake (Action, action)

44import Development.Shake (Action, action)

62−import qualified Data.HashSet as HashSet

45+import qualified Data.Set as Set

63−import qualified Data.HashMap.Strict as HM

64import qualified Data.Map.Strict as Map

46import qualified Data.Map.Strict as Map

65−import qualified Crypto.Hash.SHA1 as H

47+

66−import qualified Data.ByteString.Char8 as B

67−import Data.ByteString.Base16 (encode)

68−import DynFlags (gopt_set, gopt_unset, updOptLevel, PackageFlag(..), PackageArg(..))

69−import GhcMonad

70−import HscTypes (HscEnv(..), ic_dflags)

71import GHC hiding (def)

48import GHC hiding (def)

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

49+import qualified GHC.Paths

73−import Data.Either.Extra

75−import HIE.Bios.Cradle

51+import HIE.Bios

76−import HIE.Bios.Types

78−import Utils

53+-- Set the GHC libdir to the nix libdir if it's present.

54+getLibdir :: IO FilePath

55+getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"

80ghcideVersion :: IO String

57ghcideVersion :: IO String

81ghcideVersion = do

58ghcideVersion = do

@@ -102,68 +79,64 @@ main = do

102 let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $

79 let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $

103 T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg

80 T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg

104

105− whenJust argsCwd IO.setCurrentDirectory

82+ whenJust argsCwd setCurrentDirectory

106

107− dir <- IO.getCurrentDirectory

84+ dir <- getCurrentDirectory

108− command <- makeLspCommandId "typesignature.add"

109−

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

111− onInitialConfiguration = const $ Right ()

112− onConfigurationChange = const $ Right ()

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

114− , LSP.completionTriggerCharacters = Just "."

115− }

116

117 if argLSP then do

86 if argLSP then do

118 t <- offsetTime

87 t <- offsetTime

119 hPutStrLn stderr "Starting LSP server..."

88 hPutStrLn stderr "Starting LSP server..."

120− hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"

89+ hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcidie WITHOUT the --lsp option!"

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

90+ runLanguageServer def def $ \getLspId event vfs caps -> do

122 t <- t

91 t <- t

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

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

93+ -- very important we only call loadSession once, and it's fast, so just do it before starting

94+ session <- loadSession dir

124− let options = (defaultIdeOptions $ loadSessionShake dir)

95+ let options = (defaultIdeOptions $ return session)

125− { optReportProgress = clientSupportsProgress caps

96+ { optReportProgress = clientSupportsProgress caps }

126− , optShakeProfiling = argsShakeProfiling

127− , optTesting = argsTesting

128− , optThreads = argsThreads

129− }

130− debouncer <- newAsyncDebouncer

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

132− getLspId event (logger minBound) debouncer options vfs

97+ initialise (mainRule >> action kick) getLspId event (logger minBound) options vfs

133 else do

98 else do

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

135− hSetEncoding stdout utf8

136− hSetEncoding stderr utf8

137−

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

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

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

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

140

101

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

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

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

103+ files <- nubOrd <$> expandFiles (argFiles ++ ["." | null argFiles])

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

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

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

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

146

105

147− putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup"

106+ putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup"

148 cradles <- mapM findCradle files

107 cradles <- mapM findCradle files

149 let ucradles = nubOrd cradles

108 let ucradles = nubOrd cradles

150 let n = length ucradles

109 let n = length ucradles

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

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

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

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

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

114+ cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x

115+ when (isNothing x) $ print cradle

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

117+ cradleToSession cradle

118+

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

119+ putStrLn "\nStep 5/6: Initializing the IDE"

153 vfs <- makeVFSHandle

120 vfs <- makeVFSHandle

154− debouncer <- newAsyncDebouncer

121+ let cradlesToSessions = Map.fromList $ zip ucradles sessions

122+ let filesToCradles = Map.fromList $ zip files cradles

123+ let grab file = fromMaybe (head sessions) $ do

124+ cradle <- Map.lookup file filesToCradles

125+ Map.lookup cradle cradlesToSessions

155− ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs

126+ ide <- initialise mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) (defaultIdeOptions $ return $ return . grab) vfs

156−

127+

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

128+ putStrLn "\nStep 6/6: Type checking the files"

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

129+ setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files

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

130+ results <- runActionSync ide $ uses TypeCheck $ map toNormalizedFilePath files

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

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

161 when (failed /= []) $

132 when (failed /= []) $

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

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

163

134

164 let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"

135 let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"

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

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

166− return ()

137+

138+ unless (null failed) exitFailure

139+

167

140

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

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

169expandFiles = concatMapM $ \x -> do

142expandFiles = concatMapM $ \x -> do

@@ -172,7 +145,7 @@ expandFiles = concatMapM $ \x -> do

172 let recurse "." = True

145 let recurse "." = True

173 recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc

146 recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc

174 recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories

147 recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories

175− files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x

148+ files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> listFilesInside (return . recurse) x

176 when (null files) $

149 when (null files) $

177 fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x

150 fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x

178 return files

151 return files

@@ -181,414 +154,48 @@ expandFiles = concatMapM $ \x -> do

181kick :: Action ()

154kick :: Action ()

182kick = do

155kick = do

183 files <- getFilesOfInterest

156 files <- getFilesOfInterest

184− void $ uses TypeCheck $ HashSet.toList files

157+ void $ uses TypeCheck $ Set.toList files

185

158

186-- | Print an LSP event.

159-- | Print an LSP event.

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

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

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

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

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

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

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

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

191showEvent lock e = withLock lock $ print e

164showEvent lock e = withLock lock $ print e

192

165

193

166

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

167+cradleToSession :: Cradle -> IO HscEnvEq

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

168+cradleToSession cradle = do

196−cradleToSessionOpts cradle file = do

169+ cradleRes <- getCompilerOptions "" cradle

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

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

199− case cradleRes of

170+ opts <- case cradleRes of

200− CradleSuccess r -> pure (Right r)

171+ CradleSuccess r -> pure r

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

172+ CradleFail err -> throwIO err

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

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

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

174+ -- That will require some more changes.

204− CradleNone -> return (Left [])

175+ CradleNone -> fail "'none' cradle is not yet supported"

205−

206−emptyHscEnv :: IO HscEnv

207−emptyHscEnv = do

208 libdir <- getLibdir

176 libdir <- getLibdir

209− env <- runGhc (Just libdir) getSession

177+ env <- runGhc (Just libdir) $ do

178+ _targets <- initSession opts

179+ getSession

210 initDynLinker env

180 initDynLinker env

211− pure env

181+ newHscEnvEq env

212−

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

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

215−-- directories

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

217−-- to canonicalise it.

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

219−targetToFile is (TargetModule mod) = do

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

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

222− mapM (fmap toNormalizedFilePath' . canonicalizePath) fps

223−targetToFile _ (TargetFile f _) = do

224− f' <- canonicalizePath f

225− return [toNormalizedFilePath' f']

226−

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

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

229−

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

231−loadSessionShake fp = do

232− se <- getShakeExtras

233− IdeOptions{optTesting} <- getIdeOptions

234− res <- liftIO $ loadSession optTesting se fp

235− return (fmap liftIO res)

236−

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

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

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

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

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

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

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

244− -- Mapping from a Filepath to HscEnv

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

246−

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

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

249− res <- findCradle v

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

251− -- try and normalise that

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

253− res' <- traverse IO.makeAbsolute res

254− return $ normalise <$> res'

255−

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

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

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

259− -- which contains the union.

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

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

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

263− -- Parse DynFlags for the newly discovered component

264− hscEnv <- emptyHscEnv

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

266− setOptions opts (hsc_dflags hscEnv)

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

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

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

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

271− -- (unitId, DynFlag, Targets)

272− modifyVar hscEnvs $ \m -> do

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

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

275− let oldDeps = Map.lookup hieYaml m

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

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

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

279− -- information.

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

281− : maybe [] snd oldDeps

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

283− inplace = map rawComponentUnitId new_deps

284−

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

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

287− -- components in this HscEnv

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

289− let prefix = show rawComponentUnitId

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

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

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

293− -- contain any packages which are also loaded

294− -- into the same component.

295− pure $ ComponentInfo rawComponentUnitId

296− processed_df

297− uids

298− rawComponentTargets

299− rawComponentFP

300− rawComponentCOptions

301− rawComponentDependencyInfo

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

303− -- scratch again (for now)

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

305− -- that I do not fully understand

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

307− hscEnv <- case oldDeps of

308− Nothing -> emptyHscEnv

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

310− newHscEnv <-

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

312− evalGhcEnv hscEnv $ do

313− _ <- setSessionDynFlags df

314− getSession

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

316− -- HscEnv

317− -- Returns

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

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

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

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

322− -- existing packages

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

324−

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

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

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

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

329− -- resolve imports. (especially PackageImports)

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

331−

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

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

334−

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

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

337− let new_cache = newComponentCache logger hscEnv uids

338− (cs, res) <- new_cache new

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

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

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

342− modifyVar_ fileToFlags $ \var -> do

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

344−

345− return (fst res)

346−

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

348− consultCradle hieYaml cfp = do

349− when optTesting $ eventer $ notifyCradleLoaded cfp

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

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

352− eopts <- cradleToSessionOpts cradle cfp

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

354− case eopts of

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

356− -- into and HscEnv.

357− Right opts -> do

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

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

360− Left err -> do

361− dep_info <- getDependencyInfo (maybeToList hieYaml)

362− let ncfp = toNormalizedFilePath' cfp

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

364− modifyVar_ fileToFlags $ \var -> do

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

366− return res

367−

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

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

370− sessionOpts (hieYaml, file) = do

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

372− cfp <- canonicalizePath file

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

374− Just (opts, old_di) -> do

375− deps_ok <- checkDependencyInfo old_di

376− if not deps_ok

377− then do

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

379− -- again.

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

381− -- Keep the same name cache

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

383− consultCradle hieYaml cfp

384− else return opts

385− Nothing -> consultCradle hieYaml cfp

386

182

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

183

184+loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq)

185+loadSession dir = do

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

187+ res <- findCradle v

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

189+ -- try and normalise that

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

191+ res' <- traverse makeAbsolute res

192+ return $ normalise <$> res'

193+ session <- memoIO $ \file -> do

194+ c <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file

195+ cradleToSession c

196+ return $ \file -> liftIO $ session =<< cradleLoc file

404

197

405

198

406−-- | Create a mapping from FilePaths to HscEnvEqs

407−newComponentCache

408− :: Logger

409− -> HscEnv

410− -> [(InstalledUnitId, DynFlags)]

411− -> ComponentInfo

412− -> IO ([(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))], (IdeResult HscEnvEq, DependencyInfo))

413−newComponentCache logger hsc_env uids ci = do

414− let df = componentDynFlags ci

415− let hscEnv' = hsc_env { hsc_dflags = df

416− , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } }

417−

418− versionMismatch <- checkGhcVersion

419− henv <- case versionMismatch of

420− Just mismatch -> return mismatch

421− Nothing -> newHscEnvEq hscEnv' uids

422− let res = (([], Just henv), componentDependencyInfo ci)

423− logDebug logger ("New Component Cache HscEnvEq: " <> T.pack (show res))

424−

425− let is = importPaths df

426− ctargets <- concatMapM (targetToFile is . targetId) (componentTargets ci)

427− -- A special target for the file which caused this wonderful

428− -- component to be created. In case the cradle doesn't list all the targets for

429− -- the component, in which case things will be horribly broken anyway.

430− -- Otherwise, we will immediately attempt to reload this module which

431− -- causes an infinite loop and high CPU usage.

432− let special_target = (componentFP ci, res)

433− let xs = map (,res) ctargets

434− return (special_target:xs, res)

435−

436−{- Note [Avoiding bad interface files]

437−~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

438−Originally, we set the cache directory for the various components once

439−on the first occurrence of the component.

440−This works fine if these components have no references to each other,

441−but you have components that depend on each other, the interface files are

442−updated for each component.

443−After restarting the session and only opening the component that depended

444−on the other, suddenly the interface files of this component are stale.

445−However, from the point of view of `ghcide`, they do not look stale,

446−thus, not regenerated and the IDE shows weird errors such as:

447−```

448−typecheckIface

449−Declaration for Rep_ClientRunFlags

450−Axiom branches Rep_ClientRunFlags:

451− Failed to load interface for ‘Distribution.Simple.Flag’

452− Use -v to see a list of the files searched for.

453−```

454−and

455−```

456−expectJust checkFamInstConsistency

457−CallStack (from HasCallStack):

458− error, called at compiler\\utils\\Maybes.hs:55:27 in ghc:Maybes

459− expectJust, called at compiler\\typecheck\\FamInst.hs:461:30 in ghc:FamInst

460−```

461−

462−To mitigate this, we set the cache directory for each component dependent

463−on the components of the current `HscEnv`, additionally to the component options

464−of the respective components.

465−Assume two components, c1, c2, where c2 depends on c1, and the options of the

466−respective components are co1, co2.

467−If we want to load component c2, followed by c1, we set the cache directory for

468−each component in this way:

469−

470− * Load component c2

471− * (Cache Directory State)

472− - name of c2 + co2

473− * Load component c1

474− * (Cache Directory State)

475− - name of c2 + name of c1 + co2

476− - name of c2 + name of c1 + co1

477−

478−Overall, we created three cache directories. If we opened c1 first, then we

479−create a fourth cache directory.

480−This makes sure that interface files are always correctly updated.

481−

482−Since this causes a lot of recompilation, we only update the cache-directory,

483−if the dependencies of a component have really changed.

484−E.g. when you load two executables, they can not depend on each other. They

485−should be filtered out, such that we dont have to re-compile everything.

486−-}

487−

488−-- | Set the cache-directory based on the ComponentOptions and a list of

489−-- internal packages.

490−-- For the exact reason, see Note [Avoiding bad interface files].

491−setCacheDir :: MonadIO m => Logger -> String -> [String] -> ComponentOptions -> DynFlags -> m DynFlags

492−setCacheDir logger prefix hscComponents comps dflags = do

493− cacheDir <- liftIO $ getCacheDir prefix (hscComponents ++ componentOptions comps)

494− liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack cacheDir

495− pure $ dflags

496− & setHiDir cacheDir

497− & setDefaultHieDir cacheDir

498−

499−

500−renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic

501−renderCradleError nfp (CradleError _ec t) =

502− ideErrorText nfp (T.unlines (map T.pack t))

503−

504−-- See Note [Multi Cradle Dependency Info]

505−type DependencyInfo = Map.Map FilePath (Maybe UTCTime)

506−type HieMap = Map.Map (Maybe FilePath) (HscEnv, [RawComponentInfo])

507−type FlagsMap = Map.Map (Maybe FilePath) (HM.HashMap NormalizedFilePath (IdeResult HscEnvEq, DependencyInfo))

508−

509−-- This is pristine information about a component

510−data RawComponentInfo = RawComponentInfo

511− { rawComponentUnitId :: InstalledUnitId

512− -- | Unprocessed DynFlags. Contains inplace packages such as libraries.

513− -- We do not want to use them unprocessed.

514− , rawComponentDynFlags :: DynFlags

515− -- | All targets of this components.

516− , rawComponentTargets :: [Target]

517− -- | Filepath which caused the creation of this component

518− , rawComponentFP :: NormalizedFilePath

519− -- | Component Options used to load the component.

520− , rawComponentCOptions :: ComponentOptions

521− -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file

522− -- to last modification time. See Note [Multi Cradle Dependency Info].

523− , rawComponentDependencyInfo :: DependencyInfo

524− }

525−

526−-- This is processed information about the component, in particular the dynflags will be modified.

527−data ComponentInfo = ComponentInfo

528− { componentUnitId :: InstalledUnitId

529− -- | Processed DynFlags. Does not contain inplace packages such as local

530− -- libraries. Can be used to actually load this Component.

531− , componentDynFlags :: DynFlags

532− -- | Internal units, such as local libraries, that this component

533− -- is loaded with. These have been extracted from the original

534− -- ComponentOptions.

535− , componentInternalUnits :: [InstalledUnitId]

536− -- | All targets of this components.

537− , componentTargets :: [Target]

538− -- | Filepath which caused the creation of this component

539− , componentFP :: NormalizedFilePath

540− -- | Component Options used to load the component.

541− , componentCOptions :: ComponentOptions

542− -- | Maps cradle dependencies, such as `stack.yaml`, or `.cabal` file

543− -- to last modification time. See Note [Multi Cradle Dependency Info]

544− , componentDependencyInfo :: DependencyInfo

545− }

546−

547−-- | Check if any dependency has been modified lately.

548−checkDependencyInfo :: DependencyInfo -> IO Bool

549−checkDependencyInfo old_di = do

550− di <- getDependencyInfo (Map.keys old_di)

551− return (di == old_di)

552−

553−-- Note [Multi Cradle Dependency Info]

554−-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

555−-- Why do we implement our own file modification tracking here?

556−-- The primary reason is that the custom caching logic is quite complicated and going into shake

557−-- adds even more complexity and more indirection. I did try for about 5 hours to work out how to

558−-- use shake rules rather than IO but eventually gave up.

559−

560−-- | Computes a mapping from a filepath to its latest modification date.

561−-- See Note [Multi Cradle Dependency Info] why we do this ourselves instead

562−-- of letting shake take care of it.

563−getDependencyInfo :: [FilePath] -> IO DependencyInfo

564−getDependencyInfo fs = Map.fromList <$> mapM do_one fs

565−

566− where

567− tryIO :: IO a -> IO (Either IOException a)

568− tryIO = try

569−

570− do_one :: FilePath -> IO (FilePath, Maybe UTCTime)

571− do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp)

572−

573−-- | This function removes all the -package flags which refer to packages we

574−-- are going to deal with ourselves. For example, if a executable depends

575−-- on a library component, then this function will remove the library flag

576−-- from the package flags for the executable

577−--

578−-- There are several places in GHC (for example the call to hptInstances in

579−-- tcRnImports) which assume that all modules in the HPT have the same unit

580−-- ID. Therefore we create a fake one and give them all the same unit id.

581−removeInplacePackages :: [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId])

582−removeInplacePackages us df = (df { packageFlags = ps

583− , thisInstalledUnitId = fake_uid }, uids)

584− where

585− (uids, ps) = partitionEithers (map go (packageFlags df))

586− fake_uid = toInstalledUnitId (stringToUnitId "fake_uid")

587− go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us

588− then Left (toInstalledUnitId u)

589− else Right p

590− go p = Right p

591−

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

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

593--

200--

594-- * If multiple people ask for a result simultaneously, make sure you only compute it once.

201-- * If multiple people ask for a result simultaneously, make sure you only compute it once.

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

605 res <- onceFork $ op k

212 res <- onceFork $ op k

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

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

607 Just res -> return (mp, res)

214 Just res -> return (mp, res)

608−

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

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

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

612− let dflags'' =

613− -- disabled, generated directly by ghcide instead

614− flip gopt_unset Opt_WriteInterface $

615− -- disabled, generated directly by ghcide instead

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

617− dontWriteHieFiles $

618− setIgnoreInterfacePragmas $

619− setLinkerOptions $

620− disableOptimisation $

621− makeDynFlagsAbsolute compRoot dflags'

622− -- initPackages parses the -package flags and

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

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

625− return (final_df, targets)

626−

627−

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

629−-- (HscInterpreted) which implies LinkInMemory

630−-- HscInterpreted

631−setLinkerOptions :: DynFlags -> DynFlags

632−setLinkerOptions df = df {

633− ghcLink = LinkInMemory

634− , hscTarget = HscNothing

635− , ghcMode = CompManager

636− }

637−

638−setIgnoreInterfacePragmas :: DynFlags -> DynFlags

639−setIgnoreInterfacePragmas df =

640− gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges

641−

642−disableOptimisation :: DynFlags -> DynFlags

643−disableOptimisation df = updOptLevel 0 df

644−

645−setHiDir :: FilePath -> DynFlags -> DynFlags

646−setHiDir f d =

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

648− d { hiDir = Just f}

649−

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

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

652− where

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

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

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

656−

657−-- | Sub directory for the cache path

658−cacheDir :: String

659−cacheDir = "ghcide"

660−

661−notifyCradleLoaded :: FilePath -> FromServerMessage

662−notifyCradleLoaded fp =

663− NotCustomServer $

664− NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $

665− toJSON fp

666−

667−cradleLoadedMethod :: T.Text

668−cradleLoadedMethod = "ghcide/cradle/loaded"

669−

670−ghcVersionChecker :: IO VersionCheck

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

672−

673−checkGhcVersion :: IO (Maybe HscEnvEq)

674−checkGhcVersion = do

675− res <- ghcVersionChecker

676− case res of

677− Failure err -> do

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

679− return Nothing

680− Mismatch {..} ->

681− return $ Just GhcVersionMismatch {..}

682− _ ->

683− return Nothing

exe/Utils.hsdeleted−9

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

1−module Utils (getLibdir) where

2−

3−import qualified GHC.Paths

4−import System.Environment

5−import Data.Maybe

6−

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

8−getLibdir :: IO FilePath

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

fmt.sh+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2set -eou pipefail

3−curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s . --with-group=extra

3+curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s .

ghcide.cabal+22−143

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

2build-type: Simple

3category: Development

4name: ghcide

5−version: 0.2.0

5+version: 0.0.5

6license: Apache-2.0

7license-file: LICENSE

8author: Digital Asset

9maintainer: Digital Asset

10−copyright: Digital Asset 2018-2020

10+copyright: Digital Asset 2018-2019

11synopsis: The core of an IDE

12description:

13 A library for building Haskell IDE's on top of the GHC API.

@@ -15,13 +15,7 @@ homepage: https://github.com/digital-asset/ghcide#readme

15bug-reports: https://github.com/digital-asset/ghcide/issues

16tested-with: GHC==8.6.5

17extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md

18− test/data/hover/*.hs

18+ test/data/GotoHover.hs

19− test/data/multi/cabal.project

20− test/data/multi/hie.yaml

21− test/data/multi/a/a.cabal

22− test/data/multi/a/*.hs

23− test/data/multi/b/b.cabal

24− test/data/multi/b/*.hs

26source-repository head

20source-repository head

27 type: git

21 type: git

@@ -36,7 +30,6 @@ library

36 default-language: Haskell2010

30 default-language: Haskell2010

37 build-depends:

31 build-depends:

38 aeson,

32 aeson,

39− array,

40 async,

33 async,

41 base == 4.*,

34 base == 4.*,

42 binary,

35 binary,

@@ -48,10 +41,9 @@ library

48 extra,

41 extra,

49 fuzzy,

42 fuzzy,

50 filepath,

43 filepath,

51− haddock-library >= 1.8,

52 hashable,

44 hashable,

53− haskell-lsp-types == 0.22.*,

45+ haskell-lsp-types == 0.19.*,

54− haskell-lsp == 0.22.*,

46+ haskell-lsp == 0.19.*,

55 mtl,

47 mtl,

56 network-uri,

48 network-uri,

57 prettyprinter-ansi-terminal,

49 prettyprinter-ansi-terminal,

@@ -60,14 +52,14 @@ library

60 regex-tdfa >= 1.3.1.0,

52 regex-tdfa >= 1.3.1.0,

61 rope-utf16-splay,

53 rope-utf16-splay,

62 safe-exceptions,

54 safe-exceptions,

63− shake >= 0.18.4,

55+ shake >= 0.17.5,

64 sorted-list,

56 sorted-list,

65 stm,

57 stm,

66 syb,

58 syb,

67 text,

59 text,

68 time,

60 time,

69 transformers,

61 transformers,

70− unordered-containers >= 0.2.10.0,

62+ unordered-containers,

71 utf8-string,

63 utf8-string,

72 hslogger

64 hslogger

73 if flag(ghc-lib)

65 if flag(ghc-lib)

@@ -80,10 +72,7 @@ library

80 ghc-boot-th,

72 ghc-boot-th,

81 ghc-boot,

73 ghc-boot,

82 ghc >= 8.4

74 ghc >= 8.4

83− if os(windows)

75+ if !os(windows)

84− build-depends:

85− Win32

86− else

87 build-depends:

76 build-depends:

88 unix

77 unix

89 c-sources:

78 c-sources:

@@ -109,66 +98,49 @@ library

109 include-dirs:

98 include-dirs:

110 include

99 include

111 exposed-modules:

100 exposed-modules:

112− Development.IDE.Compat

101+ Development.IDE.Core.Completions

113− Development.IDE.Core.Debouncer

102+ Development.IDE.Core.CompletionsTypes

114 Development.IDE.Core.FileStore

103 Development.IDE.Core.FileStore

115− Development.IDE.Core.IdeConfiguration

116 Development.IDE.Core.OfInterest

104 Development.IDE.Core.OfInterest

117 Development.IDE.Core.PositionMapping

105 Development.IDE.Core.PositionMapping

118 Development.IDE.Core.Rules

106 Development.IDE.Core.Rules

119 Development.IDE.Core.RuleTypes

107 Development.IDE.Core.RuleTypes

120 Development.IDE.Core.Service

108 Development.IDE.Core.Service

121 Development.IDE.Core.Shake

109 Development.IDE.Core.Shake

122− Development.IDE.GHC.Error

123 Development.IDE.GHC.Util

110 Development.IDE.GHC.Util

124 Development.IDE.Import.DependencyInformation

111 Development.IDE.Import.DependencyInformation

125− Development.IDE.LSP.HoverDefinition

126 Development.IDE.LSP.LanguageServer

112 Development.IDE.LSP.LanguageServer

127− Development.IDE.LSP.Outline

128 Development.IDE.LSP.Protocol

113 Development.IDE.LSP.Protocol

129 Development.IDE.LSP.Server

114 Development.IDE.LSP.Server

130− Development.IDE.Spans.Common

131 Development.IDE.Types.Diagnostics

115 Development.IDE.Types.Diagnostics

132 Development.IDE.Types.Location

116 Development.IDE.Types.Location

133 Development.IDE.Types.Logger

117 Development.IDE.Types.Logger

134 Development.IDE.Types.Options

118 Development.IDE.Types.Options

135− Development.IDE.Plugin

136− Development.IDE.Plugin.Completions

137− Development.IDE.Plugin.CodeAction

138 other-modules:

119 other-modules:

120+ Development.IDE.Core.Debouncer

139 Development.IDE.Core.Compile

121 Development.IDE.Core.Compile

140 Development.IDE.Core.Preprocessor

122 Development.IDE.Core.Preprocessor

141− Development.IDE.Core.FileExists

142 Development.IDE.GHC.Compat

123 Development.IDE.GHC.Compat

143 Development.IDE.GHC.CPP

124 Development.IDE.GHC.CPP

125+ Development.IDE.GHC.Error

144 Development.IDE.GHC.Orphans

126 Development.IDE.GHC.Orphans

145 Development.IDE.GHC.Warnings

127 Development.IDE.GHC.Warnings

146− Development.IDE.GHC.WithDynFlags

147 Development.IDE.Import.FindImports

128 Development.IDE.Import.FindImports

129+ Development.IDE.LSP.CodeAction

130+ Development.IDE.LSP.Completions

131+ Development.IDE.LSP.HoverDefinition

148 Development.IDE.LSP.Notifications

132 Development.IDE.LSP.Notifications

133+ Development.IDE.LSP.Outline

149 Development.IDE.Spans.AtPoint

134 Development.IDE.Spans.AtPoint

150 Development.IDE.Spans.Calculate

135 Development.IDE.Spans.Calculate

151 Development.IDE.Spans.Documentation

136 Development.IDE.Spans.Documentation

152 Development.IDE.Spans.Type

137 Development.IDE.Spans.Type

153− Development.IDE.Plugin.CodeAction.PositionIndexed

154− Development.IDE.Plugin.CodeAction.Rules

155− Development.IDE.Plugin.CodeAction.RuleTypes

156− Development.IDE.Plugin.Completions.Logic

157− Development.IDE.Plugin.Completions.Types

158− if (impl(ghc > 8.7) && impl(ghc < 8.10)) || flag(ghc-lib)

159− hs-source-dirs: src-ghc88

160− other-modules:

161− Development.IDE.GHC.HieAst

162− if (impl(ghc > 8.9))

163− hs-source-dirs: src-ghc810

164− other-modules:

165− Development.IDE.GHC.HieAst

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

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

167

139

168executable ghcide-test-preprocessor

140executable ghcide-test-preprocessor

169 default-language: Haskell2010

141 default-language: Haskell2010

170 hs-source-dirs: test/preprocessor

142 hs-source-dirs: test/preprocessor

171− ghc-options: -Wall -Wno-name-shadowing

143+ ghc-options: -Wall

172 main-is: Main.hs

144 main-is: Main.hs

173 build-depends:

145 build-depends:

174 base == 4.*

146 base == 4.*

@@ -178,64 +150,32 @@ executable ghcide

178 buildable: False

150 buildable: False

179 default-language: Haskell2010

151 default-language: Haskell2010

180 hs-source-dirs: exe

152 hs-source-dirs: exe

181− ghc-options:

182− -threaded

183− -Wall

184− -Wno-name-shadowing

153+ ghc-options: -threaded -Wall -Wno-name-shadowing

185− -- allow user RTS overrides

186− -rtsopts

187− -- disable idle GC

188− -- disable parallel GC

189− -- increase nursery size

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

191 main-is: Main.hs

154 main-is: Main.hs

192 build-depends:

155 build-depends:

193− time,

194− async,

195 hslogger,

156 hslogger,

196− aeson,

197 base == 4.*,

157 base == 4.*,

198− binary,

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

200− bytestring,

201 containers,

158 containers,

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

203 data-default,

159 data-default,

204− deepseq,

205 directory,

160 directory,

206 extra,

161 extra,

207 filepath,

162 filepath,

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

209 ghc-paths,

163 ghc-paths,

210 ghc,

164 ghc,

211 gitrev,

165 gitrev,

212− hashable,

213 haskell-lsp,

166 haskell-lsp,

214− haskell-lsp-types,

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

167+ hie-bios >= 0.3.2 && < 0.4,

216 ghcide,

168 ghcide,

217 optparse-applicative,

169 optparse-applicative,

218 shake,

170 shake,

219− text,

171+ text

220− unordered-containers

221 other-modules:

172 other-modules:

222− Utils

223 Arguments

173 Arguments

224 Paths_ghcide

174 Paths_ghcide

225

175

226 default-extensions:

176 default-extensions:

227− BangPatterns

228− DeriveFunctor

229− DeriveGeneric

230− GeneralizedNewtypeDeriving

231− LambdaCase

232− NamedFieldPuns

233− OverloadedStrings

234 RecordWildCards

177 RecordWildCards

235− ScopedTypeVariables

236− StandaloneDeriving

237 TupleSections

178 TupleSections

238− TypeApplications

239 ViewPatterns

179 ViewPatterns

240

180

241test-suite ghcide-tests

181test-suite ghcide-tests

@@ -264,22 +204,13 @@ test-suite ghcide-tests

264 --------------------------------------------------------------

204 --------------------------------------------------------------

265 ghcide,

205 ghcide,

266 ghc-typelits-knownnat,

206 ghc-typelits-knownnat,

267− haddock-library,

268− haskell-lsp,

269 haskell-lsp-types,

207 haskell-lsp-types,

270− network-uri,

271 lens,

208 lens,

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

209+ lsp-test >= 0.8,

273 parser-combinators,

210 parser-combinators,

274− QuickCheck,

275− quickcheck-instances,

276− rope-utf16-splay,

277− shake,

278 tasty,

211 tasty,

279− tasty-expected-failure,

280 tasty-hunit,

212 tasty-hunit,

281− tasty-quickcheck,

213+ tasty-expected-failure,

282− tasty-rerun,

283 text

214 text

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

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

285 include-dirs: include

216 include-dirs: include

@@ -289,56 +220,4 @@ test-suite ghcide-tests

289 Development.IDE.Test

220 Development.IDE.Test

290 Development.IDE.Test.Runfiles

221 Development.IDE.Test.Runfiles

291 default-extensions:

222 default-extensions:

292− BangPatterns

293− DeriveFunctor

294− DeriveGeneric

295− GeneralizedNewtypeDeriving

296− LambdaCase

297− NamedFieldPuns

298− OverloadedStrings

299− RecordWildCards

300− ScopedTypeVariables

301− StandaloneDeriving

302− TupleSections

303− TypeApplications

304− ViewPatterns

305−

306−benchmark ghcide-bench

307− type: exitcode-stdio-1.0

308− default-language: Haskell2010

309− build-tool-depends:

310− ghcide:ghcide,

311− ghcide:ghcide-test-preprocessor

312− build-depends:

313− aeson,

314− base,

315− bytestring,

316− containers,

317− directory,

318− extra,

319− filepath,

320− ghcide,

321− lsp-test < 0.12,

322− optparse-applicative,

323− parser-combinators,

324− process,

325− safe-exceptions

326− hs-source-dirs: bench

327− include-dirs: include

328− ghc-options: -threaded -Wall -Wno-name-shadowing

329− main-is: Main.hs

330− other-modules:

331− default-extensions:

332− BangPatterns

333− DeriveFunctor

334− DeriveGeneric

335− GeneralizedNewtypeDeriving

336− LambdaCase

337− NamedFieldPuns

338 OverloadedStrings

223 OverloadedStrings

339− RecordWildCards

340− ScopedTypeVariables

341− StandaloneDeriving

342− TupleSections

343− TypeApplications

344− ViewPatterns

hie.yaml+1−12

@@ -1,12 +1 @@

1−cradle:

2− cabal:

3− - path: "./src"

4− component: "ghcide:lib:ghcide"

1+cradle: {stack: {component: "ghcide:lib"}}

5− - path: "./exe"

6− component: "ghcide:exe:ghcide"

7− - path: "./test"

8− component: "ghcide:test:ghcide-tests"

9− - path: "./bench"

10− component: "ghcide:benchmark:ghcide-bench"

11− - path: "./test/preprocessor"

12− component: "ghcide:exe:ghcide-test-preprocessor"

src-ghc810/Development/IDE/GHC/HieAst.hsdeleted−1928

@@ -1,1928 +0,0 @@

1−

2−

3−{-

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

5−

6−Main functions for .hie file generation

7−-}

8−{- HLINT ignore -}

9−{-# LANGUAGE OverloadedStrings #-}

10−{-# LANGUAGE FlexibleInstances #-}

11−{-# LANGUAGE UndecidableInstances #-}

12−{-# LANGUAGE FlexibleContexts #-}

13−{-# LANGUAGE TypeSynonymInstances #-}

14−{-# LANGUAGE ScopedTypeVariables #-}

15−{-# LANGUAGE TypeFamilies #-}

16−{-# LANGUAGE TypeApplications #-}

17−{-# LANGUAGE AllowAmbiguousTypes #-}

18−{-# LANGUAGE ViewPatterns #-}

19−{-# LANGUAGE DeriveDataTypeable #-}

20−module Development.IDE.GHC.HieAst ( mkHieFile ) where

21−

22−import GhcPrelude

23−

24−import Avail ( Avails )

25−import Bag ( Bag, bagToList )

26−import BasicTypes

27−import BooleanFormula

28−import Class ( FunDep )

29−import CoreUtils ( exprType )

30−import ConLike ( conLikeName )

31−import Desugar ( deSugarExpr )

32−import FieldLabel

33−import GHC.Hs

34−import HscTypes

35−import Module ( ModuleName, ml_hs_file )

36−import MonadUtils ( concatMapM, liftIO )

37−import Name ( Name, nameSrcSpan, setNameLoc )

38−import NameEnv ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )

39−import SrcLoc

40−import TcHsSyn ( hsLitType, hsPatType )

41−import Type ( mkVisFunTys, Type )

42−import TysWiredIn ( mkListTy, mkSumTy )

43−import Var ( Id, Var, setVarName, varName, varType )

44−import TcRnTypes

45−import MkIface ( mkIfaceExports )

46−import Panic

47−

48−import HieTypes

49−import HieUtils

50−

51−import qualified Data.Array as A

52−import qualified Data.ByteString as BS

53−import qualified Data.Map as M

54−import qualified Data.Set as S

55−import Data.Data ( Data, Typeable )

56−import Data.List ( foldl1' )

57−import Data.Maybe ( listToMaybe )

58−import Control.Monad.Trans.Reader

59−import Control.Monad.Trans.Class ( lift )

60−

61−{- Note [Updating HieAst for changes in the GHC AST]

62−

63−When updating the code in this file for changes in the GHC AST, you

64−need to pay attention to the following things:

65−

66−1) Symbols (Names/Vars/Modules) in the following categories:

67−

68− a) Symbols that appear in the source file that directly correspond to

69− something the user typed

70− b) Symbols that don't appear in the source, but should be in some sense

71− "visible" to a user, particularly via IDE tooling or the like. This

72− includes things like the names introduced by RecordWildcards (We record

73− all the names introduced by a (..) in HIE files), and will include implicit

74− parameters and evidence variables after one of my pending MRs lands.

75−

76−2) Subtrees that may contain such symbols, or correspond to a SrcSpan in

77− the file. This includes all `Located` things

78−

79−For 1), you need to call `toHie` for one of the following instances

80−

81−instance ToHie (Context (Located Name)) where ...

82−instance ToHie (Context (Located Var)) where ...

83−instance ToHie (IEContext (Located ModuleName)) where ...

84−

85−`Context` is a data type that looks like:

86−

87−data Context a = C ContextInfo a -- Used for names and bindings

88−

89−`ContextInfo` is defined in `HieTypes`, and looks like

90−

91−data ContextInfo

92− = Use -- ^ regular variable

93− | MatchBind

94− | IEThing IEType -- ^ import/export

95− | TyDecl

96− -- | Value binding

97− | ValBind

98− BindType -- ^ whether or not the binding is in an instance

99− Scope -- ^ scope over which the value is bound

100− (Maybe Span) -- ^ span of entire binding

101− ...

102−

103−It is used to annotate symbols in the .hie files with some extra information on

104−the context in which they occur and should be fairly self explanatory. You need

105−to select one that looks appropriate for the symbol usage. In very rare cases,

106−you might need to extend this sum type if none of the cases seem appropriate.

107−

108−So, given a `Located Name` that is just being "used", and not defined at a

109−particular location, you would do the following:

110−

111− toHie $ C Use located_name

112−

113−If you select one that corresponds to a binding site, you will need to

114−provide a `Scope` and a `Span` for your binding. Both of these are basically

115−`SrcSpans`.

116−

117−The `SrcSpan` in the `Scope` is supposed to span over the part of the source

118−where the symbol can be legally allowed to occur. For more details on how to

119−calculate this, see Note [Capturing Scopes and other non local information]

120−in HieAst.

121−

122−The binding `Span` is supposed to be the span of the entire binding for

123−the name.

124−

125−For a function definition `foo`:

126−

127−foo x = x + y

128− where y = x^2

129−

130−The binding `Span` is the span of the entire function definition from `foo x`

131−to `x^2`. For a class definition, this is the span of the entire class, and

132−so on. If this isn't well defined for your bit of syntax (like a variable

133−bound by a lambda), then you can just supply a `Nothing`

134−

135−There is a test that checks that all symbols in the resulting HIE file

136−occur inside their stated `Scope`. This can be turned on by passing the

137−-fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the

138−.hie file.

139−

140−You may also want to provide a test in testsuite/test/hiefile that includes

141−a file containing your new construction, and tests that the calculated scope

142−is valid (by using -fvalidate-ide-info)

143−

144−For subtrees in the AST that may contain symbols, the procedure is fairly

145−straightforward. If you are extending the GHC AST, you will need to provide a

146−`ToHie` instance for any new types you may have introduced in the AST.

147−

148−Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)):

149−

150− toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of

151− HsVar _ (L _ var) ->

152− [ toHie $ C Use (L mspan var)

153− -- Patch up var location since typechecker removes it

154− ]

155− HsConLikeOut _ con ->

156− [ toHie $ C Use $ L mspan $ conLikeName con

157− ]

158− ...

159− HsApp _ a b ->

160− [ toHie a

161− , toHie b

162− ]

163−

164−If your subtree is `Located` or has a `SrcSpan` available, the output list

165−should contain a HieAst `Node` corresponding to the subtree. You can use

166−either `makeNode` or `getTypeNode` for this purpose, depending on whether it

167−makes sense to assign a `Type` to the subtree. After this, you just need

168−to concatenate the result of calling `toHie` on all subexpressions and

169−appropriately annotated symbols contained in the subtree.

170−

171−The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed

172−to work for both the renamed and typechecked source. `getTypeNode` is from

173−the `HasType` class defined in this file, and it has different instances

174−for `GhcTc` and `GhcRn` that allow it to access the type of the expression

175−when given a typechecked AST:

176−

177−class Data a => HasType a where

178− getTypeNode :: a -> HieM [HieAST Type]

179−instance HasType (LHsExpr GhcTc) where

180− getTypeNode e@(L spn e') = ... -- Actually get the type for this expression

181−instance HasType (LHsExpr GhcRn) where

182− getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type

183−

184−If your subtree doesn't have a span available, you can omit the `makeNode`

185−call and just recurse directly in to the subexpressions.

186−

187−-}

188−

189−-- These synonyms match those defined in main/GHC.hs

190−type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn]

191− , Maybe [(LIE GhcRn, Avails)]

192− , Maybe LHsDocString )

193−type TypecheckedSource = LHsBinds GhcTc

194−

195−

196−{- Note [Name Remapping]

197−The Typechecker introduces new names for mono names in AbsBinds.

198−We don't care about the distinction between mono and poly bindings,

199−so we replace all occurrences of the mono name with the poly name.

200−-}

201−newtype HieState = HieState

202− { name_remapping :: NameEnv Id

203− }

204−

205−initState :: HieState

206−initState = HieState emptyNameEnv

207−

208−class ModifyState a where -- See Note [Name Remapping]

209− addSubstitution :: a -> a -> HieState -> HieState

210−

211−instance ModifyState Name where

212− addSubstitution _ _ hs = hs

213−

214−instance ModifyState Id where

215− addSubstitution mono poly hs =

216− hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly}

217−

218−modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState

219−modifyState = foldr go id

220− where

221− go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f

222− go _ f = f

223−

224−type HieM = ReaderT HieState Hsc

225−

226−-- | Construct an 'HieFile' from the outputs of the typechecker.

227−mkHieFile :: ModSummary

228− -> TcGblEnv

229− -> RenamedSource

230− -> BS.ByteString -> Hsc HieFile

231−mkHieFile ms ts rs src = do

232− let tc_binds = tcg_binds ts

233− (asts', arr) <- getCompressedAsts tc_binds rs

234− let Just src_file = ml_hs_file $ ms_location ms

235− return $ HieFile

236− { hie_hs_file = src_file

237− , hie_module = ms_mod ms

238− , hie_types = arr

239− , hie_asts = asts'

240− -- mkIfaceExports sorts the AvailInfos for stability

241− , hie_exports = mkIfaceExports (tcg_exports ts)

242− , hie_hs_src = src

243− }

244−

245−getCompressedAsts :: TypecheckedSource -> RenamedSource

246− -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)

247−getCompressedAsts ts rs = do

248− asts <- enrichHie ts rs

249− return $ compressTypes asts

250−

251−enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)

252−enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do

253− tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts

254− rasts <- processGrp hsGrp

255− imps <- toHie $ filter (not . ideclImplicit . unLoc) imports

256− exps <- toHie $ fmap (map $ IEC Export . fst) exports

257− let spanFile children = case children of

258− [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)

259− _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)

260− (realSrcSpanEnd $ nodeSpan $ last children)

261−

262− modulify xs =

263− Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs

264−

265− asts = HieASTs

266− $ resolveTyVarScopes

267− $ M.map (modulify . mergeSortAsts)

268− $ M.fromListWith (++)

269− $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts

270−

271− flat_asts = concat

272− [ tasts

273− , rasts

274− , imps

275− , exps

276− ]

277− return asts

278− where

279− processGrp grp = concatM

280− [ toHie $ fmap (RS ModuleScope ) hs_valds grp

281− , toHie $ hs_splcds grp

282− , toHie $ hs_tyclds grp

283− , toHie $ hs_derivds grp

284− , toHie $ hs_fixds grp

285− , toHie $ hs_defds grp

286− , toHie $ hs_fords grp

287− , toHie $ hs_warnds grp

288− , toHie $ hs_annds grp

289− , toHie $ hs_ruleds grp

290− ]

291−

292−getRealSpan :: SrcSpan -> Maybe Span

293−getRealSpan (RealSrcSpan sp) = Just sp

294−getRealSpan _ = Nothing

295−

296−grhss_span :: GRHSs p body -> SrcSpan

297−grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)

298−grhss_span (XGRHSs _) = panic "XGRHS has no span"

299−

300−bindingsOnly :: [Context Name] -> [HieAST a]

301−bindingsOnly [] = []

302−bindingsOnly (C c n : xs) = case nameSrcSpan n of

303− RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs

304− where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)

305− info = mempty{identInfo = S.singleton c}

306− _ -> bindingsOnly xs

307−

308−concatM :: Monad m => [m [a]] -> m [a]

309−concatM xs = concat <$> sequence xs

310−

311−{- Note [Capturing Scopes and other non local information]

312−toHie is a local tranformation, but scopes of bindings cannot be known locally,

313−hence we have to push the relevant info down into the binding nodes.

314−We use the following types (*Context and *Scoped) to wrap things and

315−carry the required info

316−(Maybe Span) always carries the span of the entire binding, including rhs

317−-}

318−data Context a = C ContextInfo a -- Used for names and bindings

319−

320−data RContext a = RC RecFieldContext a

321−data RFContext a = RFC RecFieldContext (Maybe Span) a

322−-- ^ context for record fields

323−

324−data IEContext a = IEC IEType a

325−-- ^ context for imports/exports

326−

327−data BindContext a = BC BindType Scope a

328−-- ^ context for imports/exports

329−

330−data PatSynFieldContext a = PSC (Maybe Span) a

331−-- ^ context for pattern synonym fields.

332−

333−data SigContext a = SC SigInfo a

334−-- ^ context for type signatures

335−

336−data SigInfo = SI SigType (Maybe Span)

337−

338−data SigType = BindSig | ClassSig | InstSig

339−

340−data RScoped a = RS Scope a

341−-- ^ Scope spans over everything to the right of a, (mostly) not

342−-- including a itself

343−-- (Includes a in a few special cases like recursive do bindings) or

344−-- let/where bindings

345−

346−-- | Pattern scope

347−data PScoped a = PS (Maybe Span)

348− Scope -- ^ use site of the pattern

349− Scope -- ^ pattern to the right of a, not including a

350− a

351− deriving (Typeable, Data) -- Pattern Scope

352−

353−{- Note [TyVar Scopes]

354−Due to -XScopedTypeVariables, type variables can be in scope quite far from

355−their original binding. We resolve the scope of these type variables

356−in a separate pass

357−-}

358−data TScoped a = TS TyVarScope a -- TyVarScope

359−

360−data TVScoped a = TVS TyVarScope Scope a -- TyVarScope

361−-- ^ First scope remains constant

362−-- Second scope is used to build up the scope of a tyvar over

363−-- things to its right, ala RScoped

364−

365−-- | Each element scopes over the elements to the right

366−listScopes :: Scope -> [Located a] -> [RScoped (Located a)]

367−listScopes _ [] = []

368−listScopes rhsScope [pat] = [RS rhsScope pat]

369−listScopes rhsScope (pat : pats) = RS sc pat : pats'

370− where

371− pats'@((RS scope p):_) = listScopes rhsScope pats

372− sc = combineScopes scope $ mkScope $ getLoc p

373−

374−-- | 'listScopes' specialised to 'PScoped' things

375−patScopes

376− :: Maybe Span

377− -> Scope

378− -> Scope

379− -> [LPat (GhcPass p)]

380− -> [PScoped (LPat (GhcPass p))]

381−patScopes rsp useScope patScope xs =

382− map (\(RS sc a) -> PS rsp useScope sc (composeSrcSpan a)) $

383− listScopes patScope (map dL xs)

384−

385−-- | 'listScopes' specialised to 'TVScoped' things

386−tvScopes

387− :: TyVarScope

388− -> Scope

389− -> [LHsTyVarBndr a]

390− -> [TVScoped (LHsTyVarBndr a)]

391−tvScopes tvScope rhsScope xs =

392− map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs

393−

394−{- Note [Scoping Rules for SigPat]

395−Explicitly quantified variables in pattern type signatures are not

396−brought into scope in the rhs, but implicitly quantified variables

397−are (HsWC and HsIB).

398−This is unlike other signatures, where explicitly quantified variables

399−are brought into the RHS Scope

400−For example

401−foo :: forall a. ...;

402−foo = ... -- a is in scope here

403−

404−bar (x :: forall a. a -> a) = ... -- a is not in scope here

405−-- ^ a is in scope here (pattern body)

406−

407−bax (x :: a) = ... -- a is in scope here

408−Because of HsWC and HsIB pass on their scope to their children

409−we must wrap the LHsType in pattern signatures in a

410−Shielded explictly, so that the HsWC/HsIB scope is not passed

411−on the the LHsType

412−-}

413−

414−data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead

415−

416−type family ProtectedSig a where

417− ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs

418− GhcRn

419− (Shielded (LHsType GhcRn)))

420− ProtectedSig GhcTc = NoExtField

421−

422−class ProtectSig a where

423− protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a

424−

425−instance (HasLoc a) => HasLoc (Shielded a) where

426− loc (SH _ a) = loc a

427−

428−instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where

429− toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)

430−

431−instance ProtectSig GhcTc where

432− protectSig _ _ = noExtField

433−

434−instance ProtectSig GhcRn where

435− protectSig sc (HsWC a (HsIB b sig)) =

436− HsWC a (HsIB b (SH sc sig))

437− protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec

438− protectSig _ (XHsWildCardBndrs nec) = noExtCon nec

439−

440−class HasLoc a where

441− -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can

442− -- know what their implicit bindings are scoping over

443− loc :: a -> SrcSpan

444−

445−instance HasLoc thing => HasLoc (TScoped thing) where

446− loc (TS _ a) = loc a

447−

448−instance HasLoc thing => HasLoc (PScoped thing) where

449− loc (PS _ _ _ a) = loc a

450−

451−instance HasLoc (LHsQTyVars GhcRn) where

452− loc (HsQTvs _ vs) = loc vs

453− loc _ = noSrcSpan

454−

455−instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where

456− loc (HsIB _ a) = loc a

457− loc _ = noSrcSpan

458−

459−instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where

460− loc (HsWC _ a) = loc a

461− loc _ = noSrcSpan

462−

463−instance HasLoc (Located a) where

464− loc (L l _) = l

465−

466−instance HasLoc a => HasLoc [a] where

467− loc [] = noSrcSpan

468− loc xs = foldl1' combineSrcSpans $ map loc xs

469−

470−instance HasLoc a => HasLoc (FamEqn s a) where

471− loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]

472− loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans

473− [loc a, loc tvs, loc b, loc c]

474− loc _ = noSrcSpan

475−instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where

476− loc (HsValArg tm) = loc tm

477− loc (HsTypeArg _ ty) = loc ty

478− loc (HsArgPar sp) = sp

479−

480−instance HasLoc (HsDataDefn GhcRn) where

481− loc def@(HsDataDefn{}) = loc $ dd_cons def

482− -- Only used for data family instances, so we only need rhs

483− -- Most probably the rest will be unhelpful anyway

484− loc _ = noSrcSpan

485−

486−{- Note [Real DataCon Name]

487−The typechecker subtitutes the conLikeWrapId for the name, but we don't want

488−this showing up in the hieFile, so we replace the name in the Id with the

489−original datacon name

490−See also Note [Data Constructor Naming]

491−-}

492−class HasRealDataConName p where

493− getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p)

494−

495−instance HasRealDataConName GhcRn where

496− getRealDataCon _ n = n

497−instance HasRealDataConName GhcTc where

498− getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) =

499− L sp (setVarName var (conLikeName con))

500−

501−-- | The main worker class

502−-- See Note [Updating HieAst for changes in the GHC AST] for more information

503−-- on how to add/modify instances for this.

504−class ToHie a where

505− toHie :: a -> HieM [HieAST Type]

506−

507−-- | Used to collect type info

508−class Data a => HasType a where

509− getTypeNode :: a -> HieM [HieAST Type]

510−

511−instance (ToHie a) => ToHie [a] where

512− toHie = concatMapM toHie

513−

514−instance (ToHie a) => ToHie (Bag a) where

515− toHie = toHie . bagToList

516−

517−instance (ToHie a) => ToHie (Maybe a) where

518− toHie = maybe (pure []) toHie

519−

520−instance ToHie (Context (Located NoExtField)) where

521− toHie _ = pure []

522−

523−instance ToHie (TScoped NoExtField) where

524− toHie _ = pure []

525−

526−instance ToHie (IEContext (Located ModuleName)) where

527− toHie (IEC c (L (RealSrcSpan span) mname)) =

528− pure $ [Node (NodeInfo S.empty [] idents) span []]

529− where details = mempty{identInfo = S.singleton (IEThing c)}

530− idents = M.singleton (Left mname) details

531− toHie _ = pure []

532−

533−instance ToHie (Context (Located Var)) where

534− toHie c = case c of

535− C context (L (RealSrcSpan span) name')

536− -> do

537− m <- asks name_remapping

538− let name = case lookupNameEnv m (varName name') of

539− Just var -> var

540− Nothing-> name'

541− pure

542− [Node

543− (NodeInfo S.empty [] $

544− M.singleton (Right $ varName name)

545− (IdentifierDetails (Just $ varType name')

546− (S.singleton context)))

547− span

548− []]

549− _ -> pure []

550−

551−instance ToHie (Context (Located Name)) where

552− toHie c = case c of

553− C context (L (RealSrcSpan span) name') -> do

554− m <- asks name_remapping

555− let name = case lookupNameEnv m name' of

556− Just var -> varName var

557− Nothing -> name'

558− pure

559− [Node

560− (NodeInfo S.empty [] $

561− M.singleton (Right name)

562− (IdentifierDetails Nothing

563− (S.singleton context)))

564− span

565− []]

566− _ -> pure []

567−

568−-- | Dummy instances - never called

569−instance ToHie (TScoped (LHsSigWcType GhcTc)) where

570− toHie _ = pure []

571−instance ToHie (TScoped (LHsWcType GhcTc)) where

572− toHie _ = pure []

573−instance ToHie (SigContext (LSig GhcTc)) where

574− toHie _ = pure []

575−instance ToHie (TScoped Type) where

576− toHie _ = pure []

577−

578−instance HasType (LHsBind GhcRn) where

579− getTypeNode (L spn bind) = makeNode bind spn

580−

581−instance HasType (LHsBind GhcTc) where

582− getTypeNode (L spn bind) = case bind of

583− FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)

584− _ -> makeNode bind spn

585−

586−instance HasType (Located (Pat GhcRn)) where

587− getTypeNode (dL -> L spn pat) = makeNode pat spn

588−

589−instance HasType (Located (Pat GhcTc)) where

590− getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)

591−

592−instance HasType (LHsExpr GhcRn) where

593− getTypeNode (L spn e) = makeNode e spn

594−

595−-- | This instance tries to construct 'HieAST' nodes which include the type of

596−-- the expression. It is not yet possible to do this efficiently for all

597−-- expression forms, so we skip filling in the type for those inputs.

598−--

599−-- 'HsApp', for example, doesn't have any type information available directly on

600−-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then

601−-- query the type of that. Yet both the desugaring call and the type query both

602−-- involve recursive calls to the function and argument! This is particularly

603−-- problematic when you realize that the HIE traversal will eventually visit

604−-- those nodes too and ask for their types again.

605−--

606−-- Since the above is quite costly, we just skip cases where computing the

607−-- expression's type is going to be expensive.

608−--

609−-- See #16233

610−instance HasType (LHsExpr GhcTc) where

611− getTypeNode e@(L spn e') = lift $

612− -- Some expression forms have their type immediately available

613− let tyOpt = case e' of

614− HsLit _ l -> Just (hsLitType l)

615− HsOverLit _ o -> Just (overLitType o)

616−

617− HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)

618− HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)

619− HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)

620−

621− ExplicitList ty _ _ -> Just (mkListTy ty)

622− ExplicitSum ty _ _ _ -> Just (mkSumTy ty)

623− HsDo ty _ _ -> Just ty

624− HsMultiIf ty _ -> Just ty

625−

626− _ -> Nothing

627−

628− in

629− case tyOpt of

630− Just t -> makeTypeNode e' spn t

631− Nothing

632− | skipDesugaring e' -> fallback

633− | otherwise -> do

634− hs_env <- Hsc $ \e w -> return (e,w)

635− (_,mbe) <- liftIO $ deSugarExpr hs_env e

636− maybe fallback (makeTypeNode e' spn . exprType) mbe

637− where

638− fallback = makeNode e' spn

639−

640− matchGroupType :: MatchGroupTc -> Type

641− matchGroupType (MatchGroupTc args res) = mkVisFunTys args res

642−

643− -- | Skip desugaring of these expressions for performance reasons.

644− --

645− -- See impact on Haddock output (esp. missing type annotations or links)

646− -- before marking more things here as 'False'. See impact on Haddock

647− -- performance before marking more things as 'True'.

648− skipDesugaring :: HsExpr a -> Bool

649− skipDesugaring e = case e of

650− HsVar{} -> False

651− HsUnboundVar{} -> False

652− HsConLikeOut{} -> False

653− HsRecFld{} -> False

654− HsOverLabel{} -> False

655− HsIPVar{} -> False

656− HsWrap{} -> False

657− _ -> True

658−

659−instance ( ToHie (Context (Located (IdP a)))

660− , ToHie (MatchGroup a (LHsExpr a))

661− , ToHie (PScoped (LPat a))

662− , ToHie (GRHSs a (LHsExpr a))

663− , ToHie (LHsExpr a)

664− , ToHie (Located (PatSynBind a a))

665− , HasType (LHsBind a)

666− , ModifyState (IdP a)

667− , Data (HsBind a)

668− ) => ToHie (BindContext (LHsBind a)) where

669− toHie (BC context scope b@(L span bind)) =

670− concatM $ getTypeNode b : case bind of

671− FunBind{fun_id = name, fun_matches = matches} ->

672− [ toHie $ C (ValBind context scope $ getRealSpan span) name

673− , toHie matches

674− ]

675− PatBind{pat_lhs = lhs, pat_rhs = rhs} ->

676− [ toHie $ PS (getRealSpan span) scope NoScope lhs

677− , toHie rhs

678− ]

679− VarBind{var_rhs = expr} ->

680− [ toHie expr

681− ]

682− AbsBinds{abs_exports = xs, abs_binds = binds} ->

683− [ local (modifyState xs) $ -- Note [Name Remapping]

684− toHie $ fmap (BC context scope) binds

685− ]

686− PatSynBind _ psb ->

687− [ toHie $ L span psb -- PatSynBinds only occur at the top level

688− ]

689− XHsBindsLR _ -> []

690−

691−instance ( ToHie (LMatch a body)

692− ) => ToHie (MatchGroup a body) where

693− toHie mg = concatM $ case mg of

694− MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->

695− [ pure $ locOnly span

696− , toHie alts

697− ]

698− MG{} -> []

699− XMatchGroup _ -> []

700−

701−instance ( ToHie (Context (Located (IdP a)))

702− , ToHie (PScoped (LPat a))

703− , ToHie (HsPatSynDir a)

704− ) => ToHie (Located (PatSynBind a a)) where

705− toHie (L sp psb) = concatM $ case psb of

706− PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->

707− [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var

708− , toHie $ toBind dets

709− , toHie $ PS Nothing lhsScope NoScope pat

710− , toHie dir

711− ]

712− where

713− lhsScope = combineScopes varScope detScope

714− varScope = mkLScope var

715− detScope = case dets of

716− (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args

717− (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)

718− (RecCon r) -> foldr go NoScope r

719− go (RecordPatSynField a b) c = combineScopes c

720− $ combineScopes (mkLScope a) (mkLScope b)

721− detSpan = case detScope of

722− LocalScope a -> Just a

723− _ -> Nothing

724− toBind (PrefixCon args) = PrefixCon $ map (C Use) args

725− toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)

726− toBind (RecCon r) = RecCon $ map (PSC detSpan) r

727− XPatSynBind _ -> []

728−

729−instance ( ToHie (MatchGroup a (LHsExpr a))

730− ) => ToHie (HsPatSynDir a) where

731− toHie dir = case dir of

732− ExplicitBidirectional mg -> toHie mg

733− _ -> pure []

734−

735−instance ( a ~ GhcPass p

736− , ToHie body

737− , ToHie (HsMatchContext (NameOrRdrName (IdP a)))

738− , ToHie (PScoped (LPat a))

739− , ToHie (GRHSs a body)

740− , Data (Match a body)

741− ) => ToHie (LMatch (GhcPass p) body) where

742− toHie (L span m ) = concatM $ makeNode m span : case m of

743− Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->

744− [ toHie mctx

745− , let rhsScope = mkScope $ grhss_span grhss

746− in toHie $ patScopes Nothing rhsScope NoScope pats

747− , toHie grhss

748− ]

749− XMatch _ -> []

750−

751−instance ( ToHie (Context (Located a))

752− ) => ToHie (HsMatchContext a) where

753− toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name

754− toHie (StmtCtxt a) = toHie a

755− toHie _ = pure []

756−

757−instance ( ToHie (HsMatchContext a)

758− ) => ToHie (HsStmtContext a) where

759− toHie (PatGuard a) = toHie a

760− toHie (ParStmtCtxt a) = toHie a

761− toHie (TransStmtCtxt a) = toHie a

762− toHie _ = pure []

763−

764−instance ( a ~ GhcPass p

765− , ToHie (Context (Located (IdP a)))

766− , ToHie (RContext (HsRecFields a (PScoped (LPat a))))

767− , ToHie (LHsExpr a)

768− , ToHie (TScoped (LHsSigWcType a))

769− , ProtectSig a

770− , ToHie (TScoped (ProtectedSig a))

771− , HasType (LPat a)

772− , Data (HsSplice a)

773− ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where

774− toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =

775− concatM $ getTypeNode lpat : case opat of

776− WildPat _ ->

777− []

778− VarPat _ lname ->

779− [ toHie $ C (PatternBind scope pscope rsp) lname

780− ]

781− LazyPat _ p ->

782− [ toHie $ PS rsp scope pscope p

783− ]

784− AsPat _ lname pat ->

785− [ toHie $ C (PatternBind scope

786− (combineScopes (mkLScope (dL pat)) pscope)

787− rsp)

788− lname

789− , toHie $ PS rsp scope pscope pat

790− ]

791− ParPat _ pat ->

792− [ toHie $ PS rsp scope pscope pat

793− ]

794− BangPat _ pat ->

795− [ toHie $ PS rsp scope pscope pat

796− ]

797− ListPat _ pats ->

798− [ toHie $ patScopes rsp scope pscope pats

799− ]

800− TuplePat _ pats _ ->

801− [ toHie $ patScopes rsp scope pscope pats

802− ]

803− SumPat _ pat _ _ ->

804− [ toHie $ PS rsp scope pscope pat

805− ]

806− ConPatIn c dets ->

807− [ toHie $ C Use c

808− , toHie $ contextify dets

809− ]

810− ConPatOut {pat_con = con, pat_args = dets}->

811− [ toHie $ C Use $ fmap conLikeName con

812− , toHie $ contextify dets

813− ]

814− ViewPat _ expr pat ->

815− [ toHie expr

816− , toHie $ PS rsp scope pscope pat

817− ]

818− SplicePat _ sp ->

819− [ toHie $ L ospan sp

820− ]

821− LitPat _ _ ->

822− []

823− NPat _ _ _ _ ->

824− []

825− NPlusKPat _ n _ _ _ _ ->

826− [ toHie $ C (PatternBind scope pscope rsp) n

827− ]

828− SigPat _ pat sig ->

829− [ toHie $ PS rsp scope pscope pat

830− , let cscope = mkLScope (dL pat) in

831− toHie $ TS (ResolvedScopes [cscope, scope, pscope])

832− (protectSig @a cscope sig)

833− -- See Note [Scoping Rules for SigPat]

834− ]

835− CoPat _ _ _ _ ->

836− []

837− XPat _ -> []

838− where

839− contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args

840− contextify (InfixCon a b) = InfixCon a' b'

841− where [a', b'] = patScopes rsp scope pscope [a,b]

842− contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r

843− contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a

844− where

845− go (RS fscope (L spn (HsRecField lbl pat pun))) =

846− L spn $ HsRecField lbl (PS rsp scope fscope pat) pun

847− scoped_fds = listScopes pscope fds

848−

849−instance ( ToHie body

850− , ToHie (LGRHS a body)

851− , ToHie (RScoped (LHsLocalBinds a))

852− ) => ToHie (GRHSs a body) where

853− toHie grhs = concatM $ case grhs of

854− GRHSs _ grhss binds ->

855− [ toHie grhss

856− , toHie $ RS (mkScope $ grhss_span grhs) binds

857− ]

858− XGRHSs _ -> []

859−

860−instance ( ToHie (Located body)

861− , ToHie (RScoped (GuardLStmt a))

862− , Data (GRHS a (Located body))

863− ) => ToHie (LGRHS a (Located body)) where

864− toHie (L span g) = concatM $ makeNode g span : case g of

865− GRHS _ guards body ->

866− [ toHie $ listScopes (mkLScope body) guards

867− , toHie body

868− ]

869− XGRHS _ -> []

870−

871−instance ( a ~ GhcPass p

872− , ToHie (Context (Located (IdP a)))

873− , HasType (LHsExpr a)

874− , ToHie (PScoped (LPat a))

875− , ToHie (MatchGroup a (LHsExpr a))

876− , ToHie (LGRHS a (LHsExpr a))

877− , ToHie (RContext (HsRecordBinds a))

878− , ToHie (RFContext (Located (AmbiguousFieldOcc a)))

879− , ToHie (ArithSeqInfo a)

880− , ToHie (LHsCmdTop a)

881− , ToHie (RScoped (GuardLStmt a))

882− , ToHie (RScoped (LHsLocalBinds a))

883− , ToHie (TScoped (LHsWcType (NoGhcTc a)))

884− , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))

885− , Data (HsExpr a)

886− , Data (HsSplice a)

887− , Data (HsTupArg a)

888− , Data (AmbiguousFieldOcc a)

889− , (HasRealDataConName a)

890− ) => ToHie (LHsExpr (GhcPass p)) where

891− toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of

892− HsVar _ (L _ var) ->

893− [ toHie $ C Use (L mspan var)

894− -- Patch up var location since typechecker removes it

895− ]

896− HsUnboundVar _ _ ->

897− []

898− HsConLikeOut _ con ->

899− [ toHie $ C Use $ L mspan $ conLikeName con

900− ]

901− HsRecFld _ fld ->

902− [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)

903− ]

904− HsOverLabel _ _ _ -> []

905− HsIPVar _ _ -> []

906− HsOverLit _ _ -> []

907− HsLit _ _ -> []

908− HsLam _ mg ->

909− [ toHie mg

910− ]

911− HsLamCase _ mg ->

912− [ toHie mg

913− ]

914− HsApp _ a b ->

915− [ toHie a

916− , toHie b

917− ]

918− HsAppType _ expr sig ->

919− [ toHie expr

920− , toHie $ TS (ResolvedScopes []) sig

921− ]

922− OpApp _ a b c ->

923− [ toHie a

924− , toHie b

925− , toHie c

926− ]

927− NegApp _ a _ ->

928− [ toHie a

929− ]

930− HsPar _ a ->

931− [ toHie a

932− ]

933− SectionL _ a b ->

934− [ toHie a

935− , toHie b

936− ]

937− SectionR _ a b ->

938− [ toHie a

939− , toHie b

940− ]

941− ExplicitTuple _ args _ ->

942− [ toHie args

943− ]

944− ExplicitSum _ _ _ expr ->

945− [ toHie expr

946− ]

947− HsCase _ expr matches ->

948− [ toHie expr

949− , toHie matches

950− ]

951− HsIf _ _ a b c ->

952− [ toHie a

953− , toHie b

954− , toHie c

955− ]

956− HsMultiIf _ grhss ->

957− [ toHie grhss

958− ]

959− HsLet _ binds expr ->

960− [ toHie $ RS (mkLScope expr) binds

961− , toHie expr

962− ]

963− HsDo _ _ (L ispan stmts) ->

964− [ pure $ locOnly ispan

965− , toHie $ listScopes NoScope stmts

966− ]

967− ExplicitList _ _ exprs ->

968− [ toHie exprs

969− ]

970− RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} ->

971− [ toHie $ C Use (getRealDataCon @a mrealcon name)

972− -- See Note [Real DataCon Name]

973− , toHie $ RC RecFieldAssign $ binds

974− ]

975− RecordUpd {rupd_expr = expr, rupd_flds = upds}->

976− [ toHie expr

977− , toHie $ map (RC RecFieldAssign) upds

978− ]

979− ExprWithTySig _ expr sig ->

980− [ toHie expr

981− , toHie $ TS (ResolvedScopes [mkLScope expr]) sig

982− ]

983− ArithSeq _ _ info ->

984− [ toHie info

985− ]

986− HsSCC _ _ _ expr ->

987− [ toHie expr

988− ]

989− HsCoreAnn _ _ _ expr ->

990− [ toHie expr

991− ]

992− HsProc _ pat cmdtop ->

993− [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat

994− , toHie cmdtop

995− ]

996− HsStatic _ expr ->

997− [ toHie expr

998− ]

999− HsTick _ _ expr ->

1000− [ toHie expr

1001− ]

1002− HsBinTick _ _ _ expr ->

1003− [ toHie expr

1004− ]

1005− HsTickPragma _ _ _ _ expr ->

1006− [ toHie expr

1007− ]

1008− HsWrap _ _ a ->

1009− [ toHie $ L mspan a

1010− ]

1011− HsBracket _ b ->

1012− [ toHie b

1013− ]

1014− HsRnBracketOut _ b p ->

1015− [ toHie b

1016− , toHie p

1017− ]

1018− HsTcBracketOut _ b p ->

1019− [ toHie b

1020− , toHie p

1021− ]

1022− HsSpliceE _ x ->

1023− [ toHie $ L mspan x

1024− ]

1025− XExpr _ -> []

1026−

1027−instance ( a ~ GhcPass p

1028− , ToHie (LHsExpr a)

1029− , Data (HsTupArg a)

1030− ) => ToHie (LHsTupArg (GhcPass p)) where

1031− toHie (L span arg) = concatM $ makeNode arg span : case arg of

1032− Present _ expr ->

1033− [ toHie expr

1034− ]

1035− Missing _ -> []

1036− XTupArg _ -> []

1037−

1038−instance ( a ~ GhcPass p

1039− , ToHie (PScoped (LPat a))

1040− , ToHie (LHsExpr a)

1041− , ToHie (SigContext (LSig a))

1042− , ToHie (RScoped (LHsLocalBinds a))

1043− , ToHie (RScoped (ApplicativeArg a))

1044− , ToHie (Located body)

1045− , Data (StmtLR a a (Located body))

1046− , Data (StmtLR a a (Located (HsExpr a)))

1047− ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where

1048− toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of

1049− LastStmt _ body _ _ ->

1050− [ toHie body

1051− ]

1052− BindStmt _ pat body _ _ ->

1053− [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat

1054− , toHie body

1055− ]

1056− ApplicativeStmt _ stmts _ ->

1057− [ concatMapM (toHie . RS scope . snd) stmts

1058− ]

1059− BodyStmt _ body _ _ ->

1060− [ toHie body

1061− ]

1062− LetStmt _ binds ->

1063− [ toHie $ RS scope binds

1064− ]

1065− ParStmt _ parstmts _ _ ->

1066− [ concatMapM (\(ParStmtBlock _ stmts _ _) ->

1067− toHie $ listScopes NoScope stmts)

1068− parstmts

1069− ]

1070− TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->

1071− [ toHie $ listScopes scope stmts

1072− , toHie using

1073− , toHie by

1074− ]

1075− RecStmt {recS_stmts = stmts} ->

1076− [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts

1077− ]

1078− XStmtLR _ -> []

1079−

1080−instance ( ToHie (LHsExpr a)

1081− , ToHie (PScoped (LPat a))

1082− , ToHie (BindContext (LHsBind a))

1083− , ToHie (SigContext (LSig a))

1084− , ToHie (RScoped (HsValBindsLR a a))

1085− , Data (HsLocalBinds a)

1086− ) => ToHie (RScoped (LHsLocalBinds a)) where

1087− toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of

1088− EmptyLocalBinds _ -> []

1089− HsIPBinds _ _ -> []

1090− HsValBinds _ valBinds ->

1091− [ toHie $ RS (combineScopes scope $ mkScope sp)

1092− valBinds

1093− ]

1094− XHsLocalBindsLR _ -> []

1095−

1096−instance ( ToHie (BindContext (LHsBind a))

1097− , ToHie (SigContext (LSig a))

1098− , ToHie (RScoped (XXValBindsLR a a))

1099− ) => ToHie (RScoped (HsValBindsLR a a)) where

1100− toHie (RS sc v) = concatM $ case v of

1101− ValBinds _ binds sigs ->

1102− [ toHie $ fmap (BC RegularBind sc) binds

1103− , toHie $ fmap (SC (SI BindSig Nothing)) sigs

1104− ]

1105− XValBindsLR x -> [ toHie $ RS sc x ]

1106−

1107−instance ToHie (RScoped (NHsValBindsLR GhcTc)) where

1108− toHie (RS sc (NValBinds binds sigs)) = concatM $

1109− [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)

1110− , toHie $ fmap (SC (SI BindSig Nothing)) sigs

1111− ]

1112−instance ToHie (RScoped (NHsValBindsLR GhcRn)) where

1113− toHie (RS sc (NValBinds binds sigs)) = concatM $

1114− [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)

1115− , toHie $ fmap (SC (SI BindSig Nothing)) sigs

1116− ]

1117−

1118−instance ( ToHie (RContext (LHsRecField a arg))

1119− ) => ToHie (RContext (HsRecFields a arg)) where

1120− toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields

1121−

1122−instance ( ToHie (RFContext (Located label))

1123− , ToHie arg

1124− , HasLoc arg

1125− , Data label

1126− , Data arg

1127− ) => ToHie (RContext (LHsRecField' label arg)) where

1128− toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of

1129− HsRecField label expr _ ->

1130− [ toHie $ RFC c (getRealSpan $ loc expr) label

1131− , toHie expr

1132− ]

1133−

1134−removeDefSrcSpan :: Name -> Name

1135−removeDefSrcSpan n = setNameLoc n noSrcSpan

1136−

1137−instance ToHie (RFContext (LFieldOcc GhcRn)) where

1138− toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1139− FieldOcc name _ ->

1140− [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)

1141− ]

1142− XFieldOcc _ -> []

1143−

1144−instance ToHie (RFContext (LFieldOcc GhcTc)) where

1145− toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1146− FieldOcc var _ ->

1147− let var' = setVarName var (removeDefSrcSpan $ varName var)

1148− in [ toHie $ C (RecField c rhs) (L nspan var')

1149− ]

1150− XFieldOcc _ -> []

1151−

1152−instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where

1153− toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1154− Unambiguous name _ ->

1155− [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name

1156− ]

1157− Ambiguous _name _ ->

1158− [ ]

1159− XAmbiguousFieldOcc _ -> []

1160−

1161−instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where

1162− toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1163− Unambiguous var _ ->

1164− let var' = setVarName var (removeDefSrcSpan $ varName var)

1165− in [ toHie $ C (RecField c rhs) (L nspan var')

1166− ]

1167− Ambiguous var _ ->

1168− let var' = setVarName var (removeDefSrcSpan $ varName var)

1169− in [ toHie $ C (RecField c rhs) (L nspan var')

1170− ]

1171− XAmbiguousFieldOcc _ -> []

1172−

1173−instance ( a ~ GhcPass p

1174− , ToHie (PScoped (LPat a))

1175− , ToHie (BindContext (LHsBind a))

1176− , ToHie (LHsExpr a)

1177− , ToHie (SigContext (LSig a))

1178− , ToHie (RScoped (HsValBindsLR a a))

1179− , Data (StmtLR a a (Located (HsExpr a)))

1180− , Data (HsLocalBinds a)

1181− ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where

1182− toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM

1183− [ toHie $ PS Nothing sc NoScope pat

1184− , toHie expr

1185− ]

1186− toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM

1187− [ toHie $ listScopes NoScope stmts

1188− , toHie $ PS Nothing sc NoScope pat

1189− ]

1190− toHie (RS _ (XApplicativeArg _)) = pure []

1191−

1192−instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where

1193− toHie (PrefixCon args) = toHie args

1194− toHie (RecCon rec) = toHie rec

1195− toHie (InfixCon a b) = concatM [ toHie a, toHie b]

1196−

1197−instance ( ToHie (LHsCmd a)

1198− , Data (HsCmdTop a)

1199− ) => ToHie (LHsCmdTop a) where

1200− toHie (L span top) = concatM $ makeNode top span : case top of

1201− HsCmdTop _ cmd ->

1202− [ toHie cmd

1203− ]

1204− XCmdTop _ -> []

1205−

1206−instance ( a ~ GhcPass p

1207− , ToHie (PScoped (LPat a))

1208− , ToHie (BindContext (LHsBind a))

1209− , ToHie (LHsExpr a)

1210− , ToHie (MatchGroup a (LHsCmd a))

1211− , ToHie (SigContext (LSig a))

1212− , ToHie (RScoped (HsValBindsLR a a))

1213− , Data (HsCmd a)

1214− , Data (HsCmdTop a)

1215− , Data (StmtLR a a (Located (HsCmd a)))

1216− , Data (HsLocalBinds a)

1217− , Data (StmtLR a a (Located (HsExpr a)))

1218− ) => ToHie (LHsCmd (GhcPass p)) where

1219− toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of

1220− HsCmdArrApp _ a b _ _ ->

1221− [ toHie a

1222− , toHie b

1223− ]

1224− HsCmdArrForm _ a _ _ cmdtops ->

1225− [ toHie a

1226− , toHie cmdtops

1227− ]

1228− HsCmdApp _ a b ->

1229− [ toHie a

1230− , toHie b

1231− ]

1232− HsCmdLam _ mg ->

1233− [ toHie mg

1234− ]

1235− HsCmdPar _ a ->

1236− [ toHie a

1237− ]

1238− HsCmdCase _ expr alts ->

1239− [ toHie expr

1240− , toHie alts

1241− ]

1242− HsCmdIf _ _ a b c ->

1243− [ toHie a

1244− , toHie b

1245− , toHie c

1246− ]

1247− HsCmdLet _ binds cmd' ->

1248− [ toHie $ RS (mkLScope cmd') binds

1249− , toHie cmd'

1250− ]

1251− HsCmdDo _ (L ispan stmts) ->

1252− [ pure $ locOnly ispan

1253− , toHie $ listScopes NoScope stmts

1254− ]

1255− HsCmdWrap _ _ _ -> []

1256− XCmd _ -> []

1257−

1258−instance ToHie (TyClGroup GhcRn) where

1259− toHie TyClGroup{ group_tyclds = classes

1260− , group_roles = roles

1261− , group_kisigs = sigs

1262− , group_instds = instances } =

1263− concatM

1264− [ toHie classes

1265− , toHie sigs

1266− , toHie roles

1267− , toHie instances

1268− ]

1269− toHie (XTyClGroup _) = pure []

1270−

1271−instance ToHie (LTyClDecl GhcRn) where

1272− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1273− FamDecl {tcdFam = fdecl} ->

1274− [ toHie (L span fdecl)

1275− ]

1276− SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->

1277− [ toHie $ C (Decl SynDec $ getRealSpan span) name

1278− , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars

1279− , toHie typ

1280− ]

1281− DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->

1282− [ toHie $ C (Decl DataDec $ getRealSpan span) name

1283− , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars

1284− , toHie defn

1285− ]

1286− where

1287− quant_scope = mkLScope $ dd_ctxt defn

1288− rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc

1289− sig_sc = maybe NoScope mkLScope $ dd_kindSig defn

1290− con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn

1291− deriv_sc = mkLScope $ dd_derivs defn

1292− ClassDecl { tcdCtxt = context

1293− , tcdLName = name

1294− , tcdTyVars = vars

1295− , tcdFDs = deps

1296− , tcdSigs = sigs

1297− , tcdMeths = meths

1298− , tcdATs = typs

1299− , tcdATDefs = deftyps

1300− } ->

1301− [ toHie $ C (Decl ClassDec $ getRealSpan span) name

1302− , toHie context

1303− , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars

1304− , toHie deps

1305− , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs

1306− , toHie $ fmap (BC InstanceBind ModuleScope) meths

1307− , toHie typs

1308− , concatMapM (pure . locOnly . getLoc) deftyps

1309− , toHie deftyps

1310− ]

1311− where

1312− context_scope = mkLScope context

1313− rhs_scope = foldl1' combineScopes $ map mkScope

1314− [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]

1315− XTyClDecl _ -> []

1316−

1317−instance ToHie (LFamilyDecl GhcRn) where

1318− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1319− FamilyDecl _ info name vars _ sig inj ->

1320− [ toHie $ C (Decl FamDec $ getRealSpan span) name

1321− , toHie $ TS (ResolvedScopes [rhsSpan]) vars

1322− , toHie info

1323− , toHie $ RS injSpan sig

1324− , toHie inj

1325− ]

1326− where

1327− rhsSpan = sigSpan `combineScopes` injSpan

1328− sigSpan = mkScope $ getLoc sig

1329− injSpan = maybe NoScope (mkScope . getLoc) inj

1330− XFamilyDecl _ -> []

1331−

1332−instance ToHie (FamilyInfo GhcRn) where

1333− toHie (ClosedTypeFamily (Just eqns)) = concatM $

1334− [ concatMapM (pure . locOnly . getLoc) eqns

1335− , toHie $ map go eqns

1336− ]

1337− where

1338− go (L l ib) = TS (ResolvedScopes [mkScope l]) ib

1339− toHie _ = pure []

1340−

1341−instance ToHie (RScoped (LFamilyResultSig GhcRn)) where

1342− toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of

1343− NoSig _ ->

1344− []

1345− KindSig _ k ->

1346− [ toHie k

1347− ]

1348− TyVarSig _ bndr ->

1349− [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr

1350− ]

1351− XFamilyResultSig _ -> []

1352−

1353−instance ToHie (Located (FunDep (Located Name))) where

1354− toHie (L span fd@(lhs, rhs)) = concatM $

1355− [ makeNode fd span

1356− , toHie $ map (C Use) lhs

1357− , toHie $ map (C Use) rhs

1358− ]

1359−

1360−instance (ToHie rhs, HasLoc rhs)

1361− => ToHie (TScoped (FamEqn GhcRn rhs)) where

1362− toHie (TS _ f) = toHie f

1363−

1364−instance (ToHie rhs, HasLoc rhs)

1365− => ToHie (FamEqn GhcRn rhs) where

1366− toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $

1367− [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var

1368− , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1369− , toHie pats

1370− , toHie rhs

1371− ]

1372− where scope = combineScopes patsScope rhsScope

1373− patsScope = mkScope (loc pats)

1374− rhsScope = mkScope (loc rhs)

1375− toHie (XFamEqn _) = pure []

1376−

1377−instance ToHie (LInjectivityAnn GhcRn) where

1378− toHie (L span ann) = concatM $ makeNode ann span : case ann of

1379− InjectivityAnn lhs rhs ->

1380− [ toHie $ C Use lhs

1381− , toHie $ map (C Use) rhs

1382− ]

1383−

1384−instance ToHie (HsDataDefn GhcRn) where

1385− toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM

1386− [ toHie ctx

1387− , toHie mkind

1388− , toHie cons

1389− , toHie derivs

1390− ]

1391− toHie (XHsDataDefn _) = pure []

1392−

1393−instance ToHie (HsDeriving GhcRn) where

1394− toHie (L span clauses) = concatM

1395− [ pure $ locOnly span

1396− , toHie clauses

1397− ]

1398−

1399−instance ToHie (LHsDerivingClause GhcRn) where

1400− toHie (L span cl) = concatM $ makeNode cl span : case cl of

1401− HsDerivingClause _ strat (L ispan tys) ->

1402− [ toHie strat

1403− , pure $ locOnly ispan

1404− , toHie $ map (TS (ResolvedScopes [])) tys

1405− ]

1406− XHsDerivingClause _ -> []

1407−

1408−instance ToHie (Located (DerivStrategy GhcRn)) where

1409− toHie (L span strat) = concatM $ makeNode strat span : case strat of

1410− StockStrategy -> []

1411− AnyclassStrategy -> []

1412− NewtypeStrategy -> []

1413− ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]

1414−

1415−instance ToHie (Located OverlapMode) where

1416− toHie (L span _) = pure $ locOnly span

1417−

1418−instance ToHie (LConDecl GhcRn) where

1419− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1420− ConDeclGADT { con_names = names, con_qvars = qvars

1421− , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->

1422− [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names

1423− , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars

1424− , toHie ctx

1425− , toHie args

1426− , toHie typ

1427− ]

1428− where

1429− rhsScope = combineScopes argsScope tyScope

1430− ctxScope = maybe NoScope mkLScope ctx

1431− argsScope = condecl_scope args

1432− tyScope = mkLScope typ

1433− ConDeclH98 { con_name = name, con_ex_tvs = qvars

1434− , con_mb_cxt = ctx, con_args = dets } ->

1435− [ toHie $ C (Decl ConDec $ getRealSpan span) name

1436− , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars

1437− , toHie ctx

1438− , toHie dets

1439− ]

1440− where

1441− rhsScope = combineScopes ctxScope argsScope

1442− ctxScope = maybe NoScope mkLScope ctx

1443− argsScope = condecl_scope dets

1444− XConDecl _ -> []

1445− where condecl_scope args = case args of

1446− PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs

1447− InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)

1448− RecCon x -> mkLScope x

1449−

1450−instance ToHie (Located [LConDeclField GhcRn]) where

1451− toHie (L span decls) = concatM $

1452− [ pure $ locOnly span

1453− , toHie decls

1454− ]

1455−

1456−instance ( HasLoc thing

1457− , ToHie (TScoped thing)

1458− ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where

1459− toHie (TS sc (HsIB ibrn a)) = concatM $

1460− [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn

1461− , toHie $ TS sc a

1462− ]

1463− where span = loc a

1464− toHie (TS _ (XHsImplicitBndrs _)) = pure []

1465−

1466−instance ( HasLoc thing

1467− , ToHie (TScoped thing)

1468− ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where

1469− toHie (TS sc (HsWC names a)) = concatM $

1470− [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names

1471− , toHie $ TS sc a

1472− ]

1473− where span = loc a

1474− toHie (TS _ (XHsWildCardBndrs _)) = pure []

1475−

1476−instance ToHie (LStandaloneKindSig GhcRn) where

1477− toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]

1478−

1479−instance ToHie (StandaloneKindSig GhcRn) where

1480− toHie sig = concatM $ case sig of

1481− StandaloneKindSig _ name typ ->

1482− [ toHie $ C TyDecl name

1483− , toHie $ TS (ResolvedScopes []) typ

1484− ]

1485− XStandaloneKindSig _ -> []

1486−

1487−instance ToHie (SigContext (LSig GhcRn)) where

1488− toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of

1489− TypeSig _ names typ ->

1490− [ toHie $ map (C TyDecl) names

1491− , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1492− ]

1493− PatSynSig _ names typ ->

1494− [ toHie $ map (C TyDecl) names

1495− , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1496− ]

1497− ClassOpSig _ _ names typ ->

1498− [ case styp of

1499− ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names

1500− _ -> toHie $ map (C $ TyDecl) names

1501− , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ

1502− ]

1503− IdSig _ _ -> []

1504− FixSig _ fsig ->

1505− [ toHie $ L sp fsig

1506− ]

1507− InlineSig _ name _ ->

1508− [ toHie $ (C Use) name

1509− ]

1510− SpecSig _ name typs _ ->

1511− [ toHie $ (C Use) name

1512− , toHie $ map (TS (ResolvedScopes [])) typs

1513− ]

1514− SpecInstSig _ _ typ ->

1515− [ toHie $ TS (ResolvedScopes []) typ

1516− ]

1517− MinimalSig _ _ form ->

1518− [ toHie form

1519− ]

1520− SCCFunSig _ _ name mtxt ->

1521− [ toHie $ (C Use) name

1522− , pure $ maybe [] (locOnly . getLoc) mtxt

1523− ]

1524− CompleteMatchSig _ _ (L ispan names) typ ->

1525− [ pure $ locOnly ispan

1526− , toHie $ map (C Use) names

1527− , toHie $ fmap (C Use) typ

1528− ]

1529− XSig _ -> []

1530−

1531−instance ToHie (LHsType GhcRn) where

1532− toHie x = toHie $ TS (ResolvedScopes []) x

1533−

1534−instance ToHie (TScoped (LHsType GhcRn)) where

1535− toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of

1536− HsForAllTy _ _ bndrs body ->

1537− [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs

1538− , toHie body

1539− ]

1540− HsQualTy _ ctx body ->

1541− [ toHie ctx

1542− , toHie body

1543− ]

1544− HsTyVar _ _ var ->

1545− [ toHie $ C Use var

1546− ]

1547− HsAppTy _ a b ->

1548− [ toHie a

1549− , toHie b

1550− ]

1551− HsAppKindTy _ ty ki ->

1552− [ toHie ty

1553− , toHie $ TS (ResolvedScopes []) ki

1554− ]

1555− HsFunTy _ a b ->

1556− [ toHie a

1557− , toHie b

1558− ]

1559− HsListTy _ a ->

1560− [ toHie a

1561− ]

1562− HsTupleTy _ _ tys ->

1563− [ toHie tys

1564− ]

1565− HsSumTy _ tys ->

1566− [ toHie tys

1567− ]

1568− HsOpTy _ a op b ->

1569− [ toHie a

1570− , toHie $ C Use op

1571− , toHie b

1572− ]

1573− HsParTy _ a ->

1574− [ toHie a

1575− ]

1576− HsIParamTy _ ip ty ->

1577− [ toHie ip

1578− , toHie ty

1579− ]

1580− HsKindSig _ a b ->

1581− [ toHie a

1582− , toHie b

1583− ]

1584− HsSpliceTy _ a ->

1585− [ toHie $ L span a

1586− ]

1587− HsDocTy _ a _ ->

1588− [ toHie a

1589− ]

1590− HsBangTy _ _ ty ->

1591− [ toHie ty

1592− ]

1593− HsRecTy _ fields ->

1594− [ toHie fields

1595− ]

1596− HsExplicitListTy _ _ tys ->

1597− [ toHie tys

1598− ]

1599− HsExplicitTupleTy _ tys ->

1600− [ toHie tys

1601− ]

1602− HsTyLit _ _ -> []

1603− HsWildCardTy _ -> []

1604− HsStarTy _ _ -> []

1605− XHsType _ -> []

1606−

1607−instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where

1608− toHie (HsValArg tm) = toHie tm

1609− toHie (HsTypeArg _ ty) = toHie ty

1610− toHie (HsArgPar sp) = pure $ locOnly sp

1611−

1612−instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where

1613− toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1614− UserTyVar _ var ->

1615− [ toHie $ C (TyVarBind sc tsc) var

1616− ]

1617− KindedTyVar _ var kind ->

1618− [ toHie $ C (TyVarBind sc tsc) var

1619− , toHie kind

1620− ]

1621− XTyVarBndr _ -> []

1622−

1623−instance ToHie (TScoped (LHsQTyVars GhcRn)) where

1624− toHie (TS sc (HsQTvs implicits vars)) = concatM $

1625− [ pure $ bindingsOnly bindings

1626− , toHie $ tvScopes sc NoScope vars

1627− ]

1628− where

1629− varLoc = loc vars

1630− bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits

1631− toHie (TS _ (XLHsQTyVars _)) = pure []

1632−

1633−instance ToHie (LHsContext GhcRn) where

1634− toHie (L span tys) = concatM $

1635− [ pure $ locOnly span

1636− , toHie tys

1637− ]

1638−

1639−instance ToHie (LConDeclField GhcRn) where

1640− toHie (L span field) = concatM $ makeNode field span : case field of

1641− ConDeclField _ fields typ _ ->

1642− [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields

1643− , toHie typ

1644− ]

1645− XConDeclField _ -> []

1646−

1647−instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where

1648− toHie (From expr) = toHie expr

1649− toHie (FromThen a b) = concatM $

1650− [ toHie a

1651− , toHie b

1652− ]

1653− toHie (FromTo a b) = concatM $

1654− [ toHie a

1655− , toHie b

1656− ]

1657− toHie (FromThenTo a b c) = concatM $

1658− [ toHie a

1659− , toHie b

1660− , toHie c

1661− ]

1662−

1663−instance ToHie (LSpliceDecl GhcRn) where

1664− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1665− SpliceDecl _ splice _ ->

1666− [ toHie splice

1667− ]

1668− XSpliceDecl _ -> []

1669−

1670−instance ToHie (HsBracket a) where

1671− toHie _ = pure []

1672−

1673−instance ToHie PendingRnSplice where

1674− toHie _ = pure []

1675−

1676−instance ToHie PendingTcSplice where

1677− toHie _ = pure []

1678−

1679−instance ToHie (LBooleanFormula (Located Name)) where

1680− toHie (L span form) = concatM $ makeNode form span : case form of

1681− Var a ->

1682− [ toHie $ C Use a

1683− ]

1684− And forms ->

1685− [ toHie forms

1686− ]

1687− Or forms ->

1688− [ toHie forms

1689− ]

1690− Parens f ->

1691− [ toHie f

1692− ]

1693−

1694−instance ToHie (Located HsIPName) where

1695− toHie (L span e) = makeNode e span

1696−

1697−instance ( ToHie (LHsExpr a)

1698− , Data (HsSplice a)

1699− ) => ToHie (Located (HsSplice a)) where

1700− toHie (L span sp) = concatM $ makeNode sp span : case sp of

1701− HsTypedSplice _ _ _ expr ->

1702− [ toHie expr

1703− ]

1704− HsUntypedSplice _ _ _ expr ->

1705− [ toHie expr

1706− ]

1707− HsQuasiQuote _ _ _ ispan _ ->

1708− [ pure $ locOnly ispan

1709− ]

1710− HsSpliced _ _ _ ->

1711− []

1712− HsSplicedT _ ->

1713− []

1714− XSplice _ -> []

1715−

1716−instance ToHie (LRoleAnnotDecl GhcRn) where

1717− toHie (L span annot) = concatM $ makeNode annot span : case annot of

1718− RoleAnnotDecl _ var roles ->

1719− [ toHie $ C Use var

1720− , concatMapM (pure . locOnly . getLoc) roles

1721− ]

1722− XRoleAnnotDecl _ -> []

1723−

1724−instance ToHie (LInstDecl GhcRn) where

1725− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1726− ClsInstD _ d ->

1727− [ toHie $ L span d

1728− ]

1729− DataFamInstD _ d ->

1730− [ toHie $ L span d

1731− ]

1732− TyFamInstD _ d ->

1733− [ toHie $ L span d

1734− ]

1735− XInstDecl _ -> []

1736−

1737−instance ToHie (LClsInstDecl GhcRn) where

1738− toHie (L span decl) = concatM

1739− [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl

1740− , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl

1741− , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl

1742− , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl

1743− , toHie $ cid_tyfam_insts decl

1744− , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl

1745− , toHie $ cid_datafam_insts decl

1746− , toHie $ cid_overlap_mode decl

1747− ]

1748−

1749−instance ToHie (LDataFamInstDecl GhcRn) where

1750− toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1751−

1752−instance ToHie (LTyFamInstDecl GhcRn) where

1753− toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1754−

1755−instance ToHie (Context a)

1756− => ToHie (PatSynFieldContext (RecordPatSynField a)) where

1757− toHie (PSC sp (RecordPatSynField a b)) = concatM $

1758− [ toHie $ C (RecField RecFieldDecl sp) a

1759− , toHie $ C Use b

1760− ]

1761−

1762−instance ToHie (LDerivDecl GhcRn) where

1763− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1764− DerivDecl _ typ strat overlap ->

1765− [ toHie $ TS (ResolvedScopes []) typ

1766− , toHie strat

1767− , toHie overlap

1768− ]

1769− XDerivDecl _ -> []

1770−

1771−instance ToHie (LFixitySig GhcRn) where

1772− toHie (L span sig) = concatM $ makeNode sig span : case sig of

1773− FixitySig _ vars _ ->

1774− [ toHie $ map (C Use) vars

1775− ]

1776− XFixitySig _ -> []

1777−

1778−instance ToHie (LDefaultDecl GhcRn) where

1779− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1780− DefaultDecl _ typs ->

1781− [ toHie typs

1782− ]

1783− XDefaultDecl _ -> []

1784−

1785−instance ToHie (LForeignDecl GhcRn) where

1786− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1787− ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->

1788− [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name

1789− , toHie $ TS (ResolvedScopes []) sig

1790− , toHie fi

1791− ]

1792− ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->

1793− [ toHie $ C Use name

1794− , toHie $ TS (ResolvedScopes []) sig

1795− , toHie fe

1796− ]

1797− XForeignDecl _ -> []

1798−

1799−instance ToHie ForeignImport where

1800− toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $

1801− [ locOnly a

1802− , locOnly b

1803− , locOnly c

1804− ]

1805−

1806−instance ToHie ForeignExport where

1807− toHie (CExport (L a _) (L b _)) = pure $ concat $

1808− [ locOnly a

1809− , locOnly b

1810− ]

1811−

1812−instance ToHie (LWarnDecls GhcRn) where

1813− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1814− Warnings _ _ warnings ->

1815− [ toHie warnings

1816− ]

1817− XWarnDecls _ -> []

1818−

1819−instance ToHie (LWarnDecl GhcRn) where

1820− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1821− Warning _ vars _ ->

1822− [ toHie $ map (C Use) vars

1823− ]

1824− XWarnDecl _ -> []

1825−

1826−instance ToHie (LAnnDecl GhcRn) where

1827− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1828− HsAnnotation _ _ prov expr ->

1829− [ toHie prov

1830− , toHie expr

1831− ]

1832− XAnnDecl _ -> []

1833−

1834−instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where

1835− toHie (ValueAnnProvenance a) = toHie $ C Use a

1836− toHie (TypeAnnProvenance a) = toHie $ C Use a

1837− toHie ModuleAnnProvenance = pure []

1838−

1839−instance ToHie (LRuleDecls GhcRn) where

1840− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1841− HsRules _ _ rules ->

1842− [ toHie rules

1843− ]

1844− XRuleDecls _ -> []

1845−

1846−instance ToHie (LRuleDecl GhcRn) where

1847− toHie (L _ (XRuleDecl _)) = pure []

1848− toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM

1849− [ makeNode r span

1850− , pure $ locOnly $ getLoc rname

1851− , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1852− , toHie $ map (RS $ mkScope span) bndrs

1853− , toHie exprA

1854− , toHie exprB

1855− ]

1856− where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc

1857− bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)

1858− exprA_sc = mkLScope exprA

1859− exprB_sc = mkLScope exprB

1860−

1861−instance ToHie (RScoped (LRuleBndr GhcRn)) where

1862− toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1863− RuleBndr _ var ->

1864− [ toHie $ C (ValBind RegularBind sc Nothing) var

1865− ]

1866− RuleBndrSig _ var typ ->

1867− [ toHie $ C (ValBind RegularBind sc Nothing) var

1868− , toHie $ TS (ResolvedScopes [sc]) typ

1869− ]

1870− XRuleBndr _ -> []

1871−

1872−instance ToHie (LImportDecl GhcRn) where

1873− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1874− ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->

1875− [ toHie $ IEC Import name

1876− , toHie $ fmap (IEC ImportAs) as

1877− , maybe (pure []) goIE hidden

1878− ]

1879− XImportDecl _ -> []

1880− where

1881− goIE (hiding, (L sp liens)) = concatM $

1882− [ pure $ locOnly sp

1883− , toHie $ map (IEC c) liens

1884− ]

1885− where

1886− c = if hiding then ImportHiding else Import

1887−

1888−instance ToHie (IEContext (LIE GhcRn)) where

1889− toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of

1890− IEVar _ n ->

1891− [ toHie $ IEC c n

1892− ]

1893− IEThingAbs _ n ->

1894− [ toHie $ IEC c n

1895− ]

1896− IEThingAll _ n ->

1897− [ toHie $ IEC c n

1898− ]

1899− IEThingWith _ n _ ns flds ->

1900− [ toHie $ IEC c n

1901− , toHie $ map (IEC c) ns

1902− , toHie $ map (IEC c) flds

1903− ]

1904− IEModuleContents _ n ->

1905− [ toHie $ IEC c n

1906− ]

1907− IEGroup _ _ _ -> []

1908− IEDoc _ _ -> []

1909− IEDocNamed _ _ -> []

1910− XIE _ -> []

1911−

1912−instance ToHie (IEContext (LIEWrappedName Name)) where

1913− toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of

1914− IEName n ->

1915− [ toHie $ C (IEThing c) n

1916− ]

1917− IEPattern p ->

1918− [ toHie $ C (IEThing c) p

1919− ]

1920− IEType n ->

1921− [ toHie $ C (IEThing c) n

1922− ]

1923−

1924−instance ToHie (IEContext (Located (FieldLbl Name))) where

1925− toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of

1926− FieldLabel _ _ n ->

1927− [ toHie $ C (IEThing c) $ L span n

1928− ]

src-ghc88/Development/IDE/GHC/HieAst.hsdeleted−1789

@@ -1,1789 +0,0 @@

1−

2−{-

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

4−

5−Main functions for .hie file generation

6−-}

7−{- HLINT ignore -}

8−{-# LANGUAGE OverloadedStrings #-}

9−{-# LANGUAGE FlexibleInstances #-}

10−{-# LANGUAGE UndecidableInstances #-}

11−{-# LANGUAGE FlexibleContexts #-}

12−{-# LANGUAGE TypeSynonymInstances #-}

13−{-# LANGUAGE ScopedTypeVariables #-}

14−{-# LANGUAGE TypeFamilies #-}

15−{-# LANGUAGE TypeApplications #-}

16−{-# LANGUAGE AllowAmbiguousTypes #-}

17−{-# LANGUAGE ViewPatterns #-}

18−{-# LANGUAGE DeriveDataTypeable #-}

19−module Development.IDE.GHC.HieAst ( mkHieFile ) where

20−

21−import Avail ( Avails )

22−import Bag ( Bag, bagToList )

23−import BasicTypes

24−import BooleanFormula

25−import Class ( FunDep )

26−import CoreUtils ( exprType )

27−import ConLike ( conLikeName )

28−import Desugar ( deSugarExpr )

29−import FieldLabel

30−import HsSyn

31−import HscTypes

32−import Module ( ModuleName, ml_hs_file )

33−import MonadUtils ( concatMapM, liftIO )

34−import Name ( Name, nameSrcSpan, setNameLoc )

35−import SrcLoc

36−import TcHsSyn ( hsLitType, hsPatType )

37−import Type ( mkFunTys, Type )

38−import TysWiredIn ( mkListTy, mkSumTy )

39−import Var ( Id, Var, setVarName, varName, varType )

40−import TcRnTypes

41−import MkIface ( mkIfaceExports )

42−

43−import HieTypes

44−import HieUtils

45−

46−import qualified Data.Array as A

47−import qualified Data.ByteString as BS

48−import qualified Data.Map as M

49−import qualified Data.Set as S

50−import Data.Data ( Data, Typeable )

51−import Data.List (foldl', foldl1' )

52−import Data.Maybe ( listToMaybe )

53−import Control.Monad.Trans.Reader

54−import Control.Monad.Trans.Class ( lift )

55−

56−-- These synonyms match those defined in main/GHC.hs

57−type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn]

58− , Maybe [(LIE GhcRn, Avails)]

59− , Maybe LHsDocString )

60−type TypecheckedSource = LHsBinds GhcTc

61−

62−

63−{- Note [Name Remapping]

64−The Typechecker introduces new names for mono names in AbsBinds.

65−We don't care about the distinction between mono and poly bindings,

66−so we replace all occurrences of the mono name with the poly name.

67−-}

68−newtype HieState = HieState

69− { name_remapping :: M.Map Name Id

70− }

71−

72−initState :: HieState

73−initState = HieState M.empty

74−

75−class ModifyState a where -- See Note [Name Remapping]

76− addSubstitution :: a -> a -> HieState -> HieState

77−

78−instance ModifyState Name where

79− addSubstitution _ _ hs = hs

80−

81−instance ModifyState Id where

82− addSubstitution mono poly hs =

83− hs{name_remapping = M.insert (varName mono) poly (name_remapping hs)}

84−

85−modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState

86−modifyState = foldr go id

87− where

88− go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f

89− go _ f = f

90−

91−type HieM = ReaderT HieState Hsc

92−

93−-- | Construct an 'HieFile' from the outputs of the typechecker.

94−mkHieFile :: ModSummary

95− -> TcGblEnv

96− -> RenamedSource

97− -> BS.ByteString

98− -> Hsc HieFile

99−mkHieFile ms ts rs src = do

100− let tc_binds = tcg_binds ts

101− (asts', arr) <- getCompressedAsts tc_binds rs

102− let Just src_file = ml_hs_file $ ms_location ms

103− return $ HieFile

104− { hie_hs_file = src_file

105− , hie_module = ms_mod ms

106− , hie_types = arr

107− , hie_asts = asts'

108− -- mkIfaceExports sorts the AvailInfos for stability

109− , hie_exports = mkIfaceExports (tcg_exports ts)

110− , hie_hs_src = src

111− }

112−

113−getCompressedAsts :: TypecheckedSource -> RenamedSource

114− -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)

115−getCompressedAsts ts rs = do

116− asts <- enrichHie ts rs

117− return $ compressTypes asts

118−

119−enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)

120−enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do

121− tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts

122− rasts <- processGrp hsGrp

123− imps <- toHie $ filter (not . ideclImplicit . unLoc) imports

124− exps <- toHie $ fmap (map $ IEC Export . fst) exports

125− let spanFile children = case children of

126− [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)

127− _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)

128− (realSrcSpanEnd $ nodeSpan $ last children)

129−

130− modulify xs =

131− Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs

132−

133− asts = HieASTs

134− $ resolveTyVarScopes

135− $ M.map (modulify . mergeSortAsts)

136− $ M.fromListWith (++)

137− $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts

138−

139− flat_asts = concat

140− [ tasts

141− , rasts

142− , imps

143− , exps

144− ]

145− return asts

146− where

147− processGrp grp = concatM

148− [ toHie $ fmap (RS ModuleScope ) hs_valds grp

149− , toHie $ hs_splcds grp

150− , toHie $ hs_tyclds grp

151− , toHie $ hs_derivds grp

152− , toHie $ hs_fixds grp

153− , toHie $ hs_defds grp

154− , toHie $ hs_fords grp

155− , toHie $ hs_warnds grp

156− , toHie $ hs_annds grp

157− , toHie $ hs_ruleds grp

158− ]

159−

160−getRealSpan :: SrcSpan -> Maybe Span

161−getRealSpan (RealSrcSpan sp) = Just sp

162−getRealSpan _ = Nothing

163−

164−grhss_span :: GRHSs p body -> SrcSpan

165−grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)

166−grhss_span (XGRHSs _) = error "XGRHS has no span"

167−

168−bindingsOnly :: [Context Name] -> [HieAST a]

169−bindingsOnly [] = []

170−bindingsOnly (C c n : xs) = case nameSrcSpan n of

171− RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs

172− where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)

173− info = mempty{identInfo = S.singleton c}

174− _ -> bindingsOnly xs

175−

176−concatM :: Monad m => [m [a]] -> m [a]

177−concatM xs = concat <$> sequence xs

178−

179−{- Note [Capturing Scopes and other non local information]

180−toHie is a local tranformation, but scopes of bindings cannot be known locally,

181−hence we have to push the relevant info down into the binding nodes.

182−We use the following types (*Context and *Scoped) to wrap things and

183−carry the required info

184−(Maybe Span) always carries the span of the entire binding, including rhs

185−-}

186−data Context a = C ContextInfo a -- Used for names and bindings

187−

188−data RContext a = RC RecFieldContext a

189−data RFContext a = RFC RecFieldContext (Maybe Span) a

190−-- ^ context for record fields

191−

192−data IEContext a = IEC IEType a

193−-- ^ context for imports/exports

194−

195−data BindContext a = BC BindType Scope a

196−-- ^ context for imports/exports

197−

198−data PatSynFieldContext a = PSC (Maybe Span) a

199−-- ^ context for pattern synonym fields.

200−

201−data SigContext a = SC SigInfo a

202−-- ^ context for type signatures

203−

204−data SigInfo = SI SigType (Maybe Span)

205−

206−data SigType = BindSig | ClassSig | InstSig

207−

208−data RScoped a = RS Scope a

209−-- ^ Scope spans over everything to the right of a, (mostly) not

210−-- including a itself

211−-- (Includes a in a few special cases like recursive do bindings) or

212−-- let/where bindings

213−

214−-- | Pattern scope

215−data PScoped a = PS (Maybe Span)

216− Scope -- ^ use site of the pattern

217− Scope -- ^ pattern to the right of a, not including a

218− a

219− deriving (Typeable, Data) -- Pattern Scope

220−

221−{- Note [TyVar Scopes]

222−Due to -XScopedTypeVariables, type variables can be in scope quite far from

223−their original binding. We resolve the scope of these type variables

224−in a separate pass

225−-}

226−data TScoped a = TS TyVarScope a -- TyVarScope

227−

228−data TVScoped a = TVS TyVarScope Scope a -- TyVarScope

229−-- ^ First scope remains constant

230−-- Second scope is used to build up the scope of a tyvar over

231−-- things to its right, ala RScoped

232−

233−-- | Each element scopes over the elements to the right

234−listScopes :: Scope -> [Located a] -> [RScoped (Located a)]

235−listScopes _ [] = []

236−listScopes rhsScope [pat] = [RS rhsScope pat]

237−listScopes rhsScope (pat : pats) = RS sc pat : pats'

238− where

239− pats'@((RS scope p):_) = listScopes rhsScope pats

240− sc = combineScopes scope $ mkScope $ getLoc p

241−

242−-- | 'listScopes' specialised to 'PScoped' things

243−patScopes

244− :: Maybe Span

245− -> Scope

246− -> Scope

247− -> [LPat (GhcPass p)]

248− -> [PScoped (LPat (GhcPass p))]

249−patScopes rsp useScope patScope xs =

250− map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $

251− listScopes patScope (map dL xs)

252−

253−-- | 'listScopes' specialised to 'TVScoped' things

254−tvScopes

255− :: TyVarScope

256− -> Scope

257− -> [LHsTyVarBndr a]

258− -> [TVScoped (LHsTyVarBndr a)]

259−tvScopes tvScope rhsScope xs =

260− map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs

261−

262−{- Note [Scoping Rules for SigPat]

263−Explicitly quantified variables in pattern type signatures are not

264−brought into scope in the rhs, but implicitly quantified variables

265−are (HsWC and HsIB).

266−This is unlike other signatures, where explicitly quantified variables

267−are brought into the RHS Scope

268−For example

269−foo :: forall a. ...;

270−foo = ... -- a is in scope here

271−

272−bar (x :: forall a. a -> a) = ... -- a is not in scope here

273−-- ^ a is in scope here (pattern body)

274−

275−bax (x :: a) = ... -- a is in scope here

276−Because of HsWC and HsIB pass on their scope to their children

277−we must wrap the LHsType in pattern signatures in a

278−Shielded explictly, so that the HsWC/HsIB scope is not passed

279−on the the LHsType

280−-}

281−

282−data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead

283−

284−type family ProtectedSig a where

285− ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs

286− GhcRn

287− (Shielded (LHsType GhcRn)))

288− ProtectedSig GhcTc = NoExt

289−

290−class ProtectSig a where

291− protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a

292−

293−instance (HasLoc a) => HasLoc (Shielded a) where

294− loc (SH _ a) = loc a

295−

296−instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where

297− toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)

298−

299−instance ProtectSig GhcTc where

300− protectSig _ _ = NoExt

301−

302−instance ProtectSig GhcRn where

303− protectSig sc (HsWC a (HsIB b sig)) =

304− HsWC a (HsIB b (SH sc sig))

305− protectSig _ _ = error "protectSig not given HsWC (HsIB)"

306−

307−class HasLoc a where

308− -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can

309− -- know what their implicit bindings are scoping over

310− loc :: a -> SrcSpan

311−

312−instance HasLoc thing => HasLoc (TScoped thing) where

313− loc (TS _ a) = loc a

314−

315−instance HasLoc thing => HasLoc (PScoped thing) where

316− loc (PS _ _ _ a) = loc a

317−

318−instance HasLoc (LHsQTyVars GhcRn) where

319− loc (HsQTvs _ vs) = loc vs

320− loc _ = noSrcSpan

321−

322−instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where

323− loc (HsIB _ a) = loc a

324− loc _ = noSrcSpan

325−

326−instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where

327− loc (HsWC _ a) = loc a

328− loc _ = noSrcSpan

329−

330−instance HasLoc (Located a) where

331− loc (L l _) = l

332−

333−instance HasLoc a => HasLoc [a] where

334− loc [] = noSrcSpan

335− loc xs = foldl1' combineSrcSpans $ map loc xs

336−

337−instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where

338− loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]

339− loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans

340− [loc a, loc tvs, loc b, loc c]

341− loc _ = noSrcSpan

342−instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where

343− loc (HsValArg tm) = loc tm

344− loc (HsTypeArg _ ty) = loc ty

345− loc (HsArgPar sp) = sp

346−

347−instance HasLoc (HsDataDefn GhcRn) where

348− loc def@(HsDataDefn{}) = loc $ dd_cons def

349− -- Only used for data family instances, so we only need rhs

350− -- Most probably the rest will be unhelpful anyway

351− loc _ = noSrcSpan

352−

353−instance HasLoc (Pat (GhcPass a)) where

354− loc (dL -> L l _) = l

355−

356−-- | The main worker class

357−class ToHie a where

358− toHie :: a -> HieM [HieAST Type]

359−

360−-- | Used to collect type info

361−class Data a => HasType a where

362− getTypeNode :: a -> HieM [HieAST Type]

363−

364−instance (ToHie a) => ToHie [a] where

365− toHie = concatMapM toHie

366−

367−instance (ToHie a) => ToHie (Bag a) where

368− toHie = toHie . bagToList

369−

370−instance (ToHie a) => ToHie (Maybe a) where

371− toHie = maybe (pure []) toHie

372−

373−instance ToHie (Context (Located NoExt)) where

374− toHie _ = pure []

375−

376−instance ToHie (TScoped NoExt) where

377− toHie _ = pure []

378−

379−instance ToHie (IEContext (Located ModuleName)) where

380− toHie (IEC c (L (RealSrcSpan span) mname)) =

381− pure $ [Node (NodeInfo S.empty [] idents) span []]

382− where details = mempty{identInfo = S.singleton (IEThing c)}

383− idents = M.singleton (Left mname) details

384− toHie _ = pure []

385−

386−instance ToHie (Context (Located Var)) where

387− toHie c = case c of

388− C context (L (RealSrcSpan span) name')

389− -> do

390− m <- asks name_remapping

391− let name = M.findWithDefault name' (varName name') m

392− pure

393− [Node

394− (NodeInfo S.empty [] $

395− M.singleton (Right $ varName name)

396− (IdentifierDetails (Just $ varType name')

397− (S.singleton context)))

398− span

399− []]

400− _ -> pure []

401−

402−instance ToHie (Context (Located Name)) where

403− toHie c = case c of

404− C context (L (RealSrcSpan span) name') -> do

405− m <- asks name_remapping

406− let name = case M.lookup name' m of

407− Just var -> varName var

408− Nothing -> name'

409− pure

410− [Node

411− (NodeInfo S.empty [] $

412− M.singleton (Right name)

413− (IdentifierDetails Nothing

414− (S.singleton context)))

415− span

416− []]

417− _ -> pure []

418−

419−-- | Dummy instances - never called

420−instance ToHie (TScoped (LHsSigWcType GhcTc)) where

421− toHie _ = pure []

422−instance ToHie (TScoped (LHsWcType GhcTc)) where

423− toHie _ = pure []

424−instance ToHie (SigContext (LSig GhcTc)) where

425− toHie _ = pure []

426−instance ToHie (TScoped Type) where

427− toHie _ = pure []

428−

429−instance HasType (LHsBind GhcRn) where

430− getTypeNode (L spn bind) = makeNode bind spn

431−

432−instance HasType (LHsBind GhcTc) where

433− getTypeNode (L spn bind) = case bind of

434− FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)

435− _ -> makeNode bind spn

436−

437−instance HasType (LPat GhcRn) where

438− getTypeNode (dL -> L spn pat) = makeNode pat spn

439−

440−instance HasType (LPat GhcTc) where

441− getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)

442−

443−instance HasType (LHsExpr GhcRn) where

444− getTypeNode (L spn e) = makeNode e spn

445−

446−-- | This instance tries to construct 'HieAST' nodes which include the type of

447−-- the expression. It is not yet possible to do this efficiently for all

448−-- expression forms, so we skip filling in the type for those inputs.

449−--

450−-- 'HsApp', for example, doesn't have any type information available directly on

451−-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then

452−-- query the type of that. Yet both the desugaring call and the type query both

453−-- involve recursive calls to the function and argument! This is particularly

454−-- problematic when you realize that the HIE traversal will eventually visit

455−-- those nodes too and ask for their types again.

456−--

457−-- Since the above is quite costly, we just skip cases where computing the

458−-- expression's type is going to be expensive.

459−--

460−-- See #16233

461−instance HasType (LHsExpr GhcTc) where

462− getTypeNode e@(L spn e') = lift $

463− -- Some expression forms have their type immediately available

464− let tyOpt = case e' of

465− HsLit _ l -> Just (hsLitType l)

466− HsOverLit _ o -> Just (overLitType o)

467−

468− HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)

469− HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)

470− HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)

471−

472− ExplicitList ty _ _ -> Just (mkListTy ty)

473− ExplicitSum ty _ _ _ -> Just (mkSumTy ty)

474− HsDo ty _ _ -> Just ty

475− HsMultiIf ty _ -> Just ty

476−

477− _ -> Nothing

478−

479− in

480− case tyOpt of

481− _ | skipDesugaring e' -> fallback

482− | otherwise -> do

483− hs_env <- Hsc $ \e w -> return (e,w)

484− (_,mbe) <- liftIO $ deSugarExpr hs_env e

485− maybe fallback (makeTypeNode e' spn . exprType) mbe

486− where

487− fallback = makeNode e' spn

488−

489− matchGroupType :: MatchGroupTc -> Type

490− matchGroupType (MatchGroupTc args res) = mkFunTys args res

491−

492− -- | Skip desugaring of these expressions for performance reasons.

493− --

494− -- See impact on Haddock output (esp. missing type annotations or links)

495− -- before marking more things here as 'False'. See impact on Haddock

496− -- performance before marking more things as 'True'.

497− skipDesugaring :: HsExpr a -> Bool

498− skipDesugaring e = case e of

499− HsVar{} -> False

500− HsUnboundVar{} -> False

501− HsConLikeOut{} -> False

502− HsRecFld{} -> False

503− HsOverLabel{} -> False

504− HsIPVar{} -> False

505− HsWrap{} -> False

506− _ -> True

507−

508−instance ( ToHie (Context (Located (IdP a)))

509− , ToHie (MatchGroup a (LHsExpr a))

510− , ToHie (PScoped (LPat a))

511− , ToHie (GRHSs a (LHsExpr a))

512− , ToHie (LHsExpr a)

513− , ToHie (Located (PatSynBind a a))

514− , HasType (LHsBind a)

515− , ModifyState (IdP a)

516− , Data (HsBind a)

517− ) => ToHie (BindContext (LHsBind a)) where

518− toHie (BC context scope b@(L span bind)) =

519− concatM $ getTypeNode b : case bind of

520− FunBind{fun_id = name, fun_matches = matches} ->

521− [ toHie $ C (ValBind context scope $ getRealSpan span) name

522− , toHie matches

523− ]

524− PatBind{pat_lhs = lhs, pat_rhs = rhs} ->

525− [ toHie $ PS (getRealSpan span) scope NoScope lhs

526− , toHie rhs

527− ]

528− VarBind{var_rhs = expr} ->

529− [ toHie expr

530− ]

531− AbsBinds{abs_exports = xs, abs_binds = binds} ->

532− [ local (modifyState xs) $ -- Note [Name Remapping]

533− toHie $ fmap (BC context scope) binds

534− ]

535− PatSynBind _ psb ->

536− [ toHie $ L span psb -- PatSynBinds only occur at the top level

537− ]

538− XHsBindsLR _ -> []

539−

540−instance ( ToHie (LMatch a body)

541− ) => ToHie (MatchGroup a body) where

542− toHie mg = concatM $ case mg of

543− MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->

544− [ pure $ locOnly span

545− , toHie alts

546− ]

547− MG{} -> []

548− XMatchGroup _ -> []

549−

550−instance ( ToHie (Context (Located (IdP a)))

551− , ToHie (PScoped (LPat a))

552− , ToHie (HsPatSynDir a)

553− ) => ToHie (Located (PatSynBind a a)) where

554− toHie (L sp psb) = concatM $ case psb of

555− PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->

556− [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var

557− , toHie $ toBind dets

558− , toHie $ PS Nothing lhsScope NoScope pat

559− , toHie dir

560− ]

561− where

562− lhsScope = combineScopes varScope detScope

563− varScope = mkLScope var

564− detScope = case dets of

565− (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args

566− (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)

567− (RecCon r) -> foldr go NoScope r

568− go (RecordPatSynField a b) c = combineScopes c

569− $ combineScopes (mkLScope a) (mkLScope b)

570− detSpan = case detScope of

571− LocalScope a -> Just a

572− _ -> Nothing

573− toBind (PrefixCon args) = PrefixCon $ map (C Use) args

574− toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)

575− toBind (RecCon r) = RecCon $ map (PSC detSpan) r

576− XPatSynBind _ -> []

577−

578−instance ( ToHie (MatchGroup a (LHsExpr a))

579− ) => ToHie (HsPatSynDir a) where

580− toHie dir = case dir of

581− ExplicitBidirectional mg -> toHie mg

582− _ -> pure []

583−

584−instance ( a ~ GhcPass p

585− , ToHie body

586− , ToHie (HsMatchContext (NameOrRdrName (IdP a)))

587− , ToHie (PScoped (LPat a))

588− , ToHie (GRHSs a body)

589− , Data (Match a body)

590− ) => ToHie (LMatch (GhcPass p) body) where

591− toHie (L span m ) = concatM $ makeNode m span : case m of

592− Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->

593− [ toHie mctx

594− , let rhsScope = mkScope $ grhss_span grhss

595− in toHie $ patScopes Nothing rhsScope NoScope pats

596− , toHie grhss

597− ]

598− XMatch _ -> []

599−

600−instance ( ToHie (Context (Located a))

601− ) => ToHie (HsMatchContext a) where

602− toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name

603− toHie (StmtCtxt a) = toHie a

604− toHie _ = pure []

605−

606−instance ( ToHie (HsMatchContext a)

607− ) => ToHie (HsStmtContext a) where

608− toHie (PatGuard a) = toHie a

609− toHie (ParStmtCtxt a) = toHie a

610− toHie (TransStmtCtxt a) = toHie a

611− toHie _ = pure []

612−

613−instance ( a ~ GhcPass p

614− , ToHie (Context (Located (IdP a)))

615− , ToHie (RContext (HsRecFields a (PScoped (LPat a))))

616− , ToHie (LHsExpr a)

617− , ToHie (TScoped (LHsSigWcType a))

618− , ProtectSig a

619− , ToHie (TScoped (ProtectedSig a))

620− , HasType (LPat a)

621− , Data (HsSplice a)

622− ) => ToHie (PScoped (LPat (GhcPass p))) where

623− toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =

624− concatM $ getTypeNode lpat : case opat of

625− WildPat _ ->

626− []

627− VarPat _ lname ->

628− [ toHie $ C (PatternBind scope pscope rsp) lname

629− ]

630− LazyPat _ p ->

631− [ toHie $ PS rsp scope pscope p

632− ]

633− AsPat _ lname pat ->

634− [ toHie $ C (PatternBind scope

635− (combineScopes (mkLScope (dL pat)) pscope)

636− rsp)

637− lname

638− , toHie $ PS rsp scope pscope pat

639− ]

640− ParPat _ pat ->

641− [ toHie $ PS rsp scope pscope pat

642− ]

643− BangPat _ pat ->

644− [ toHie $ PS rsp scope pscope pat

645− ]

646− ListPat _ pats ->

647− [ toHie $ patScopes rsp scope pscope pats

648− ]

649− TuplePat _ pats _ ->

650− [ toHie $ patScopes rsp scope pscope pats

651− ]

652− SumPat _ pat _ _ ->

653− [ toHie $ PS rsp scope pscope pat

654− ]

655− ConPatIn c dets ->

656− [ toHie $ C Use c

657− , toHie $ contextify dets

658− ]

659− ConPatOut {pat_con = con, pat_args = dets}->

660− [ toHie $ C Use $ fmap conLikeName con

661− , toHie $ contextify dets

662− ]

663− ViewPat _ expr pat ->

664− [ toHie expr

665− , toHie $ PS rsp scope pscope pat

666− ]

667− SplicePat _ sp ->

668− [ toHie $ L ospan sp

669− ]

670− LitPat _ _ ->

671− []

672− NPat _ _ _ _ ->

673− []

674− NPlusKPat _ n _ _ _ _ ->

675− [ toHie $ C (PatternBind scope pscope rsp) n

676− ]

677− SigPat _ pat sig ->

678− [ toHie $ PS rsp scope pscope pat

679− , let cscope = mkLScope (dL pat) in

680− toHie $ TS (ResolvedScopes [cscope, scope, pscope])

681− (protectSig @a cscope sig)

682− -- See Note [Scoping Rules for SigPat]

683− ]

684− CoPat _ _ _ _ ->

685− []

686− XPat _ -> []

687− where

688− contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args

689− contextify (InfixCon a b) = InfixCon a' b'

690− where [a', b'] = patScopes rsp scope pscope [a,b]

691− contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r

692− contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a

693− where

694− go (RS fscope (L spn (HsRecField lbl pat pun))) =

695− L spn $ HsRecField lbl (PS rsp scope fscope pat) pun

696− scoped_fds = listScopes pscope fds

697−

698−instance ( ToHie body

699− , ToHie (LGRHS a body)

700− , ToHie (RScoped (LHsLocalBinds a))

701− ) => ToHie (GRHSs a body) where

702− toHie grhs = concatM $ case grhs of

703− GRHSs _ grhss binds ->

704− [ toHie grhss

705− , toHie $ RS (mkScope $ grhss_span grhs) binds

706− ]

707− XGRHSs _ -> []

708−

709−instance ( ToHie (Located body)

710− , ToHie (RScoped (GuardLStmt a))

711− , Data (GRHS a (Located body))

712− ) => ToHie (LGRHS a (Located body)) where

713− toHie (L span g) = concatM $ makeNode g span : case g of

714− GRHS _ guards body ->

715− [ toHie $ listScopes (mkLScope body) guards

716− , toHie body

717− ]

718− XGRHS _ -> []

719−

720−instance ( a ~ GhcPass p

721− , ToHie (Context (Located (IdP a)))

722− , HasType (LHsExpr a)

723− , ToHie (PScoped (LPat a))

724− , ToHie (MatchGroup a (LHsExpr a))

725− , ToHie (LGRHS a (LHsExpr a))

726− , ToHie (RContext (HsRecordBinds a))

727− , ToHie (RFContext (Located (AmbiguousFieldOcc a)))

728− , ToHie (ArithSeqInfo a)

729− , ToHie (LHsCmdTop a)

730− , ToHie (RScoped (GuardLStmt a))

731− , ToHie (RScoped (LHsLocalBinds a))

732− , ToHie (TScoped (LHsWcType (NoGhcTc a)))

733− , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))

734− , Data (HsExpr a)

735− , Data (HsSplice a)

736− , Data (HsTupArg a)

737− , Data (AmbiguousFieldOcc a)

738− ) => ToHie (LHsExpr (GhcPass p)) where

739− toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of

740− HsVar _ (L _ var) ->

741− [ toHie $ C Use (L mspan var)

742− -- Patch up var location since typechecker removes it

743− ]

744− HsUnboundVar _ _ ->

745− []

746− HsConLikeOut _ con ->

747− [ toHie $ C Use $ L mspan $ conLikeName con

748− ]

749− HsRecFld _ fld ->

750− [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)

751− ]

752− HsOverLabel _ _ _ -> []

753− HsIPVar _ _ -> []

754− HsOverLit _ _ -> []

755− HsLit _ _ -> []

756− HsLam _ mg ->

757− [ toHie mg

758− ]

759− HsLamCase _ mg ->

760− [ toHie mg

761− ]

762− HsApp _ a b ->

763− [ toHie a

764− , toHie b

765− ]

766− HsAppType _ expr sig ->

767− [ toHie expr

768− , toHie $ TS (ResolvedScopes []) sig

769− ]

770− OpApp _ a b c ->

771− [ toHie a

772− , toHie b

773− , toHie c

774− ]

775− NegApp _ a _ ->

776− [ toHie a

777− ]

778− HsPar _ a ->

779− [ toHie a

780− ]

781− SectionL _ a b ->

782− [ toHie a

783− , toHie b

784− ]

785− SectionR _ a b ->

786− [ toHie a

787− , toHie b

788− ]

789− ExplicitTuple _ args _ ->

790− [ toHie args

791− ]

792− ExplicitSum _ _ _ expr ->

793− [ toHie expr

794− ]

795− HsCase _ expr matches ->

796− [ toHie expr

797− , toHie matches

798− ]

799− HsIf _ _ a b c ->

800− [ toHie a

801− , toHie b

802− , toHie c

803− ]

804− HsMultiIf _ grhss ->

805− [ toHie grhss

806− ]

807− HsLet _ binds expr ->

808− [ toHie $ RS (mkLScope expr) binds

809− , toHie expr

810− ]

811− HsDo _ _ (L ispan stmts) ->

812− [ pure $ locOnly ispan

813− , toHie $ listScopes NoScope stmts

814− ]

815− ExplicitList _ _ exprs ->

816− [ toHie exprs

817− ]

818− RecordCon {rcon_con_name = name, rcon_flds = binds}->

819− [ toHie $ C Use name

820− , toHie $ RC RecFieldAssign $ binds

821− ]

822− RecordUpd {rupd_expr = expr, rupd_flds = upds}->

823− [ toHie expr

824− , toHie $ map (RC RecFieldAssign) upds

825− ]

826− ExprWithTySig _ expr sig ->

827− [ toHie expr

828− , toHie $ TS (ResolvedScopes [mkLScope expr]) sig

829− ]

830− ArithSeq _ _ info ->

831− [ toHie info

832− ]

833− HsSCC _ _ _ expr ->

834− [ toHie expr

835− ]

836− HsCoreAnn _ _ _ expr ->

837− [ toHie expr

838− ]

839− HsProc _ pat cmdtop ->

840− [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat

841− , toHie cmdtop

842− ]

843− HsStatic _ expr ->

844− [ toHie expr

845− ]

846− HsArrApp _ a b _ _ ->

847− [ toHie a

848− , toHie b

849− ]

850− HsArrForm _ expr _ cmds ->

851− [ toHie expr

852− , toHie cmds

853− ]

854− HsTick _ _ expr ->

855− [ toHie expr

856− ]

857− HsBinTick _ _ _ expr ->

858− [ toHie expr

859− ]

860− HsTickPragma _ _ _ _ expr ->

861− [ toHie expr

862− ]

863− HsWrap _ _ a ->

864− [ toHie $ L mspan a

865− ]

866− HsBracket _ b ->

867− [ toHie b

868− ]

869− HsRnBracketOut _ b p ->

870− [ toHie b

871− , toHie p

872− ]

873− HsTcBracketOut _ b p ->

874− [ toHie b

875− , toHie p

876− ]

877− HsSpliceE _ x ->

878− [ toHie $ L mspan x

879− ]

880− EWildPat _ -> []

881− EAsPat _ a b ->

882− [ toHie $ C Use a

883− , toHie b

884− ]

885− EViewPat _ a b ->

886− [ toHie a

887− , toHie b

888− ]

889− ELazyPat _ a ->

890− [ toHie a

891− ]

892− XExpr _ -> []

893−

894−instance ( a ~ GhcPass p

895− , ToHie (LHsExpr a)

896− , Data (HsTupArg a)

897− ) => ToHie (LHsTupArg (GhcPass p)) where

898− toHie (L span arg) = concatM $ makeNode arg span : case arg of

899− Present _ expr ->

900− [ toHie expr

901− ]

902− Missing _ -> []

903− XTupArg _ -> []

904−

905−instance ( a ~ GhcPass p

906− , ToHie (PScoped (LPat a))

907− , ToHie (LHsExpr a)

908− , ToHie (SigContext (LSig a))

909− , ToHie (RScoped (LHsLocalBinds a))

910− , ToHie (RScoped (ApplicativeArg a))

911− , ToHie (Located body)

912− , Data (StmtLR a a (Located body))

913− , Data (StmtLR a a (Located (HsExpr a)))

914− ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where

915− toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of

916− LastStmt _ body _ _ ->

917− [ toHie body

918− ]

919− BindStmt _ pat body _ _ ->

920− [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat

921− , toHie body

922− ]

923− ApplicativeStmt _ stmts _ ->

924− [ concatMapM (toHie . RS scope . snd) stmts

925− ]

926− BodyStmt _ body _ _ ->

927− [ toHie body

928− ]

929− LetStmt _ binds ->

930− [ toHie $ RS scope binds

931− ]

932− ParStmt _ parstmts _ _ ->

933− [ concatMapM (\(ParStmtBlock _ stmts _ _) ->

934− toHie $ listScopes NoScope stmts)

935− parstmts

936− ]

937− TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->

938− [ toHie $ listScopes scope stmts

939− , toHie using

940− , toHie by

941− ]

942− RecStmt {recS_stmts = stmts} ->

943− [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts

944− ]

945− XStmtLR _ -> []

946−

947−instance ( ToHie (LHsExpr a)

948− , ToHie (PScoped (LPat a))

949− , ToHie (BindContext (LHsBind a))

950− , ToHie (SigContext (LSig a))

951− , ToHie (RScoped (HsValBindsLR a a))

952− , Data (HsLocalBinds a)

953− ) => ToHie (RScoped (LHsLocalBinds a)) where

954− toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of

955− EmptyLocalBinds _ -> []

956− HsIPBinds _ _ -> []

957− HsValBinds _ valBinds ->

958− [ toHie $ RS (combineScopes scope $ mkScope sp)

959− valBinds

960− ]

961− XHsLocalBindsLR _ -> []

962−

963−instance ( ToHie (BindContext (LHsBind a))

964− , ToHie (SigContext (LSig a))

965− , ToHie (RScoped (XXValBindsLR a a))

966− ) => ToHie (RScoped (HsValBindsLR a a)) where

967− toHie (RS sc v) = concatM $ case v of

968− ValBinds _ binds sigs ->

969− [ toHie $ fmap (BC RegularBind sc) binds

970− , toHie $ fmap (SC (SI BindSig Nothing)) sigs

971− ]

972− XValBindsLR x -> [ toHie $ RS sc x ]

973−

974−instance ToHie (RScoped (NHsValBindsLR GhcTc)) where

975− toHie (RS sc (NValBinds binds sigs)) = concatM $

976− [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)

977− , toHie $ fmap (SC (SI BindSig Nothing)) sigs

978− ]

979−instance ToHie (RScoped (NHsValBindsLR GhcRn)) where

980− toHie (RS sc (NValBinds binds sigs)) = concatM $

981− [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)

982− , toHie $ fmap (SC (SI BindSig Nothing)) sigs

983− ]

984−

985−instance ( ToHie (RContext (LHsRecField a arg))

986− ) => ToHie (RContext (HsRecFields a arg)) where

987− toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields

988−

989−instance ( ToHie (RFContext (Located label))

990− , ToHie arg

991− , HasLoc arg

992− , Data label

993− , Data arg

994− ) => ToHie (RContext (LHsRecField' label arg)) where

995− toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of

996− HsRecField label expr _ ->

997− [ toHie $ RFC c (getRealSpan $ loc expr) label

998− , toHie expr

999− ]

1000−

1001−removeDefSrcSpan :: Name -> Name

1002−removeDefSrcSpan n = setNameLoc n noSrcSpan

1003−

1004−instance ToHie (RFContext (LFieldOcc GhcRn)) where

1005− toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1006− FieldOcc name _ ->

1007− [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)

1008− ]

1009− XFieldOcc _ -> []

1010−

1011−instance ToHie (RFContext (LFieldOcc GhcTc)) where

1012− toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1013− FieldOcc var _ ->

1014− let var' = setVarName var (removeDefSrcSpan $ varName var)

1015− in [ toHie $ C (RecField c rhs) (L nspan var')

1016− ]

1017− XFieldOcc _ -> []

1018−

1019−instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where

1020− toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1021− Unambiguous name _ ->

1022− [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name

1023− ]

1024− Ambiguous _name _ ->

1025− [ ]

1026− XAmbiguousFieldOcc _ -> []

1027−

1028−instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where

1029− toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1030− Unambiguous var _ ->

1031− let var' = setVarName var (removeDefSrcSpan $ varName var)

1032− in [ toHie $ C (RecField c rhs) (L nspan var')

1033− ]

1034− Ambiguous var _ ->

1035− let var' = setVarName var (removeDefSrcSpan $ varName var)

1036− in [ toHie $ C (RecField c rhs) (L nspan var')

1037− ]

1038− XAmbiguousFieldOcc _ -> []

1039−

1040−instance ( a ~ GhcPass p

1041− , ToHie (PScoped (LPat a))

1042− , ToHie (BindContext (LHsBind a))

1043− , ToHie (LHsExpr a)

1044− , ToHie (SigContext (LSig a))

1045− , ToHie (RScoped (HsValBindsLR a a))

1046− , Data (StmtLR a a (Located (HsExpr a)))

1047− , Data (HsLocalBinds a)

1048− ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where

1049− toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM

1050− [ toHie $ PS Nothing sc NoScope pat

1051− , toHie expr

1052− ]

1053− toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM

1054− [ toHie $ listScopes NoScope stmts

1055− , toHie $ PS Nothing sc NoScope pat

1056− ]

1057− toHie (RS _ (XApplicativeArg _)) = pure []

1058−

1059−instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where

1060− toHie (PrefixCon args) = toHie args

1061− toHie (RecCon rec) = toHie rec

1062− toHie (InfixCon a b) = concatM [ toHie a, toHie b]

1063−

1064−instance ( ToHie (LHsCmd a)

1065− , Data (HsCmdTop a)

1066− ) => ToHie (LHsCmdTop a) where

1067− toHie (L span top) = concatM $ makeNode top span : case top of

1068− HsCmdTop _ cmd ->

1069− [ toHie cmd

1070− ]

1071− XCmdTop _ -> []

1072−

1073−instance ( a ~ GhcPass p

1074− , ToHie (PScoped (LPat a))

1075− , ToHie (BindContext (LHsBind a))

1076− , ToHie (LHsExpr a)

1077− , ToHie (MatchGroup a (LHsCmd a))

1078− , ToHie (SigContext (LSig a))

1079− , ToHie (RScoped (HsValBindsLR a a))

1080− , Data (HsCmd a)

1081− , Data (HsCmdTop a)

1082− , Data (StmtLR a a (Located (HsCmd a)))

1083− , Data (HsLocalBinds a)

1084− , Data (StmtLR a a (Located (HsExpr a)))

1085− ) => ToHie (LHsCmd (GhcPass p)) where

1086− toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of

1087− HsCmdArrApp _ a b _ _ ->

1088− [ toHie a

1089− , toHie b

1090− ]

1091− HsCmdArrForm _ a _ _ cmdtops ->

1092− [ toHie a

1093− , toHie cmdtops

1094− ]

1095− HsCmdApp _ a b ->

1096− [ toHie a

1097− , toHie b

1098− ]

1099− HsCmdLam _ mg ->

1100− [ toHie mg

1101− ]

1102− HsCmdPar _ a ->

1103− [ toHie a

1104− ]

1105− HsCmdCase _ expr alts ->

1106− [ toHie expr

1107− , toHie alts

1108− ]

1109− HsCmdIf _ _ a b c ->

1110− [ toHie a

1111− , toHie b

1112− , toHie c

1113− ]

1114− HsCmdLet _ binds cmd' ->

1115− [ toHie $ RS (mkLScope cmd') binds

1116− , toHie cmd'

1117− ]

1118− HsCmdDo _ (L ispan stmts) ->

1119− [ pure $ locOnly ispan

1120− , toHie $ listScopes NoScope stmts

1121− ]

1122− HsCmdWrap _ _ _ -> []

1123− XCmd _ -> []

1124−

1125−instance ToHie (TyClGroup GhcRn) where

1126− toHie (TyClGroup _ classes roles instances) = concatM

1127− [ toHie classes

1128− , toHie roles

1129− , toHie instances

1130− ]

1131− toHie (XTyClGroup _) = pure []

1132−

1133−instance ToHie (LTyClDecl GhcRn) where

1134− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1135− FamDecl {tcdFam = fdecl} ->

1136− [ toHie (L span fdecl)

1137− ]

1138− SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->

1139− [ toHie $ C (Decl SynDec $ getRealSpan span) name

1140− , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars

1141− , toHie typ

1142− ]

1143− DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->

1144− [ toHie $ C (Decl DataDec $ getRealSpan span) name

1145− , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars

1146− , toHie defn

1147− ]

1148− where

1149− quant_scope = mkLScope $ dd_ctxt defn

1150− rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc

1151− sig_sc = maybe NoScope mkLScope $ dd_kindSig defn

1152− con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn

1153− deriv_sc = mkLScope $ dd_derivs defn

1154− ClassDecl { tcdCtxt = context

1155− , tcdLName = name

1156− , tcdTyVars = vars

1157− , tcdFDs = deps

1158− , tcdSigs = sigs

1159− , tcdMeths = meths

1160− , tcdATs = typs

1161− , tcdATDefs = deftyps

1162− } ->

1163− [ toHie $ C (Decl ClassDec $ getRealSpan span) name

1164− , toHie context

1165− , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars

1166− , toHie deps

1167− , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs

1168− , toHie $ fmap (BC InstanceBind ModuleScope) meths

1169− , toHie typs

1170− , concatMapM (pure . locOnly . getLoc) deftyps

1171− , toHie $ map (go . unLoc) deftyps

1172− ]

1173− where

1174− context_scope = mkLScope context

1175− rhs_scope = foldl1' combineScopes $ map mkScope

1176− [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]

1177−

1178− go :: TyFamDefltEqn GhcRn

1179− -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)

1180− go (FamEqn a var bndrs pat b rhs) =

1181− FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs

1182− go (XFamEqn NoExt) = XFamEqn NoExt

1183− XTyClDecl _ -> []

1184−

1185−instance ToHie (LFamilyDecl GhcRn) where

1186− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1187− FamilyDecl _ info name vars _ sig inj ->

1188− [ toHie $ C (Decl FamDec $ getRealSpan span) name

1189− , toHie $ TS (ResolvedScopes [rhsSpan]) vars

1190− , toHie info

1191− , toHie $ RS injSpan sig

1192− , toHie inj

1193− ]

1194− where

1195− rhsSpan = sigSpan `combineScopes` injSpan

1196− sigSpan = mkScope $ getLoc sig

1197− injSpan = maybe NoScope (mkScope . getLoc) inj

1198− XFamilyDecl _ -> []

1199−

1200−instance ToHie (FamilyInfo GhcRn) where

1201− toHie (ClosedTypeFamily (Just eqns)) = concatM $

1202− [ concatMapM (pure . locOnly . getLoc) eqns

1203− , toHie $ map go eqns

1204− ]

1205− where

1206− go (L l ib) = TS (ResolvedScopes [mkScope l]) ib

1207− toHie _ = pure []

1208−

1209−instance ToHie (RScoped (LFamilyResultSig GhcRn)) where

1210− toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of

1211− NoSig _ ->

1212− []

1213− KindSig _ k ->

1214− [ toHie k

1215− ]

1216− TyVarSig _ bndr ->

1217− [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr

1218− ]

1219− XFamilyResultSig _ -> []

1220−

1221−instance ToHie (Located (FunDep (Located Name))) where

1222− toHie (L span fd@(lhs, rhs)) = concatM $

1223− [ makeNode fd span

1224− , toHie $ map (C Use) lhs

1225− , toHie $ map (C Use) rhs

1226− ]

1227−

1228−instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs)

1229− => ToHie (TScoped (FamEqn GhcRn pats rhs)) where

1230− toHie (TS _ f) = toHie f

1231−

1232−instance ( ToHie pats

1233− , ToHie rhs

1234− , HasLoc pats

1235− , HasLoc rhs

1236− ) => ToHie (FamEqn GhcRn pats rhs) where

1237− toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $

1238− [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var

1239− , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1240− , toHie pats

1241− , toHie rhs

1242− ]

1243− where scope = combineScopes patsScope rhsScope

1244− patsScope = mkScope (loc pats)

1245− rhsScope = mkScope (loc rhs)

1246− toHie (XFamEqn _) = pure []

1247−

1248−instance ToHie (LInjectivityAnn GhcRn) where

1249− toHie (L span ann) = concatM $ makeNode ann span : case ann of

1250− InjectivityAnn lhs rhs ->

1251− [ toHie $ C Use lhs

1252− , toHie $ map (C Use) rhs

1253− ]

1254−

1255−instance ToHie (HsDataDefn GhcRn) where

1256− toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM

1257− [ toHie ctx

1258− , toHie mkind

1259− , toHie cons

1260− , toHie derivs

1261− ]

1262− toHie (XHsDataDefn _) = pure []

1263−

1264−instance ToHie (HsDeriving GhcRn) where

1265− toHie (L span clauses) = concatM

1266− [ pure $ locOnly span

1267− , toHie clauses

1268− ]

1269−

1270−instance ToHie (LHsDerivingClause GhcRn) where

1271− toHie (L span cl) = concatM $ makeNode cl span : case cl of

1272− HsDerivingClause _ strat (L ispan tys) ->

1273− [ toHie strat

1274− , pure $ locOnly ispan

1275− , toHie $ map (TS (ResolvedScopes [])) tys

1276− ]

1277− XHsDerivingClause _ -> []

1278−

1279−instance ToHie (Located (DerivStrategy GhcRn)) where

1280− toHie (L span strat) = concatM $ makeNode strat span : case strat of

1281− StockStrategy -> []

1282− AnyclassStrategy -> []

1283− NewtypeStrategy -> []

1284− ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]

1285−

1286−instance ToHie (Located OverlapMode) where

1287− toHie (L span _) = pure $ locOnly span

1288−

1289−instance ToHie (LConDecl GhcRn) where

1290− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1291− ConDeclGADT { con_names = names, con_qvars = qvars

1292− , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->

1293− [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names

1294− , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars

1295− , toHie ctx

1296− , toHie args

1297− , toHie typ

1298− ]

1299− where

1300− rhsScope = combineScopes argsScope tyScope

1301− ctxScope = maybe NoScope mkLScope ctx

1302− argsScope = condecl_scope args

1303− tyScope = mkLScope typ

1304− ConDeclH98 { con_name = name, con_ex_tvs = qvars

1305− , con_mb_cxt = ctx, con_args = dets } ->

1306− [ toHie $ C (Decl ConDec $ getRealSpan span) name

1307− , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars

1308− , toHie ctx

1309− , toHie dets

1310− ]

1311− where

1312− rhsScope = combineScopes ctxScope argsScope

1313− ctxScope = maybe NoScope mkLScope ctx

1314− argsScope = condecl_scope dets

1315− XConDecl _ -> []

1316− where condecl_scope args = case args of

1317− PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs

1318− InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)

1319− RecCon x -> mkLScope x

1320−

1321−instance ToHie (Located [LConDeclField GhcRn]) where

1322− toHie (L span decls) = concatM $

1323− [ pure $ locOnly span

1324− , toHie decls

1325− ]

1326−

1327−instance ( HasLoc thing

1328− , ToHie (TScoped thing)

1329− ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where

1330− toHie (TS sc (HsIB ibrn a)) = concatM $

1331− [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn

1332− , toHie $ TS sc a

1333− ]

1334− where span = loc a

1335− toHie (TS _ (XHsImplicitBndrs _)) = pure []

1336−

1337−instance ( HasLoc thing

1338− , ToHie (TScoped thing)

1339− ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where

1340− toHie (TS sc (HsWC names a)) = concatM $

1341− [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names

1342− , toHie $ TS sc a

1343− ]

1344− where span = loc a

1345− toHie (TS _ (XHsWildCardBndrs _)) = pure []

1346−

1347−instance ToHie (SigContext (LSig GhcRn)) where

1348− toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of

1349− TypeSig _ names typ ->

1350− [ toHie $ map (C TyDecl) names

1351− , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1352− ]

1353− PatSynSig _ names typ ->

1354− [ toHie $ map (C TyDecl) names

1355− , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1356− ]

1357− ClassOpSig _ _ names typ ->

1358− [ case styp of

1359− ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names

1360− _ -> toHie $ map (C $ TyDecl) names

1361− , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ

1362− ]

1363− IdSig _ _ -> []

1364− FixSig _ fsig ->

1365− [ toHie $ L sp fsig

1366− ]

1367− InlineSig _ name _ ->

1368− [ toHie $ (C Use) name

1369− ]

1370− SpecSig _ name typs _ ->

1371− [ toHie $ (C Use) name

1372− , toHie $ map (TS (ResolvedScopes [])) typs

1373− ]

1374− SpecInstSig _ _ typ ->

1375− [ toHie $ TS (ResolvedScopes []) typ

1376− ]

1377− MinimalSig _ _ form ->

1378− [ toHie form

1379− ]

1380− SCCFunSig _ _ name mtxt ->

1381− [ toHie $ (C Use) name

1382− , pure $ maybe [] (locOnly . getLoc) mtxt

1383− ]

1384− CompleteMatchSig _ _ (L ispan names) typ ->

1385− [ pure $ locOnly ispan

1386− , toHie $ map (C Use) names

1387− , toHie $ fmap (C Use) typ

1388− ]

1389− XSig _ -> []

1390−

1391−instance ToHie (LHsType GhcRn) where

1392− toHie x = toHie $ TS (ResolvedScopes []) x

1393−

1394−instance ToHie (TScoped (LHsType GhcRn)) where

1395− toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of

1396− HsForAllTy _ bndrs body ->

1397− [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs

1398− , toHie body

1399− ]

1400− HsQualTy _ ctx body ->

1401− [ toHie ctx

1402− , toHie body

1403− ]

1404− HsTyVar _ _ var ->

1405− [ toHie $ C Use var

1406− ]

1407− HsAppTy _ a b ->

1408− [ toHie a

1409− , toHie b

1410− ]

1411− HsAppKindTy _ ty ki ->

1412− [ toHie ty

1413− , toHie $ TS (ResolvedScopes []) ki

1414− ]

1415− HsFunTy _ a b ->

1416− [ toHie a

1417− , toHie b

1418− ]

1419− HsListTy _ a ->

1420− [ toHie a

1421− ]

1422− HsTupleTy _ _ tys ->

1423− [ toHie tys

1424− ]

1425− HsSumTy _ tys ->

1426− [ toHie tys

1427− ]

1428− HsOpTy _ a op b ->

1429− [ toHie a

1430− , toHie $ C Use op

1431− , toHie b

1432− ]

1433− HsParTy _ a ->

1434− [ toHie a

1435− ]

1436− HsIParamTy _ ip ty ->

1437− [ toHie ip

1438− , toHie ty

1439− ]

1440− HsKindSig _ a b ->

1441− [ toHie a

1442− , toHie b

1443− ]

1444− HsSpliceTy _ a ->

1445− [ toHie $ L span a

1446− ]

1447− HsDocTy _ a _ ->

1448− [ toHie a

1449− ]

1450− HsBangTy _ _ ty ->

1451− [ toHie ty

1452− ]

1453− HsRecTy _ fields ->

1454− [ toHie fields

1455− ]

1456− HsExplicitListTy _ _ tys ->

1457− [ toHie tys

1458− ]

1459− HsExplicitTupleTy _ tys ->

1460− [ toHie tys

1461− ]

1462− HsTyLit _ _ -> []

1463− HsWildCardTy _ -> []

1464− HsStarTy _ _ -> []

1465− XHsType _ -> []

1466−

1467−instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where

1468− toHie (HsValArg tm) = toHie tm

1469− toHie (HsTypeArg _ ty) = toHie ty

1470− toHie (HsArgPar sp) = pure $ locOnly sp

1471−

1472−instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where

1473− toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1474− UserTyVar _ var ->

1475− [ toHie $ C (TyVarBind sc tsc) var

1476− ]

1477− KindedTyVar _ var kind ->

1478− [ toHie $ C (TyVarBind sc tsc) var

1479− , toHie kind

1480− ]

1481− XTyVarBndr _ -> []

1482−

1483−instance ToHie (TScoped (LHsQTyVars GhcRn)) where

1484− toHie (TS sc (HsQTvs (HsQTvsRn implicits _) vars)) = concatM $

1485− [ pure $ bindingsOnly bindings

1486− , toHie $ tvScopes sc NoScope vars

1487− ]

1488− where

1489− varLoc = loc vars

1490− bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits

1491− toHie (TS _ (XLHsQTyVars _)) = pure []

1492−

1493−instance ToHie (LHsContext GhcRn) where

1494− toHie (L span tys) = concatM $

1495− [ pure $ locOnly span

1496− , toHie tys

1497− ]

1498−

1499−instance ToHie (LConDeclField GhcRn) where

1500− toHie (L span field) = concatM $ makeNode field span : case field of

1501− ConDeclField _ fields typ _ ->

1502− [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields

1503− , toHie typ

1504− ]

1505− XConDeclField _ -> []

1506−

1507−instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where

1508− toHie (From expr) = toHie expr

1509− toHie (FromThen a b) = concatM $

1510− [ toHie a

1511− , toHie b

1512− ]

1513− toHie (FromTo a b) = concatM $

1514− [ toHie a

1515− , toHie b

1516− ]

1517− toHie (FromThenTo a b c) = concatM $

1518− [ toHie a

1519− , toHie b

1520− , toHie c

1521− ]

1522−

1523−instance ToHie (LSpliceDecl GhcRn) where

1524− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1525− SpliceDecl _ splice _ ->

1526− [ toHie splice

1527− ]

1528− XSpliceDecl _ -> []

1529−

1530−instance ToHie (HsBracket a) where

1531− toHie _ = pure []

1532−

1533−instance ToHie PendingRnSplice where

1534− toHie _ = pure []

1535−

1536−instance ToHie PendingTcSplice where

1537− toHie _ = pure []

1538−

1539−instance ToHie (LBooleanFormula (Located Name)) where

1540− toHie (L span form) = concatM $ makeNode form span : case form of

1541− Var a ->

1542− [ toHie $ C Use a

1543− ]

1544− And forms ->

1545− [ toHie forms

1546− ]

1547− Or forms ->

1548− [ toHie forms

1549− ]

1550− Parens f ->

1551− [ toHie f

1552− ]

1553−

1554−instance ToHie (Located HsIPName) where

1555− toHie (L span e) = makeNode e span

1556−

1557−instance ( ToHie (LHsExpr a)

1558− , Data (HsSplice a)

1559− ) => ToHie (Located (HsSplice a)) where

1560− toHie (L span sp) = concatM $ makeNode sp span : case sp of

1561− HsTypedSplice _ _ _ expr ->

1562− [ toHie expr

1563− ]

1564− HsUntypedSplice _ _ _ expr ->

1565− [ toHie expr

1566− ]

1567− HsQuasiQuote _ _ _ ispan _ ->

1568− [ pure $ locOnly ispan

1569− ]

1570− HsSpliced _ _ _ ->

1571− []

1572− HsSplicedT _ ->

1573− []

1574− XSplice _ -> []

1575−

1576−instance ToHie (LRoleAnnotDecl GhcRn) where

1577− toHie (L span annot) = concatM $ makeNode annot span : case annot of

1578− RoleAnnotDecl _ var roles ->

1579− [ toHie $ C Use var

1580− , concatMapM (pure . locOnly . getLoc) roles

1581− ]

1582− XRoleAnnotDecl _ -> []

1583−

1584−instance ToHie (LInstDecl GhcRn) where

1585− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1586− ClsInstD _ d ->

1587− [ toHie $ L span d

1588− ]

1589− DataFamInstD _ d ->

1590− [ toHie $ L span d

1591− ]

1592− TyFamInstD _ d ->

1593− [ toHie $ L span d

1594− ]

1595− XInstDecl _ -> []

1596−

1597−instance ToHie (LClsInstDecl GhcRn) where

1598− toHie (L span decl) = concatM

1599− [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl

1600− , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl

1601− , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl

1602− , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl

1603− , toHie $ cid_tyfam_insts decl

1604− , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl

1605− , toHie $ cid_datafam_insts decl

1606− , toHie $ cid_overlap_mode decl

1607− ]

1608−

1609−instance ToHie (LDataFamInstDecl GhcRn) where

1610− toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1611−

1612−instance ToHie (LTyFamInstDecl GhcRn) where

1613− toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1614−

1615−instance ToHie (Context a)

1616− => ToHie (PatSynFieldContext (RecordPatSynField a)) where

1617− toHie (PSC sp (RecordPatSynField a b)) = concatM $

1618− [ toHie $ C (RecField RecFieldDecl sp) a

1619− , toHie $ C Use b

1620− ]

1621−

1622−instance ToHie (LDerivDecl GhcRn) where

1623− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1624− DerivDecl _ typ strat overlap ->

1625− [ toHie $ TS (ResolvedScopes []) typ

1626− , toHie strat

1627− , toHie overlap

1628− ]

1629− XDerivDecl _ -> []

1630−

1631−instance ToHie (LFixitySig GhcRn) where

1632− toHie (L span sig) = concatM $ makeNode sig span : case sig of

1633− FixitySig _ vars _ ->

1634− [ toHie $ map (C Use) vars

1635− ]

1636− XFixitySig _ -> []

1637−

1638−instance ToHie (LDefaultDecl GhcRn) where

1639− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1640− DefaultDecl _ typs ->

1641− [ toHie typs

1642− ]

1643− XDefaultDecl _ -> []

1644−

1645−instance ToHie (LForeignDecl GhcRn) where

1646− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1647− ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->

1648− [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name

1649− , toHie $ TS (ResolvedScopes []) sig

1650− , toHie fi

1651− ]

1652− ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->

1653− [ toHie $ C Use name

1654− , toHie $ TS (ResolvedScopes []) sig

1655− , toHie fe

1656− ]

1657− XForeignDecl _ -> []

1658−

1659−instance ToHie ForeignImport where

1660− toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $

1661− [ locOnly a

1662− , locOnly b

1663− , locOnly c

1664− ]

1665−

1666−instance ToHie ForeignExport where

1667− toHie (CExport (L a _) (L b _)) = pure $ concat $

1668− [ locOnly a

1669− , locOnly b

1670− ]

1671−

1672−instance ToHie (LWarnDecls GhcRn) where

1673− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1674− Warnings _ _ warnings ->

1675− [ toHie warnings

1676− ]

1677− XWarnDecls _ -> []

1678−

1679−instance ToHie (LWarnDecl GhcRn) where

1680− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1681− Warning _ vars _ ->

1682− [ toHie $ map (C Use) vars

1683− ]

1684− XWarnDecl _ -> []

1685−

1686−instance ToHie (LAnnDecl GhcRn) where

1687− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1688− HsAnnotation _ _ prov expr ->

1689− [ toHie prov

1690− , toHie expr

1691− ]

1692− XAnnDecl _ -> []

1693−

1694−instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where

1695− toHie (ValueAnnProvenance a) = toHie $ C Use a

1696− toHie (TypeAnnProvenance a) = toHie $ C Use a

1697− toHie ModuleAnnProvenance = pure []

1698−

1699−instance ToHie (LRuleDecls GhcRn) where

1700− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1701− HsRules _ _ rules ->

1702− [ toHie rules

1703− ]

1704− XRuleDecls _ -> []

1705−

1706−instance ToHie (LRuleDecl GhcRn) where

1707− toHie (L _ (XRuleDecl _)) = pure []

1708− toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM

1709− [ makeNode r span

1710− , pure $ locOnly $ getLoc rname

1711− , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1712− , toHie $ map (RS $ mkScope span) bndrs

1713− , toHie exprA

1714− , toHie exprB

1715− ]

1716− where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc

1717− bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)

1718− exprA_sc = mkLScope exprA

1719− exprB_sc = mkLScope exprB

1720−

1721−instance ToHie (RScoped (LRuleBndr GhcRn)) where

1722− toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1723− RuleBndr _ var ->

1724− [ toHie $ C (ValBind RegularBind sc Nothing) var

1725− ]

1726− RuleBndrSig _ var typ ->

1727− [ toHie $ C (ValBind RegularBind sc Nothing) var

1728− , toHie $ TS (ResolvedScopes [sc]) typ

1729− ]

1730− XRuleBndr _ -> []

1731−

1732−instance ToHie (LImportDecl GhcRn) where

1733− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1734− ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->

1735− [ toHie $ IEC Import name

1736− , toHie $ fmap (IEC ImportAs) as

1737− , maybe (pure []) goIE hidden

1738− ]

1739− XImportDecl _ -> []

1740− where

1741− goIE (hiding, (L sp liens)) = concatM $

1742− [ pure $ locOnly sp

1743− , toHie $ map (IEC c) liens

1744− ]

1745− where

1746− c = if hiding then ImportHiding else Import

1747−

1748−instance ToHie (IEContext (LIE GhcRn)) where

1749− toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of

1750− IEVar _ n ->

1751− [ toHie $ IEC c n

1752− ]

1753− IEThingAbs _ n ->

1754− [ toHie $ IEC c n

1755− ]

1756− IEThingAll _ n ->

1757− [ toHie $ IEC c n

1758− ]

1759− IEThingWith _ n _ ns flds ->

1760− [ toHie $ IEC c n

1761− , toHie $ map (IEC c) ns

1762− , toHie $ map (IEC c) flds

1763− ]

1764− IEModuleContents _ n ->

1765− [ toHie $ IEC c n

1766− ]

1767− IEGroup _ _ _ -> []

1768− IEDoc _ _ -> []

1769− IEDocNamed _ _ -> []

1770− XIE _ -> []

1771−

1772−instance ToHie (IEContext (LIEWrappedName Name)) where

1773− toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of

1774− IEName n ->

1775− [ toHie $ C (IEThing c) n

1776− ]

1777− IEPattern p ->

1778− [ toHie $ C (IEThing c) p

1779− ]

1780− IEType n ->

1781− [ toHie $ C (IEThing c) n

1782− ]

1783−

1784−instance ToHie (IEContext (Located (FieldLbl Name))) where

1785− toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of

1786− FieldLabel _ _ n ->

1787− [ toHie $ C (IEThing c) $ L span n

1788− ]

1789−

src/Development/IDE/Compat.hsdeleted−19

@@ -1,19 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−module Development.IDE.Compat

3− (

4− getProcessID

5− ) where

6−

7−#ifdef mingw32_HOST_OS

8−

9−import qualified System.Win32.Process as P (getCurrentProcessId)

10−getProcessID :: IO Int

11−getProcessID = fromIntegral <$> P.getCurrentProcessId

12−

13−#else

14−

15−import qualified System.Posix.Process as P (getProcessID)

16−getProcessID :: IO Int

17−getProcessID = fromIntegral <$> P.getProcessID

18−

19−#endif

src/Development/IDE/Core/Compile.hs+104−306

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

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

13 , compileModule

12 , compileModule

14 , parseModule

13 , parseModule

15 , typecheckModule

14 , typecheckModule

@@ -17,18 +16,10 @@ module Development.IDE.Core.Compile

17 , addRelativeImport

16 , addRelativeImport

18 , mkTcModuleResult

17 , mkTcModuleResult

19 , generateByteCode

18 , generateByteCode

20− , generateAndWriteHieFile

21− , generateAndWriteHiFile

22− , getModSummaryFromImports

23− , loadHieFile

24− , loadInterface

25− , loadDepModule

26− , loadModuleHome

27 ) where

19 ) where

29import Development.IDE.Core.RuleTypes

21import Development.IDE.Core.RuleTypes

30import Development.IDE.Core.Preprocessor

22import Development.IDE.Core.Preprocessor

31−import Development.IDE.Core.Shake

32import Development.IDE.GHC.Error

23import Development.IDE.GHC.Error

33import Development.IDE.GHC.Warnings

24import Development.IDE.GHC.Warnings

34import Development.IDE.Types.Diagnostics

25import Development.IDE.Types.Diagnostics

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

37import qualified GHC.LanguageExtensions.Type as GHC

28import qualified GHC.LanguageExtensions.Type as GHC

38import Development.IDE.Types.Options

29import Development.IDE.Types.Options

39import Development.IDE.Types.Location

30import Development.IDE.Types.Location

40−import Outputable

42#if MIN_GHC_API_VERSION(8,6,0)

32#if MIN_GHC_API_VERSION(8,6,0)

43import DynamicLoading (initializePlugins)

33import DynamicLoading (initializePlugins)

@@ -46,60 +36,42 @@ import DynamicLoading (initializePlugins)

46import GHC hiding (parseModule, typecheckModule)

36import GHC hiding (parseModule, typecheckModule)

47import qualified Parser

37import qualified Parser

48import Lexer

38import Lexer

49−#if MIN_GHC_API_VERSION(8,10,0)

50−#else

51import ErrUtils

39import ErrUtils

52−#endif

54−import Finder

41+import qualified GHC

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

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

57import GhcMonad

42import GhcMonad

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

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

59import qualified HeaderInfo as Hdr

44import qualified HeaderInfo as Hdr

60−import HscMain (hscInteractive, hscSimplify)

45+import HscMain (hscInteractive)

61−import LoadIface (readIface)

62−import qualified Maybes

63import MkIface

46import MkIface

64−import NameCache

65import StringBuffer as SB

47import StringBuffer as SB

66−import TcRnMonad (initIfaceLoad, tcg_th_coreplugins)

67−import TcIface (typecheckIface)

68import TidyPgm

48import TidyPgm

70−import Control.Exception.Safe

71import Control.Monad.Extra

50import Control.Monad.Extra

72import Control.Monad.Except

51import Control.Monad.Except

73import Control.Monad.Trans.Except

52import Control.Monad.Trans.Except

74−import Data.Bifunctor (first, second)

53+import Data.Function

54+import Data.Ord

75import qualified Data.Text as T

55import qualified Data.Text as T

76import Data.IORef

56import Data.IORef

77import Data.List.Extra

57import Data.List.Extra

78import Data.Maybe

58import Data.Maybe

59+import Data.Tuple.Extra

79import qualified Data.Map.Strict as Map

60import qualified Data.Map.Strict as Map

80import System.FilePath

61import System.FilePath

81−import System.Directory

82−import System.IO.Extra

83−import Data.Either.Extra (maybeToEither)

84−import Control.DeepSeq (rnf)

85−import Control.Exception (evaluate)

86−import Exception (ExceptionMonad)

89−-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.

64+-- | Given a string buffer, return a pre-processed @ParsedModule@.

90parseModule

65parseModule

91 :: IdeOptions

66 :: IdeOptions

92 -> HscEnv

67 -> HscEnv

93− -> [PackageName]

94 -> FilePath

68 -> FilePath

95 -> Maybe SB.StringBuffer

69 -> Maybe SB.StringBuffer

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

70+ -> IO ([FileDiagnostic], Maybe ParsedModule)

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

71+parseModule IdeOptions{..} env file =

98− fmap (either (, Nothing) id) $

72+ fmap (either (, Nothing) (second Just)) .

99− evalGhcEnv env $ runExceptT $ do

73+ -- We need packages since imports fail to resolve otherwise.

100− (contents, dflags) <- preprocessor filename mbContents

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

74+ runGhcEnv env . runExceptT . parseFileContents optPreprocessor file

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

103

104

105-- | Given a package identifier, what packages does it depend on

77-- | Given a package identifier, what packages does it depend on

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

110computePackageDeps env pkg = do

82computePackageDeps env pkg = do

111 let dflags = hsc_dflags env

83 let dflags = hsc_dflags env

112 case lookupInstalledPackage dflags pkg of

84 case lookupInstalledPackage dflags pkg of

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

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

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

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

115 Just pkgInfo -> return $ Right $ depends pkgInfo

87 Just pkgInfo -> return $ Right $ depends pkgInfo

116

89+

90+-- | Typecheck a single module using the supplied dependencies and packages.

91+typecheckModule

117−typecheckModule :: IdeDefer

92+ :: IdeDefer

118− -> HscEnv

93+ -> HscEnv

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

94+ -> [TcModuleResult]

120− -> ParsedModule

95+ -> ParsedModule

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

96+ -> IO ([FileDiagnostic], Maybe TcModuleResult)

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

97+typecheckModule (IdeDefer defer) packageState deps pm =

98+ let demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id

99+ in

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

100+ fmap (either (, Nothing) (second Just)) $

124− runGhcEnv hsc $

101+ runGhcEnv packageState $

125− catchSrcErrors "typecheck" $ do

102+ catchSrcErrors "typecheck" $ do

126− -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.

103+ setupEnv deps

127− -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.

128− -- Long-term we might just want to change the order returned by GetDependencies

129− let deps = reverse depsIn

130−

131− setupFinderCache (map fst deps)

132−

133− let modSummary = pm_mod_summary pm

104+ let modSummary = pm_mod_summary pm

134− dflags = ms_hspp_opts modSummary

105+ dflags = ms_hspp_opts modSummary

135−

136− mapM_ (uncurry loadDepModule . snd) deps

137− modSummary' <- initPlugins modSummary

106+ modSummary' <- initPlugins modSummary

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

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

139− GHC.typecheckModule $ enableTopLevelWarnings

108+ GHC.typecheckModule $ enableTopLevelWarnings

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

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

141− tcm2 <- mkTcModuleResult tcm

110+ tcm2 <- mkTcModuleResult tcm

142− let errorPipeline = unDefer . hideDiag dflags

111+ let errorPipeline = unDefer . hideDiag dflags

143− return (map errorPipeline warnings, tcm2)

112+ return (map errorPipeline warnings, tcm2)

144− where

145− demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id

146

113

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

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

148initPlugins modSummary = do

115initPlugins modSummary = do

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

154 return modSummary

121 return modSummary

155#endif

122#endif

156

123

157−-- | Whether we should run the -O0 simplifier when generating core.

158−--

159−-- This is required for template Haskell to work but we disable this in DAML.

160−-- See #256

161−newtype RunSimplifier = RunSimplifier Bool

162−

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

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

164-- provide errors.

125-- provide errors.

165compileModule

126compileModule

166− :: RunSimplifier

167− -> HscEnv

127+ :: HscEnv

168− -> [(ModSummary, HomeModInfo)]

128+ -> [TcModuleResult]

169 -> TcModuleResult

129 -> TcModuleResult

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

130+ -> IO ([FileDiagnostic], Maybe (SafeHaskellMode, CgGuts, ModDetails))

171−compileModule (RunSimplifier simplify) packageState deps tmr =

131+compileModule packageState deps tmr =

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

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

173− evalGhcEnv packageState $

133+ runGhcEnv packageState $

174 catchSrcErrors "compile" $ do

134 catchSrcErrors "compile" $ do

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

135+ setupEnv (deps ++ [tmr])

176

136

177 let tm = tmrModule tmr

137 let tm = tmrModule tmr

178 session <- getSession

138 session <- getSession

@@ -181,30 +141,20 @@ compileModule (RunSimplifier simplify) packageState deps tmr =

181 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}

141 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}

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

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

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

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

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

144+

185− desugared_guts <-

186− if simplify

187− then do

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

189− liftIO $ hscSimplify session plugins desugar

190− else pure desugar

191 -- give variables unique OccNames

145 -- give variables unique OccNames

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

146+ (guts, details) <- liftIO $ tidyProgram session desugar

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

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

194

148

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

149+generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO ([FileDiagnostic], Maybe Linkable)

196generateByteCode hscEnv deps tmr guts =

150generateByteCode hscEnv deps tmr guts =

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

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

198− evalGhcEnv hscEnv $

152+ runGhcEnv hscEnv $

199 catchSrcErrors "bytecode" $ do

153 catchSrcErrors "bytecode" $ do

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

154+ setupEnv (deps ++ [tmr])

201 session <- getSession

155 session <- getSession

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

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

203−#if MIN_GHC_API_VERSION(8,10,0)

204− liftIO $ hscInteractive session guts (GHC.ms_location $ tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)

205−#else

206− liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)

157+ liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)

207−#endif

208 let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr

158 let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr

209 let unlinked = BCOs bytecode sptEntries

159 let unlinked = BCOs bytecode sptEntries

210 let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]

160 let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]

@@ -226,10 +176,9 @@ demoteTypeErrorsToWarnings =

226enableTopLevelWarnings :: ParsedModule -> ParsedModule

176enableTopLevelWarnings :: ParsedModule -> ParsedModule

227enableTopLevelWarnings =

177enableTopLevelWarnings =

228 (update_pm_mod_summary . update_hspp_opts)

178 (update_pm_mod_summary . update_hspp_opts)

229− ((`wopt_set` Opt_WarnMissingPatternSynonymSignatures) .

230− (`wopt_set` Opt_WarnMissingSignatures))

179+ (`wopt_set` Opt_WarnMissingSignatures)

231 -- the line below would show also warnings for let bindings without signature

180 -- the line below would show also warnings for let bindings without signature

232− -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures)))

181+ -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures))

233

182

234update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary

183update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary

235update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}

184update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}

@@ -253,9 +202,9 @@ upgradeWarningToError (nfp, sh, fd) =

253hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)

202hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)

254hideDiag originalFlags (Reason warning, (nfp, _sh, fd))

203hideDiag originalFlags (Reason warning, (nfp, _sh, fd))

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

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

256−hideDiag _originalFlags t = t

205+hideDiag _originalFlags t = t

257

206

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

207+addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags

259addRelativeImport fp modu dflags = dflags

208addRelativeImport fp modu dflags = dflags

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

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

261

210

@@ -265,81 +214,25 @@ mkTcModuleResult

265 -> m TcModuleResult

214 -> m TcModuleResult

266mkTcModuleResult tcm = do

215mkTcModuleResult tcm = do

267 session <- getSession

216 session <- getSession

268− let sf = modInfoSafe (tm_checked_module_info tcm)

269−#if MIN_GHC_API_VERSION(8,10,0)

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

271−#else

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

217+ (iface, _) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv

273−#endif

274 let mod_info = HomeModInfo iface details Nothing

218 let mod_info = HomeModInfo iface details Nothing

275 return $ TcModuleResult tcm mod_info

219 return $ TcModuleResult tcm mod_info

276 where

220 where

277 (tcGblEnv, details) = tm_internals_ tcm

221 (tcGblEnv, details) = tm_internals_ tcm

278

222

279−atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO ()

280−atomicFileWrite targetPath write = do

281− let dir = takeDirectory targetPath

282− createDirectoryIfMissing True dir

283− (tempFilePath, cleanUp) <- newTempFileWithin dir

284− (write tempFilePath >> renameFile tempFilePath targetPath) `onException` cleanUp

285−

286−generateAndWriteHieFile :: HscEnv -> TypecheckedModule -> IO [FileDiagnostic]

287−generateAndWriteHieFile hscEnv tcm =

288− handleGenerationErrors dflags "extended interface generation" $ do

289− case tm_renamed_source tcm of

290− Just rnsrc -> do

291− hf <- runHsc hscEnv $

292− GHC.mkHieFile mod_summary (fst $ tm_internals_ tcm) rnsrc ""

293− atomicFileWrite targetPath $ flip GHC.writeHieFile hf

294− _ ->

295− return ()

296− where

297− dflags = hsc_dflags hscEnv

298− mod_summary = pm_mod_summary $ tm_parsed_module tcm

299− mod_location = ms_location mod_summary

300− targetPath = Compat.ml_hie_file mod_location

301−

302−generateAndWriteHiFile :: HscEnv -> TcModuleResult -> IO [FileDiagnostic]

303−generateAndWriteHiFile hscEnv tc =

304− handleGenerationErrors dflags "interface generation" $ do

305− atomicFileWrite targetPath $ \fp ->

306− writeIfaceFile dflags fp modIface

307− where

308− modIface = hm_iface $ tmrModInfo tc

309− modSummary = tmrModSummary tc

310− targetPath = withBootSuffix $ ml_hi_file $ ms_location $ tmrModSummary tc

311− withBootSuffix = case ms_hsc_src modSummary of

312− HsBootFile -> addBootSuffix

313− _ -> id

314− dflags = hsc_dflags hscEnv

315−

316−handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]

317−handleGenerationErrors dflags source action =

318− action >> return [] `catches`

319− [ Handler $ return . diagFromGhcException source dflags

320− , Handler $ return . diagFromString source DsError (noSpan "<internal>")

321− . (("Error during " ++ T.unpack source) ++) . show @SomeException

322− ]

323−

324−

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

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

326-- best understanding (!)

224-- best understanding (!)

327−--

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

329−-- HPT.

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

225+setupEnv :: GhcMonad m => [TcModuleResult] -> m ()

331−setupEnv tms = do

226+setupEnv tmsIn = do

332− setupFinderCache (map fst tms)

227+ -- if both a .hs-boot file and a .hs file appear here, we want to make sure that the .hs file

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

228+ -- takes precedence, so put the .hs-boot file earlier in the list

334− modifySession $ \e ->

229+ let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule

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

230+ tms = sortBy (compare `on` Down . isSourceFile) tmsIn

336

231

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

338−-- sorted.

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

340−setupFinderCache mss = do

341 session <- getSession

232 session <- getSession

342

233

234+ let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms

235+

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

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

344 let graph = mkModuleGraph mss

237 let graph = mkModuleGraph mss

345 setSession session { hsc_mod_graph = graph }

238 setSession session { hsc_mod_graph = graph }

@@ -358,40 +251,26 @@ setupFinderCache mss = do

358 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache

251 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache

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

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

360

253

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

255+ mapM_ loadModuleHome tms

256+

361

257

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

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

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

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

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

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

365-- modifies the session.

261-- modifies the session.

366−--

367−-- The order modules are loaded is important when there are hs-boot files.

368−-- In particular you should make sure to load the .hs version of a file after the

369−-- .hs-boot version.

370loadModuleHome

262loadModuleHome

371− :: HomeModInfo

263+ :: (GhcMonad m)

372− -> HscEnv

264+ => TcModuleResult

373− -> HscEnv

265+ -> m ()

374−loadModuleHome mod_info e =

266+loadModuleHome tmr = modifySession $ \e ->

375− e { hsc_HPT = addToHpt (hsc_HPT e) mod_name mod_info }

376− where

377− mod_name = moduleName $ mi_module $ hm_iface mod_info

378−

379−-- | Load module interface.

380−loadDepModuleIO :: ModIface -> Maybe Linkable -> HscEnv -> IO HscEnv

381−loadDepModuleIO iface linkable hsc = do

382− details <- liftIO $ fixIO $ \details -> do

383− let hsc' = hsc { hsc_HPT = addToHpt (hsc_HPT hsc) mod (HomeModInfo iface details linkable) }

267+ e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }

384− initIfaceLoad hsc' (typecheckIface iface)

268+ where

385− let mod_info = HomeModInfo iface details linkable

269+ ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr

386− return $ loadModuleHome mod_info hsc

270+ mod_info = tmrModInfo tmr

387− where

271+ mod = ms_mod_name ms

388− mod = moduleName $ mi_module iface

272+

389

273

390−loadDepModule :: GhcMonad m => ModIface -> Maybe Linkable -> m ()

391−loadDepModule iface linkable = do

392− e <- getSession

393− e' <- liftIO $ loadDepModuleIO iface linkable e

394− setSession e'

395

274

396-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's

275-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's

397-- name and its imports.

276-- name and its imports.

@@ -412,18 +291,30 @@ getImportsParsed dflags (L loc parsed) = do

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

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

413 ])

292 ])

414

293

294+

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

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

416getModSummaryFromBuffer

296getModSummaryFromBuffer

417 :: GhcMonad m

297 :: GhcMonad m

418 => FilePath

298 => FilePath

299+ -> SB.StringBuffer

419 -> DynFlags

300 -> DynFlags

420 -> GHC.ParsedSource

301 -> GHC.ParsedSource

421 -> ExceptT [FileDiagnostic] m ModSummary

302 -> ExceptT [FileDiagnostic] m ModSummary

422−getModSummaryFromBuffer fp dflags parsed = do

303+getModSummaryFromBuffer fp contents dflags parsed = do

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

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

424

305

425− modLoc <- liftIO $ mkHomeModLocation dflags modName fp

306+ let modLoc = ModLocation

307+ { ml_hs_file = Just fp

308+ , ml_hi_file = derivedFile "hi"

309+ , ml_obj_file = derivedFile "o"

310+#if MIN_GHC_API_VERSION(8,8,0)

311+ , ml_hie_file = derivedFile "hie"

312+#endif

313+ -- This does not consider the dflags configuration

314+ -- (-osuf and -hisuf, object and hi dir.s).

315+ -- However, we anyway don't want to generate them.

316+ }

426− let InstalledUnitId unitId = thisInstalledUnitId dflags

317+ InstalledUnitId unitId = thisInstalledUnitId dflags

427 return $ ModSummary

318 return $ ModSummary

428 { ms_mod = mkModule (fsToUnitId unitId) modName

319 { ms_mod = mkModule (fsToUnitId unitId) modName

429 , ms_location = modLoc

320 , ms_location = modLoc

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

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

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

436 , ms_hspp_file = fp

327 , ms_hspp_file = fp

437 , ms_hspp_opts = dflags

328 , ms_hspp_opts = dflags

438− , ms_hspp_buf = Nothing

329+ , ms_hspp_buf = Just contents

439

330

440 -- defaults:

331 -- defaults:

441 , ms_hsc_src = sourceType

332 , ms_hsc_src = sourceType

@@ -448,71 +339,27 @@ getModSummaryFromBuffer fp dflags parsed = do

448 , ms_parsed_mod = Nothing

339 , ms_parsed_mod = Nothing

449 }

340 }

450 where

341 where

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

342+ (sourceType, derivedFile) =

452−

343+ let (stem, ext) = splitExtension fp in

453−-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports.

344+ if "-boot" `isSuffixOf` ext

454−-- Runs preprocessors as needed.

345+ then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")

455−getModSummaryFromImports

346+ else (HsSrcFile , \newExt -> stem <.> newExt)

456− :: (HasDynFlags m, ExceptionMonad m, MonadIO m)

347+

457− => FilePath

348+

458− -> Maybe SB.StringBuffer

459− -> ExceptT [FileDiagnostic] m ModSummary

460−getModSummaryFromImports fp contents = do

461− (contents, dflags) <- preprocessor fp contents

462− (srcImports, textualImports, L _ moduleName) <-

463− ExceptT $ liftIO $ first (diagFromErrMsgs "parser" dflags) <$> GHC.getHeaderImports dflags contents fp fp

464−

465− -- Force bits that might keep the string buffer and DynFlags alive unnecessarily

466− liftIO $ evaluate $ rnf srcImports

467− liftIO $ evaluate $ rnf textualImports

468−

469− modLoc <- liftIO $ mkHomeModLocation dflags moduleName fp

470−

471− let mod = mkModule (thisPackage dflags) moduleName

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

473− summary =

474− ModSummary

475− { ms_mod = mod

476−#if MIN_GHC_API_VERSION(8,8,0)

477− , ms_hie_date = Nothing

478−#endif

479− , ms_hs_date = error "Rules should not depend on ms_hs_date"

480− -- When we are working with a virtual file we do not have a file date.

481− -- To avoid silent issues where something is not processed because the date

482− -- has not changed, we make sure that things blow up if they depend on the date.

483− , ms_hsc_src = sourceType

484− , ms_hspp_buf = Nothing

485− , ms_hspp_file = fp

486− , ms_hspp_opts = dflags

487− , ms_iface_date = Nothing

488− , ms_location = modLoc

489− , ms_obj_date = Nothing

490− , ms_parsed_mod = Nothing

491− , ms_srcimps = srcImports

492− , ms_textual_imps = textualImports

493− }

494− return summary

495−

496−

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

349+-- | Given a buffer, flags, file path and module summary, produce a

498−-- parsed module (or errors) and any parse warnings. Does not run any preprocessors

350+-- parsed module (or errors) and any parse warnings.

499parseFileContents

351parseFileContents

500 :: GhcMonad m

352 :: GhcMonad m

501 => (GHC.ParsedSource -> IdePreprocessedSource)

353 => (GHC.ParsedSource -> IdePreprocessedSource)

502− -> DynFlags -- ^ flags to use

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

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

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

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

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

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

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

507−parseFileContents customPreprocessor dflags comp_pkgs filename contents = do

357+parseFileContents customPreprocessor filename mbContents = do

358+ (contents, dflags) <- preprocessor filename mbContents

508 let loc = mkRealSrcLoc (mkFastString filename) 1 1

359 let loc = mkRealSrcLoc (mkFastString filename) 1 1

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

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

510−#if MIN_GHC_API_VERSION(8,10,0)

511− PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags

512−#else

513 PFailed _ locErr msgErr ->

361 PFailed _ locErr msgErr ->

514 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr

362 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr

515−#endif

516 POk pst rdr_module ->

363 POk pst rdr_module ->

517 let hpm_annotations =

364 let hpm_annotations =

518 (Map.fromListWith (++) $ annotations pst,

365 (Map.fromListWith (++) $ annotations pst,

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

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

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

537 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

384 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

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

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

539− let parsed' = removePackageImports comp_pkgs parsed

540 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

386 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

541− ms <- getModSummaryFromBuffer filename dflags parsed'

387+ ms <- getModSummaryFromBuffer filename contents dflags parsed

542 let pm =

388 let pm =

543 ParsedModule {

389 ParsedModule {

544 pm_mod_summary = ms

390 pm_mod_summary = ms

545− , pm_parsed_source = parsed'

391+ , pm_parsed_source = parsed

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

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

547 , pm_annotations = hpm_annotations

393 , pm_annotations = hpm_annotations

548 }

394 }

549 warnings = diagFromErrMsgs "parser" dflags warns

395 warnings = diagFromErrMsgs "parser" dflags warns

550 pure (warnings ++ preproc_warnings, pm)

396 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/Plugin/Completions/Logic.hs → src/Development/IDE/Core/Completions.hsrenamed+161−126

@@ -1,7 +1,5 @@

1−{-# LANGUAGE CPP #-}

2−#include "ghc-api-version.h"

3-- Mostly taken from "haskell-ide-engine"

1-- Mostly taken from "haskell-ide-engine"

4−module Development.IDE.Plugin.Completions.Logic (

2+module Development.IDE.Core.Completions (

5 CachedCompletions

3 CachedCompletions

6, cacheDataProducer

4, cacheDataProducer

7, WithSnippets(..)

5, WithSnippets(..)

@@ -9,15 +7,18 @@ module Development.IDE.Plugin.Completions.Logic (

9) where

7) where

11import Control.Applicative

9import Control.Applicative

12−import Data.Char (isSpace, isUpper)

10+import Data.Aeson

11+import Data.Aeson.Types

12+import Data.Char (isSpace)

13import Data.Generics

14−import Data.List.Extra as List hiding (stripPrefix)

14+import Data.List as List hiding (stripPrefix)

15import qualified Data.Map as Map

16import Data.Maybe (fromMaybe, mapMaybe)

17import qualified Data.Text as T

18import qualified Text.Fuzzy as Fuzzy

20import GHC

21+import Module

21import HscTypes

22import HscTypes

22import Name

23import Name

23import RdrName

24import RdrName

@@ -26,22 +27,59 @@ import Type

26import Var

27import Var

27import Packages

28import Packages

28import DynFlags

29import DynFlags

29−#if MIN_GHC_API_VERSION(8,10,0)

30+import ConLike

30−import Predicate (isDictTy)

31+import DataCon

31−import GHC.Platform

32+import SrcLoc as GHC

32−import Pair

33−import Coercion

34−#endif

36import Language.Haskell.LSP.Types

34import Language.Haskell.LSP.Types

37import Language.Haskell.LSP.Types.Capabilities

35import Language.Haskell.LSP.Types.Capabilities

38import qualified Language.Haskell.LSP.VFS as VFS

36import qualified Language.Haskell.LSP.VFS as VFS

39−import Development.IDE.Plugin.Completions.Types

37+import Development.IDE.Core.CompletionsTypes

40import Development.IDE.Spans.Documentation

38import Development.IDE.Spans.Documentation

41−import Development.IDE.GHC.Error

39+

42−import Development.IDE.Types.Options

40+-- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs

43−import Development.IDE.Spans.Common

41+

44−import Development.IDE.GHC.Util

42+data NameDetails

43+ = NameDetails Module OccName

44+ deriving (Eq)

45+

46+nsJSON :: NameSpace -> Value

47+nsJSON ns

48+ | isVarNameSpace ns = String "v"

49+ | isDataConNameSpace ns = String "c"

50+ | isTcClsNameSpace ns = String "t"

51+ | isTvNameSpace ns = String "z"

52+ | otherwise = error "namespace not recognized"

53+

54+parseNs :: Value -> Parser NameSpace

55+parseNs (String "v") = pure Name.varName

56+parseNs (String "c") = pure dataName

57+parseNs (String "t") = pure tcClsName

58+parseNs (String "z") = pure tvName

59+parseNs _ = mempty

60+

61+instance FromJSON NameDetails where

62+ parseJSON v@(Array _)

63+ = do

64+ [modname,modid,namesp,occname] <- parseJSON v

65+ mn <- parseJSON modname

66+ mid <- parseJSON modid

67+ ns <- parseNs namesp

68+ occn <- parseJSON occname

69+ pure $ NameDetails (mkModule (stringToUnitId mid) (mkModuleName mn)) (mkOccName ns occn)

70+ parseJSON _ = mempty

71+instance ToJSON NameDetails where

72+ toJSON (NameDetails mdl occ) = toJSON [toJSON mname,toJSON mid,nsJSON ns,toJSON occs]

73+ where

74+ mname = moduleNameString $ moduleName mdl

75+ mid = unitIdString $ moduleUnitId mdl

76+ ns = occNameSpace occ

77+ occs = occNameString occ

78+

79+safeTyThingId :: TyThing -> Maybe Id

80+safeTyThingId (AnId i) = Just i

81+safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc

82+safeTyThingId _ = Nothing

46-- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs

84-- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs

@@ -63,12 +101,12 @@ data Context = TypeContext

63-- i.e. where are the value decls and the type decls

101-- i.e. where are the value decls and the type decls

64getCContext :: Position -> ParsedModule -> Maybe Context

102getCContext :: Position -> ParsedModule -> Maybe Context

65getCContext pos pm

103getCContext pos pm

66− | Just (L r modName) <- moduleHeader

104+ | Just (L (RealSrcSpan r) modName) <- moduleHeader

67− , pos `isInsideSrcSpan` r

105+ , pos `isInsideRange` r

68 = Just (ModuleContext (moduleNameString modName))

106 = Just (ModuleContext (moduleNameString modName))

107

70− | Just (L r _) <- exportList

108+ | Just (L (RealSrcSpan r) _) <- exportList

71− , pos `isInsideSrcSpan` r

109+ , pos `isInsideRange` r

72 = Just ExportContext

110 = Just ExportContext

111

74 | Just ctx <- something (Nothing `mkQ` go `extQ` goInline) decl

112 | Just ctx <- something (Nothing `mkQ` go `extQ` goInline) decl

@@ -86,57 +124,75 @@ getCContext pos pm

86 imports = hsmodImports $ unLoc $ pm_parsed_source pm

124 imports = hsmodImports $ unLoc $ pm_parsed_source pm

125

88 go :: LHsDecl GhcPs -> Maybe Context

126 go :: LHsDecl GhcPs -> Maybe Context

89− go (L r SigD {})

127+ go (L (RealSrcSpan r) SigD {})

90− | pos `isInsideSrcSpan` r = Just TypeContext

128+ | pos `isInsideRange` r = Just TypeContext

91 | otherwise = Nothing

129 | otherwise = Nothing

92− go (L r GHC.ValD {})

130+ go (L (GHC.RealSrcSpan r) GHC.ValD {})

93− | pos `isInsideSrcSpan` r = Just ValueContext

131+ | pos `isInsideRange` r = Just ValueContext

94 | otherwise = Nothing

132 | otherwise = Nothing

95 go _ = Nothing

133 go _ = Nothing

134

97 goInline :: GHC.LHsType GhcPs -> Maybe Context

135 goInline :: GHC.LHsType GhcPs -> Maybe Context

98− goInline (GHC.L r _)

136+ goInline (GHC.L (GHC.RealSrcSpan r) _)

99− | pos `isInsideSrcSpan` r = Just TypeContext

137+ | pos `isInsideRange` r = Just TypeContext

138+ | otherwise = Nothing

100 goInline _ = Nothing

139 goInline _ = Nothing

101

140

141+ p `isInsideRange` r = sp <= p && p <= ep

142+ where (sp, ep) = unpackRealSrcSpan r

143+

144+ -- | Converts from one based tuple

145+ toPos :: (Int,Int) -> Position

146+ toPos (l,c) = Position (l-1) (c-1)

147+

148+ unpackRealSrcSpan :: GHC.RealSrcSpan -> (Position, Position)

149+ unpackRealSrcSpan rspan =

150+ (toPos (l1,c1),toPos (l2,c2))

151+ where s = GHC.realSrcSpanStart rspan

152+ l1 = GHC.srcLocLine s

153+ c1 = GHC.srcLocCol s

154+ e = GHC.realSrcSpanEnd rspan

155+ l2 = GHC.srcLocLine e

156+ c2 = GHC.srcLocCol e

157+

102 importGo :: GHC.LImportDecl GhcPs -> Maybe Context

158 importGo :: GHC.LImportDecl GhcPs -> Maybe Context

103− importGo (L r impDecl)

159+ importGo (L (RealSrcSpan r) impDecl)

104− | pos `isInsideSrcSpan` r

160+ | pos `isInsideRange` r

105 = importInline importModuleName (ideclHiding impDecl)

161 = importInline importModuleName (ideclHiding impDecl)

106 <|> Just (ImportContext importModuleName)

162 <|> Just (ImportContext importModuleName)

107

163

108 | otherwise = Nothing

164 | otherwise = Nothing

109 where importModuleName = moduleNameString $ unLoc $ ideclName impDecl

165 where importModuleName = moduleNameString $ unLoc $ ideclName impDecl

110

166

167+ importGo _ = Nothing

168+

111 importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context

169 importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context

112− importInline modName (Just (True, L r _))

170+ importInline modName (Just (True, L (RealSrcSpan r) _))

113− | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName

171+ | pos `isInsideRange` r = Just $ ImportHidingContext modName

114 | otherwise = Nothing

172 | otherwise = Nothing

115− importInline modName (Just (False, L r _))

173+ importInline modName (Just (False, L (RealSrcSpan r) _))

116− | pos `isInsideSrcSpan` r = Just $ ImportListContext modName

174+ | pos `isInsideRange` r = Just $ ImportListContext modName

117 | otherwise = Nothing

175 | otherwise = Nothing

118 importInline _ _ = Nothing

176 importInline _ _ = Nothing

119

177

178+type CompItemResolveData

179+ = Maybe NameDetails

180+

120−occNameToComKind :: Maybe T.Text -> OccName -> CompletionItemKind

181+occNameToComKind :: OccName -> CompletionItemKind

121−occNameToComKind ty oc

182+occNameToComKind oc

122− | isVarOcc oc = case occNameString oc of

123− i:_ | isUpper i -> CiConstructor

124− _ -> CiFunction

183+ | isVarOcc oc = CiFunction

125− | isTcOcc oc = case ty of

126− Just t

127− | "Constraint" `T.isSuffixOf` t

128− -> CiClass

184+ | isTcOcc oc = CiClass

129− _ -> CiStruct

130 | isDataOcc oc = CiConstructor

185 | isDataOcc oc = CiConstructor

131 | otherwise = CiVariable

186 | otherwise = CiVariable

132

187

133−mkCompl :: IdeOptions -> CompItem -> CompletionItem

188+mkCompl :: CompItem -> CompletionItem

134−mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} =

189+mkCompl CI{origName,importedFrom,thingType,label,isInfix,docs} =

135− CompletionItem label kind (List []) ((colon <>) <$> typeText)

190+ CompletionItem label kind (Just $ maybe "" (<>"\n") typeText <> importedFrom)

136− (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')

191+ (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs)

137 Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)

192 Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)

138− Nothing Nothing Nothing Nothing Nothing

193+ Nothing Nothing Nothing Nothing resolveData

139− where kind = Just $ occNameToComKind typeText $ occName origName

194+ where kind = Just $ occNameToComKind $ occName origName

195+ resolveData = Just (toJSON nameDets)

140 insertText = case isInfix of

196 insertText = case isInfix of

141 Nothing -> case getArgText <$> thingType of

197 Nothing -> case getArgText <$> thingType of

142 Nothing -> label

198 Nothing -> label

@@ -147,8 +203,11 @@ mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} =

147 typeText

203 typeText

148 | Just t <- thingType = Just . stripForall $ T.pack (showGhc t)

204 | Just t <- thingType = Just . stripForall $ T.pack (showGhc t)

149 | otherwise = Nothing

205 | otherwise = Nothing

150− docs' = ("*Defined in '" <> importedFrom <> "'*\n") : spanDocToMarkdown docs

206+ nameDets =

151− colon = if optNewColonConvention then ": " else ":: "

207+ case (thingType, nameModule_maybe origName) of

208+ (Just _,_) -> Nothing

209+ (Nothing, Nothing) -> Nothing

210+ (Nothing, Just mdl) -> Just (NameDetails mdl (nameOccName origName))

152

211

153stripForall :: T.Text -> T.Text

212stripForall :: T.Text -> T.Text

154stripForall t

213stripForall t

@@ -162,7 +221,7 @@ getArgText typ = argText

162 where

221 where

163 argTypes = getArgs typ

222 argTypes = getArgs typ

164 argText :: T.Text

223 argText :: T.Text

165− argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes

224+ argText = mconcat $ List.intersperse " " $ zipWith snippet [1..] argTypes

166 snippet :: Int -> Type -> T.Text

225 snippet :: Int -> Type -> T.Text

167 snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"

226 snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"

168 getArgs :: Type -> [Type]

227 getArgs :: Type -> [Type]

@@ -176,44 +235,40 @@ getArgText typ = argText

176 then getArgs ret

235 then getArgs ret

177 else Prelude.filter (not . isDictTy) args

236 else Prelude.filter (not . isDictTy) args

178 | isPiTy t = getArgs $ snd (splitPiTys t)

237 | isPiTy t = getArgs $ snd (splitPiTys t)

179−#if MIN_GHC_API_VERSION(8,10,0)

180− | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t

181− = getArgs t

182−#else

183 | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t)

238 | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t)

184−#endif

185 | otherwise = []

239 | otherwise = []

186

240

187mkModCompl :: T.Text -> CompletionItem

241mkModCompl :: T.Text -> CompletionItem

188mkModCompl label =

242mkModCompl label =

189− CompletionItem label (Just CiModule) (List []) Nothing

243+ CompletionItem label (Just CiModule) Nothing

190 Nothing Nothing Nothing Nothing Nothing Nothing Nothing

244 Nothing Nothing Nothing Nothing Nothing Nothing Nothing

191− Nothing Nothing Nothing Nothing Nothing

245+ Nothing Nothing Nothing Nothing (Just $ toJSON resolveData)

246+ where resolveData :: CompItemResolveData

247+ resolveData = Nothing

192

248

193mkImportCompl :: T.Text -> T.Text -> CompletionItem

249mkImportCompl :: T.Text -> T.Text -> CompletionItem

194mkImportCompl enteredQual label =

250mkImportCompl enteredQual label =

195− CompletionItem m (Just CiModule) (List []) (Just label)

251+ CompletionItem m (Just CiModule) (Just label)

196 Nothing Nothing Nothing Nothing Nothing Nothing Nothing

252 Nothing Nothing Nothing Nothing Nothing Nothing Nothing

197 Nothing Nothing Nothing Nothing Nothing

253 Nothing Nothing Nothing Nothing Nothing

198− where

254+ where

199 m = fromMaybe "" (T.stripPrefix enteredQual label)

255 m = fromMaybe "" (T.stripPrefix enteredQual label)

200

256

201mkExtCompl :: T.Text -> CompletionItem

257mkExtCompl :: T.Text -> CompletionItem

202mkExtCompl label =

258mkExtCompl label =

203− CompletionItem label (Just CiKeyword) (List []) Nothing

259+ CompletionItem label (Just CiKeyword) Nothing

204 Nothing Nothing Nothing Nothing Nothing Nothing Nothing

260 Nothing Nothing Nothing Nothing Nothing Nothing Nothing

205 Nothing Nothing Nothing Nothing Nothing

261 Nothing Nothing Nothing Nothing Nothing

206

262

207mkPragmaCompl :: T.Text -> T.Text -> CompletionItem

263mkPragmaCompl :: T.Text -> T.Text -> CompletionItem

208mkPragmaCompl label insertText =

264mkPragmaCompl label insertText =

209− CompletionItem label (Just CiKeyword) (List []) Nothing

265+ CompletionItem label (Just CiKeyword) Nothing

210 Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)

266 Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)

211 Nothing Nothing Nothing Nothing Nothing

267 Nothing Nothing Nothing Nothing Nothing

212

268

213−cacheDataProducer :: HscEnv -> TypecheckedModule -> [ParsedModule] -> IO CachedCompletions

269+cacheDataProducer :: DynFlags -> TypecheckedModule -> [TypecheckedModule] -> IO CachedCompletions

214−cacheDataProducer packageState tm deps = do

270+cacheDataProducer dflags tm tcs = do

215 let parsedMod = tm_parsed_module tm

271 let parsedMod = tm_parsed_module tm

216− dflags = hsc_dflags packageState

217 curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod

272 curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod

218 Just (_,limports,_,_) = tm_renamed_source tm

273 Just (_,limports,_,_) = tm_renamed_source tm

219

274

@@ -238,56 +293,42 @@ cacheDataProducer packageState tm deps = do

238 rdrEnv = tcg_rdr_env $ fst $ tm_internals_ tm

293 rdrEnv = tcg_rdr_env $ fst $ tm_internals_ tm

239 rdrElts = globalRdrEnvElts rdrEnv

294 rdrElts = globalRdrEnvElts rdrEnv

240

295

241− foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b

296+ getCompls :: [GlobalRdrElt] -> ([CompItem],QualCompls)

242− foldMapM f xs = foldr step return xs mempty where

297+ getCompls = foldMap getComplsForOne

243− step x r z = f x >>= \y -> r $! z `mappend` y

244

298

245− getCompls :: [GlobalRdrElt] -> IO ([CompItem],QualCompls)

246− getCompls = foldMapM getComplsForOne

247−

248− getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls)

299+ getComplsForOne :: GlobalRdrElt -> ([CompItem],QualCompls)

249 getComplsForOne (GRE n _ True _) =

300 getComplsForOne (GRE n _ True _) =

250 case lookupTypeEnv typeEnv n of

301 case lookupTypeEnv typeEnv n of

251 Just tt -> case safeTyThingId tt of

302 Just tt -> case safeTyThingId tt of

252− Just var -> (\x -> ([x],mempty)) <$> varToCompl var

303+ Just var -> ([varToCompl var],mempty)

253− Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n

304+ Nothing -> ([toCompItem curMod n],mempty)

254− Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n

305+ Nothing -> ([toCompItem curMod n],mempty)

255 getComplsForOne (GRE n _ False prov) =

306 getComplsForOne (GRE n _ False prov) =

256− flip foldMapM (map is_decl prov) $ \spec -> do

307+ flip foldMap (map is_decl prov) $ \spec ->

257− compItem <- toCompItem (is_mod spec) n

258 let unqual

308 let unqual

259 | is_qual spec = []

309 | is_qual spec = []

260− | otherwise = [compItem]

310+ | otherwise = compItem

261 qual

311 qual

262− | is_qual spec = Map.singleton asMod [compItem]

312+ | is_qual spec = Map.singleton asMod compItem

263− | otherwise = Map.fromList [(asMod,[compItem]),(origMod,[compItem])]

313+ | otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)]

314+ compItem = [toCompItem (is_mod spec) n]

264 asMod = showModName (is_as spec)

315 asMod = showModName (is_as spec)

265 origMod = showModName (is_mod spec)

316 origMod = showModName (is_mod spec)

266− return (unqual,QualCompls qual)

317+ in (unqual,QualCompls qual)

267−

318+

268− varToCompl :: Var -> IO CompItem

319+ varToCompl :: Var -> CompItem

269− varToCompl var = do

320+ varToCompl var = CI name (showModName curMod) typ label Nothing docs

321+ where

270− let typ = Just $ varType var

322+ typ = Just $ varType var

271− name = Var.varName var

323+ name = Var.varName var

272− label = T.pack $ showGhc name

324+ label = T.pack $ showGhc name

273− docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) name

325+ docs = getDocumentation tcs name

274− return $ CI name (showModName curMod) typ label Nothing docs

326+

275−

276− toCompItem :: ModuleName -> Name -> IO CompItem

327+ toCompItem :: ModuleName -> Name -> CompItem

277− toCompItem mn n = do

328+ toCompItem mn n =

278− docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) n

279−-- lookupName uses runInteractiveHsc, i.e., GHCi stuff which does not work with GHCi

280−-- and leads to fun errors like "Cannot continue after interface file error".

281−#ifdef GHC_LIB

282− let ty = Right Nothing

283−#else

284− ty <- evalGhcEnv packageState $ catchSrcErrors "completion" $ do

285− name' <- lookupName n

286− return $ name' >>= safeTyThingType

287−#endif

288− return $ CI n (showModName mn) (either (const Nothing) id ty) (T.pack $ showGhc n) Nothing docs

329+ CI n (showModName mn) Nothing (T.pack $ showGhc n) Nothing (getDocumentation tcs n)

289−

330+

290− (unquals,quals) <- getCompls rdrElts

331+ (unquals,quals) = getCompls rdrElts

291

332

292 return $ CC

333 return $ CC

293 { allModNamesAsNS = allModNamesAsNS

334 { allModNamesAsNS = allModNamesAsNS

@@ -304,16 +345,19 @@ toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x

304 | otherwise = x { _insertTextFormat = Just PlainText

345 | otherwise = x { _insertTextFormat = Just PlainText

305 , _insertText = Nothing

346 , _insertText = Nothing

306 }

347 }

307− where supported = Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)

348+ where supported = fromMaybe False (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)

308

349

309-- | Returns the cached completions for the given module and position.

350-- | Returns the cached completions for the given module and position.

310−getCompletions :: IdeOptions -> CachedCompletions -> ParsedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]

351+getCompletions :: CachedCompletions -> TypecheckedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]

311−getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }

352+getCompletions CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }

312− pm prefixInfo caps withSnippets = do

353+ tm prefixInfo caps withSnippets = do

313 let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo

354 let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo

314 enteredQual = if T.null prefixModule then "" else prefixModule <> "."

355 enteredQual = if T.null prefixModule then "" else prefixModule <> "."

315 fullPrefix = enteredQual <> prefixText

356 fullPrefix = enteredQual <> prefixText

316

357

358+ -- default to value context if no explicit context

359+ context = fromMaybe ValueContext $ getCContext pos (tm_parsed_module tm)

360+

317 {- correct the position by moving 'foo :: Int -> String -> '

361 {- correct the position by moving 'foo :: Int -> String -> '

318 ^

362 ^

319 to 'foo :: Int -> String -> '

363 to 'foo :: Int -> String -> '

@@ -342,11 +386,10 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl

342 where

386 where

343 isTypeCompl = isTcOcc . occName . origName

387 isTypeCompl = isTcOcc . occName . origName

344 -- completions specific to the current context

388 -- completions specific to the current context

345− ctxCompls' = case getCContext pos pm of

389+ ctxCompls' = case context of

346− Nothing -> compls

347− Just TypeContext -> filter isTypeCompl compls

390+ TypeContext -> filter isTypeCompl compls

348− Just ValueContext -> filter (not . isTypeCompl) compls

391+ ValueContext -> filter (not . isTypeCompl) compls

349− Just _ -> filter (not . isTypeCompl) compls

392+ _ -> filter (not . isTypeCompl) compls

350 -- Add whether the text to insert has backticks

393 -- Add whether the text to insert has backticks

351 ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'

394 ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'

352

395

@@ -372,9 +415,6 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl

372 filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules

415 filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules

373 filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas

416 filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas

374 filtOptsCompls = filtListWith mkExtCompl

417 filtOptsCompls = filtListWith mkExtCompl

375− filtKeywordCompls

376− | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)

377− | otherwise = []

378

418

379 stripLeading :: Char -> String -> String

419 stripLeading :: Char -> String -> String

380 stripLeading _ [] = []

420 stripLeading _ [] = []

@@ -393,19 +433,14 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl

393 = filtPragmaCompls (pragmaSuffix fullLine)

433 = filtPragmaCompls (pragmaSuffix fullLine)

394 | otherwise

434 | otherwise

395 = filtModNameCompls ++ map (toggleSnippets caps withSnippets

435 = filtModNameCompls ++ map (toggleSnippets caps withSnippets

396− . mkCompl ideOpts . stripAutoGenerated) filtCompls

436+ . mkCompl . stripAutoGenerated) filtCompls

397− ++ filtKeywordCompls

437+

398−

399 return result

438 return result

400

439

401-- The supported languages and extensions

440-- The supported languages and extensions

402languagesAndExts :: [T.Text]

441languagesAndExts :: [T.Text]

403−#if MIN_GHC_API_VERSION(8,10,0)

404−languagesAndExts = map T.pack $ DynFlags.supportedLanguagesAndExtensions ( PlatformMini ArchUnknown OSUnknown )

405−#else

406languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions

442languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions

407−#endif

443+

408−

409-- ---------------------------------------------------------------------

444-- ---------------------------------------------------------------------

410-- helper functions for pragmas

445-- helper functions for pragmas

411-- ---------------------------------------------------------------------

446-- ---------------------------------------------------------------------

@@ -527,4 +562,4 @@ prefixes =

527 , "$t"

562 , "$t"

528 , "$c"

563 , "$c"

529 , "$m"

564 , "$m"

530− ]

565+ ]

src/Development/IDE/Plugin/Completions/Types.hs → src/Development/IDE/Core/CompletionsTypes.hsrenamed+9−5

@@ -1,16 +1,20 @@

1−module Development.IDE.Plugin.Completions.Types (

1+module Development.IDE.Core.CompletionsTypes (

2− module Development.IDE.Plugin.Completions.Types

2+ module Development.IDE.Core.CompletionsTypes

3) where

5import Control.DeepSeq

6import qualified Data.Map as Map

7import qualified Data.Text as T

8−import GHC

10−import Development.IDE.Spans.Common

9+import GHC

10+import Outputable

11+import DynFlags

12-- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs

13-- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs

15+showGhc :: Outputable a => a -> String

16+showGhc = showPpr unsafeGlobalDynFlags

17+

14data Backtick = Surrounded | LeftSide deriving Show

18data Backtick = Surrounded | LeftSide deriving Show

15data CompItem = CI

19data CompItem = CI

16 { origName :: Name -- ^ Original name, such as Maybe, //, or find.

20 { origName :: Name -- ^ Original name, such as Maybe, //, or find.

@@ -19,7 +23,7 @@ data CompItem = CI

19 , label :: T.Text -- ^ Label to display to the user.

23 , label :: T.Text -- ^ Label to display to the user.

20 , isInfix :: Maybe Backtick -- ^ Did the completion happen

24 , isInfix :: Maybe Backtick -- ^ Did the completion happen

21 -- in the context of an infix notation.

25 -- in the context of an infix notation.

22− , docs :: SpanDoc -- ^ Available documentation.

26+ , docs :: [T.Text] -- ^ Available documentation.

23 }

27 }

24instance Show CompItem where

28instance Show CompItem where

25 show CI { .. } = "CompItem { origName = \"" ++ showGhc origName ++ "\""

29 show CI { .. } = "CompItem { origName = \"" ++ showGhc origName ++ "\""

src/Development/IDE/Core/Debouncer.hs+11−18

@@ -3,18 +3,16 @@

4module Development.IDE.Core.Debouncer

5 ( Debouncer

6+ , newDebouncer

6 , registerEvent

7 , registerEvent

7− , newAsyncDebouncer

8− , noopDebouncer

9 ) where

8 ) where

11import Control.Concurrent.Extra

10import Control.Concurrent.Extra

12import Control.Concurrent.Async

11import Control.Concurrent.Async

13import Control.Exception

12import Control.Exception

14import Control.Monad.Extra

13import Control.Monad.Extra

15−import Data.Hashable

14+import Data.Map.Strict (Map)

16−import Data.HashMap.Strict (HashMap)

17−import qualified Data.HashMap.Strict as Map

15+import qualified Data.Map.Strict as Map

18import System.Time.Extra

16import System.Time.Extra

20-- | A debouncer can be used to avoid triggering many events

18-- | A debouncer can be used to avoid triggering many events

@@ -23,14 +21,13 @@ import System.Time.Extra

23-- by delaying each event for a given time. If another event

21-- by delaying each event for a given time. If another event

24-- is registered for the same key within that timeframe,

22-- is registered for the same key within that timeframe,

25-- only the new event will fire.

23-- only the new event will fire.

26−--

27−-- We abstract over the debouncer used so we an use a proper debouncer in the IDE but disable

28−-- debouncing in the DAML CLI compiler.

29−newtype Debouncer k = Debouncer { registerEvent :: Seconds -> k -> IO () -> IO () }

24+newtype Debouncer k = Debouncer (Var (Map k (Async ())))

31−-- | Debouncer used in the IDE that delays events as expected.

26+-- | Create a new empty debouncer.

32−newAsyncDebouncer :: (Eq k, Hashable k) => IO (Debouncer k)

27+newDebouncer :: IO (Debouncer k)

33−newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty

28+newDebouncer = do

29+ m <- newVar Map.empty

30+ pure $ Debouncer m

35-- | Register an event that will fire after the given delay if no other event

32-- | Register an event that will fire after the given delay if no other event

36-- for the same key gets registered until then.

33-- for the same key gets registered until then.

@@ -38,15 +35,11 @@ newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty

38-- If there is a pending event for the same key, the pending event will be killed.

35-- If there is a pending event for the same key, the pending event will be killed.

39-- Events are run unmasked so it is up to the user of `registerEvent`

36-- Events are run unmasked so it is up to the user of `registerEvent`

40-- to mask if required.

37-- to mask if required.

41−asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()

38+registerEvent :: Ord k => Debouncer k -> Seconds -> k -> IO () -> IO ()

42−asyncRegisterEvent d delay k fire = modifyVar_ d $ \m -> mask_ $ do

39+registerEvent (Debouncer d) delay k fire = modifyVar_ d $ \m -> mask_ $ do

43 whenJust (Map.lookup k m) cancel

40 whenJust (Map.lookup k m) cancel

44 a <- asyncWithUnmask $ \unmask -> unmask $ do

41 a <- asyncWithUnmask $ \unmask -> unmask $ do

45 sleep delay

42 sleep delay

46 fire

43 fire

47 modifyVar_ d (pure . Map.delete k)

44 modifyVar_ d (pure . Map.delete k)

48 pure $ Map.insert k a m

45 pure $ Map.insert k a m

49−

50−-- | Debouncer used in the DAML CLI compiler that emits events immediately.

51−noopDebouncer :: Debouncer k

52−noopDebouncer = Debouncer $ \_ _ a -> a

src/Development/IDE/Core/FileExists.hsdeleted−181

@@ -1,181 +0,0 @@

1−{-# LANGUAGE OverloadedLists #-}

2−{-# LANGUAGE TypeFamilies #-}

3−{-# LANGUAGE UndecidableInstances #-}

4−module Development.IDE.Core.FileExists

5− ( fileExistsRules

6− , modifyFileExists

7− , getFileExists

8− )

9−where

10−

11−import Control.Concurrent.Extra

12−import Control.Exception

13−import Control.Monad.Extra

14−import qualified Data.Aeson as A

15−import Data.Binary

16−import qualified Data.ByteString as BS

17−import Data.HashMap.Strict (HashMap)

18−import qualified Data.HashMap.Strict as HashMap

19−import Data.Maybe

20−import qualified Data.Text as T

21−import Development.IDE.Core.FileStore

22−import Development.IDE.Core.IdeConfiguration

23−import Development.IDE.Core.Shake

24−import Development.IDE.Types.Location

25−import Development.IDE.Types.Logger

26−import Development.Shake

27−import Development.Shake.Classes

28−import GHC.Generics

29−import Language.Haskell.LSP.Messages

30−import Language.Haskell.LSP.Types

31−import Language.Haskell.LSP.Types.Capabilities

32−import qualified System.Directory as Dir

33−

34−-- | A map for tracking the file existence

35−type FileExistsMap = (HashMap NormalizedFilePath Bool)

36−

37−-- | A wrapper around a mutable 'FileExistsMap'

38−newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap)

39−

40−instance IsIdeGlobal FileExistsMapVar

41−

42−-- | Grab the current global value of 'FileExistsMap' without acquiring a dependency

43−getFileExistsMapUntracked :: Action FileExistsMap

44−getFileExistsMapUntracked = do

45− FileExistsMapVar v <- getIdeGlobalAction

46− liftIO $ readVar v

47−

48−-- | Modify the global store of file exists

49−modifyFileExistsAction :: (FileExistsMap -> IO FileExistsMap) -> Action ()

50−modifyFileExistsAction f = do

51− FileExistsMapVar var <- getIdeGlobalAction

52− liftIO $ modifyVar_ var f

53−

54−-- | Modify the global store of file exists

55−modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO ()

56−modifyFileExists state changes = do

57− FileExistsMapVar var <- getIdeGlobalState state

58− changesMap <- evaluate $ HashMap.fromList changes

59−

60− -- Masked to ensure that the previous values are flushed together with the map update

61− mask $ \_ -> do

62− -- update the map

63− modifyVar_ var $ evaluate . HashMap.union changesMap

64− -- flush previous values

65− mapM_ (deleteValue state GetFileExists . fst) changes

66−

67−-------------------------------------------------------------------------------------

68−

69−type instance RuleResult GetFileExists = Bool

70−

71−data GetFileExists = GetFileExists

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

73−

74−instance NFData GetFileExists

75−instance Hashable GetFileExists

76−instance Binary GetFileExists

77−

78−-- | Returns True if the file exists

79−-- Note that a file is not considered to exist unless it is saved to disk.

80−-- In particular, VFS existence is not enough.

81−-- Consider the following example:

82−-- 1. The file @A.hs@ containing the line @import B@ is added to the files of interest

83−-- Since @B.hs@ is neither open nor exists, GetLocatedImports finds Nothing

84−-- 2. The editor creates a new buffer @B.hs@

85−-- Unless the editor also sends a @DidChangeWatchedFile@ event, ghcide will not pick it up

86−-- Most editors, e.g. VSCode, only send the event when the file is saved to disk.

87−getFileExists :: NormalizedFilePath -> Action Bool

88−getFileExists fp = use_ GetFileExists fp

89−

90−-- | Installs the 'getFileExists' rules.

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

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

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

94−fileExistsRules getLspId ClientCapabilities{_workspace} vfs = do

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

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

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

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

99− case () of

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

101− , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles

102− , Just True <- _dynamicRegistration

103− -> fileExistsRulesFast getLspId vfs

104− | otherwise -> do

105− logger <- logger <$> getShakeExtrasRules

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

107− fileExistsRulesSlow vfs

108−

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

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

111−fileExistsRulesFast getLspId vfs =

112− defineEarlyCutoff $ \GetFileExists file -> do

113− isWf <- isWorkspaceFile file

114− if isWf

115− then fileExistsFast getLspId vfs file

116− else fileExistsSlow vfs file

117−

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

119−fileExistsFast getLspId vfs file = do

120− fileExistsMap <- getFileExistsMapUntracked

121− let mbFilesWatched = HashMap.lookup file fileExistsMap

122− case mbFilesWatched of

123− Just fv -> pure (summarizeExists fv, ([], Just fv))

124− Nothing -> do

125− exist <- liftIO $ getFileExistsVFS vfs file

126− ShakeExtras { eventer } <- getShakeExtras

127−

128− -- add a listener for VFS Create/Delete file events,

129− -- taking the FileExistsMap lock to prevent race conditions

130− -- that would lead to multiple listeners for the same path

131− modifyFileExistsAction $ \x -> do

132− case HashMap.alterF (,Just exist) file x of

133− (Nothing, x') -> do

134− -- if the listener addition fails, we never recover. This is a bug.

135− addListener eventer file

136− return x'

137− (Just _, _) ->

138− -- if the key was already there, do nothing

139− return x

140−

141− pure (summarizeExists exist, ([], Just exist))

142− where

143− addListener eventer fp = do

144− reqId <- getLspId

145− let

146− req = RequestMessage "2.0" reqId ClientRegisterCapability regParams

147− fpAsId = T.pack $ fromNormalizedFilePath fp

148− regParams = RegistrationParams (List [registration])

149− registration = Registration fpAsId

150− WorkspaceDidChangeWatchedFiles

151− (Just (A.toJSON regOptions))

152− regOptions =

153− DidChangeWatchedFilesRegistrationOptions { _watchers = List [watcher] }

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

155− watcher = FileSystemWatcher { _globPattern = fromNormalizedFilePath fp

156− , _kind = Just watchKind

157− }

158−

159− eventer $ ReqRegisterCapability req

160−

161−summarizeExists :: Bool -> Maybe BS.ByteString

162−summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty

163−

164−fileExistsRulesSlow:: VFSHandle -> Rules ()

165−fileExistsRulesSlow vfs =

166− defineEarlyCutoff $ \GetFileExists file -> fileExistsSlow vfs file

167−

168−fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))

169−fileExistsSlow vfs file = do

170− alwaysRerun

171− exist <- liftIO $ getFileExistsVFS vfs file

172− pure (summarizeExists exist, ([], Just exist))

173−

174−getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool

175−getFileExistsVFS vfs file = do

176− -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute

177− -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly

178− -- cached 'No' rather than an exception in the wrong place

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

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

181− Dir.doesFileExist (fromNormalizedFilePath file)

src/Development/IDE/Core/FileStore.hs+68−19

@@ -4,25 +4,32 @@

4{-# LANGUAGE TypeFamilies #-}

6module Development.IDE.Core.FileStore(

7− getFileContents,

7+ getFileExists, getFileContents,

8− getVirtualFile,

9 setBufferModified,

8 setBufferModified,

10 setSomethingModified,

9 setSomethingModified,

11 fileStoreRules,

10 fileStoreRules,

12 VFSHandle,

11 VFSHandle,

13 makeVFSHandle,

12 makeVFSHandle,

14− makeLSPVFSHandle

13+ makeLSPVFSHandle,

14+ getSourceFingerprint

15 ) where

17+import Foreign.Ptr

18+import Foreign.ForeignPtr

19+import Fingerprint

20+import StringBuffer

17import Development.IDE.GHC.Orphans()

21import Development.IDE.GHC.Orphans()

18−import Development.IDE.Core.Shake

22+import Development.IDE.GHC.Util

23+

19import Control.Concurrent.Extra

24import Control.Concurrent.Extra

20import qualified Data.Map.Strict as Map

25import qualified Data.Map.Strict as Map

21import Data.Maybe

26import Data.Maybe

22import qualified Data.Text as T

27import qualified Data.Text as T

23import Control.Monad.Extra

28import Control.Monad.Extra

29+import qualified System.Directory as Dir

24import Development.Shake

30import Development.Shake

25import Development.Shake.Classes

31import Development.Shake.Classes

32+import Development.IDE.Core.Shake

26import Control.Exception

33import Control.Exception

27import GHC.Generics

34import GHC.Generics

28import Data.Either.Extra

35import Data.Either.Extra

@@ -34,9 +41,7 @@ import qualified Data.Rope.UTF16 as Rope

35#ifdef mingw32_HOST_OS

42#ifdef mingw32_HOST_OS

36import Data.Time

43import Data.Time

37−import qualified System.Directory as Dir

38#else

44#else

39−import Foreign.Ptr

40import Foreign.C.String

45import Foreign.C.String

41import Foreign.C.Types

46import Foreign.C.Types

42import Foreign.Marshal (alloca)

47import Foreign.Marshal (alloca)

@@ -83,7 +88,18 @@ makeLSPVFSHandle lspFuncs = VFSHandle

85-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.

90-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.

86−type instance RuleResult GetFileContents = (FileVersion, Maybe T.Text)

91+type instance RuleResult GetFileContents = (FileVersion, Maybe StringBuffer)

92+

93+-- | Does the file exist.

94+type instance RuleResult GetFileExists = Bool

95+

96+type instance RuleResult FingerprintSource = Fingerprint

97+

98+data GetFileExists = GetFileExists

99+ deriving (Eq, Show, Generic)

100+instance Hashable GetFileExists

101+instance NFData GetFileExists

102+instance Binary GetFileExists

103

88data GetFileContents = GetFileContents

104data GetFileContents = GetFileContents

89 deriving (Eq, Show, Generic)

105 deriving (Eq, Show, Generic)

@@ -91,16 +107,40 @@ instance Hashable GetFileContents

91instance NFData GetFileContents

107instance NFData GetFileContents

92instance Binary GetFileContents

108instance Binary GetFileContents

109

110+data FingerprintSource = FingerprintSource

111+ deriving (Eq, Show, Generic)

112+instance Hashable FingerprintSource

113+instance NFData FingerprintSource

114+instance Binary FingerprintSource

115+

116+fingerprintSourceRule :: Rules ()

117+fingerprintSourceRule =

118+ define $ \FingerprintSource file -> do

119+ (_, mbContent) <- getFileContents file

120+ content <- liftIO $ maybe (hGetStringBuffer $ fromNormalizedFilePath file) pure mbContent

121+ fingerprint <- liftIO $ fpStringBuffer content

122+ pure ([], Just fingerprint)

123+ where fpStringBuffer (StringBuffer buf len cur) = withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len

124+

125+getFileExistsRule :: VFSHandle -> Rules ()

126+getFileExistsRule vfs =

127+ defineEarlyCutoff $ \GetFileExists file -> do

128+ alwaysRerun

129+ res <- liftIO $ handle (\(_ :: IOException) -> return False) $

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

131+ Dir.doesFileExist (fromNormalizedFilePath file)

132+ return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))

133+

134+

94getModificationTimeRule :: VFSHandle -> Rules ()

135getModificationTimeRule :: VFSHandle -> Rules ()

95getModificationTimeRule vfs =

136getModificationTimeRule vfs =

96 defineEarlyCutoff $ \GetModificationTime file -> do

137 defineEarlyCutoff $ \GetModificationTime file -> do

97 let file' = fromNormalizedFilePath file

138 let file' = fromNormalizedFilePath file

98− let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s))

139+ let wrap time = (Just time, ([], Just $ ModificationTime time))

99 alwaysRerun

140 alwaysRerun

100 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file

141 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file

101 case mbVirtual of

142 case mbVirtual of

102− Just (virtualFileVersion -> ver) ->

103− pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))

143+ Just (virtualFileVersion -> ver) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))

104 Nothing -> liftIO $ fmap wrap (getModTime file')

144 Nothing -> liftIO $ fmap wrap (getModTime file')

105 `catch` \(e :: IOException) -> do

145 `catch` \(e :: IOException) -> do

106 let err | isDoesNotExistError e = "File does not exist: " ++ file'

146 let err | isDoesNotExistError e = "File does not exist: " ++ file'

@@ -114,15 +154,11 @@ getModificationTimeRule vfs =

114 -- time spent checking file modifications (which happens on every change)

154 -- time spent checking file modifications (which happens on every change)

115 -- from > 0.5s to ~0.15s.

155 -- from > 0.5s to ~0.15s.

116 -- We might also want to try speeding this up on Windows at some point.

156 -- We might also want to try speeding this up on Windows at some point.

117− -- TODO leverage DidChangeWatchedFile lsp notifications on clients that

118− -- support them, as done for GetFileExists

119− getModTime :: FilePath -> IO (Int,Int)

157+ getModTime :: FilePath -> IO BS.ByteString

120 getModTime f =

158 getModTime f =

121#ifdef mingw32_HOST_OS

159#ifdef mingw32_HOST_OS

122 do time <- Dir.getModificationTime f

160 do time <- Dir.getModificationTime f

123− let !day = fromInteger $ toModifiedJulianDay $ utctDay time

124− !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time

161+ pure $! BS.pack $ show (toModifiedJulianDay $ utctDay time, diffTimeToPicoseconds $ utctDayTime time)

125− pure (day, dayTime)

126#else

162#else

127 withCString f $ \f' ->

163 withCString f $ \f' ->

128 alloca $ \secPtr ->

164 alloca $ \secPtr ->

@@ -130,13 +166,16 @@ getModificationTimeRule vfs =

130 Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr

166 Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr

131 sec <- peek secPtr

167 sec <- peek secPtr

132 nsec <- peek nsecPtr

168 nsec <- peek nsecPtr

133− pure (fromEnum sec, fromIntegral nsec)

169+ pure $! BS.pack $ show sec <> "." <> show nsec

134

170

135-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow

171-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow

136-- as doing the FFI call ourselves :(.

172-- as doing the FFI call ourselves :(.

137foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int

173foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int

138#endif

174#endif

139

175

176+getSourceFingerprint :: NormalizedFilePath -> Action Fingerprint

177+getSourceFingerprint = use_ FingerprintSource

178+

140getFileContentsRule :: VFSHandle -> Rules ()

179getFileContentsRule :: VFSHandle -> Rules ()

141getFileContentsRule vfs =

180getFileContentsRule vfs =

142 define $ \GetFileContents file -> do

181 define $ \GetFileContents file -> do

@@ -144,7 +183,7 @@ getFileContentsRule vfs =

144 time <- use_ GetModificationTime file

183 time <- use_ GetModificationTime file

145 res <- liftIO $ ideTryIOException file $ do

184 res <- liftIO $ ideTryIOException file $ do

146 mbVirtual <- getVirtualFile vfs $ filePathToUri' file

185 mbVirtual <- getVirtualFile vfs $ filePathToUri' file

147− pure $ Rope.toText . _text <$> mbVirtual

186+ pure $ textToStringBuffer . Rope.toText . _text <$> mbVirtual

148 case res of

187 case res of

149 Left err -> return ([err], Nothing)

188 Left err -> return ([err], Nothing)

150 Right contents -> return ([], Just (time, contents))

189 Right contents -> return ([], Just (time, contents))

@@ -156,14 +195,24 @@ ideTryIOException fp act =

156 <$> try act

195 <$> try act

157

196

158

197

159−getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe T.Text)

198+getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe StringBuffer)

160getFileContents = use_ GetFileContents

199getFileContents = use_ GetFileContents

161

200

201+getFileExists :: NormalizedFilePath -> Action Bool

202+getFileExists =

203+ -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute

204+ -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly

205+ -- cached 'No' rather than an exception in the wrong place

206+ use_ GetFileExists

207+

208+

162fileStoreRules :: VFSHandle -> Rules ()

209fileStoreRules :: VFSHandle -> Rules ()

163fileStoreRules vfs = do

210fileStoreRules vfs = do

164 addIdeGlobal vfs

211 addIdeGlobal vfs

165 getModificationTimeRule vfs

212 getModificationTimeRule vfs

166 getFileContentsRule vfs

213 getFileContentsRule vfs

214+ getFileExistsRule vfs

215+ fingerprintSourceRule

167

216

168

217

169-- | Notify the compiler service that a particular file has been modified.

218-- | Notify the compiler service that a particular file has been modified.

src/Development/IDE/Core/IdeConfiguration.hsdeleted−71

@@ -1,71 +0,0 @@

1−{-# LANGUAGE DuplicateRecordFields #-}

2−module Development.IDE.Core.IdeConfiguration

3− ( IdeConfiguration(..)

4− , registerIdeConfiguration

5− , parseConfiguration

6− , parseWorkspaceFolder

7− , isWorkspaceFile

8− , modifyWorkspaceFolders

9− )

10−where

11−

12−import Control.Concurrent.Extra

13−import Control.Monad

14−import Data.HashSet (HashSet, singleton)

15−import Data.Text (Text, isPrefixOf)

16−import Development.IDE.Core.Shake

17−import Development.IDE.Types.Location

18−import Development.Shake

19−import Language.Haskell.LSP.Types

20−import System.FilePath (isRelative)

21−

22−-- | Lsp client relevant configuration details

23−data IdeConfiguration = IdeConfiguration

24− { workspaceFolders :: HashSet NormalizedUri

25− }

26− deriving (Show)

27−

28−newtype IdeConfigurationVar = IdeConfigurationVar {unIdeConfigurationRef :: Var IdeConfiguration}

29−

30−instance IsIdeGlobal IdeConfigurationVar

31−

32−registerIdeConfiguration :: ShakeExtras -> IdeConfiguration -> IO ()

33−registerIdeConfiguration extras =

34− addIdeGlobalExtras extras . IdeConfigurationVar <=< newVar

35−

36−getIdeConfiguration :: Action IdeConfiguration

37−getIdeConfiguration =

38− getIdeGlobalAction >>= liftIO . readVar . unIdeConfigurationRef

39−

40−parseConfiguration :: InitializeParams -> IdeConfiguration

41−parseConfiguration InitializeParams {..} =

42− IdeConfiguration { .. }

43− where

44− workspaceFolders =

45− foldMap (singleton . toNormalizedUri) _rootUri

46− <> (foldMap . foldMap)

47− (singleton . parseWorkspaceFolder)

48− _workspaceFolders

49−

50−parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri

51−parseWorkspaceFolder =

52− toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text)

53−

54−modifyWorkspaceFolders

55− :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()

56−modifyWorkspaceFolders ide f = do

57− IdeConfigurationVar var <- getIdeGlobalState ide

58− IdeConfiguration ws <- readVar var

59− writeVar var (IdeConfiguration (f ws))

60−

61−isWorkspaceFile :: NormalizedFilePath -> Action Bool

62−isWorkspaceFile file =

63− if isRelative (fromNormalizedFilePath file)

64− then return True

65− else do

66− IdeConfiguration {..} <- getIdeConfiguration

67− let toText = getUri . fromNormalizedUri

68− return $

69− any

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

71− workspaceFolders

src/Development/IDE/Core/OfInterest.hs+24−24

@@ -1,17 +1,19 @@

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

4−{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FlexibleInstances #-}

7−-- | Utilities and state for the files of interest - those which are currently

8+-- | A Shake implementation of the compiler service, built

8−-- open in the editor. The useful function is 'getFilesOfInterest'.

9+-- using the "Shaker" abstraction layer for in-memory use.

10+--

9module Development.IDE.Core.OfInterest(

11module Development.IDE.Core.OfInterest(

10 ofInterestRules,

12 ofInterestRules,

11 getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,

13 getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,

12 ) where

14 ) where

14−import Control.Concurrent.Extra

16+import Control.Concurrent.Extra

15import Data.Binary

17import Data.Binary

16import Data.Hashable

18import Data.Hashable

17import Control.DeepSeq

19import Control.DeepSeq

@@ -19,22 +21,25 @@ import GHC.Generics

19import Data.Typeable

21import Data.Typeable

20import qualified Data.ByteString.UTF8 as BS

22import qualified Data.ByteString.UTF8 as BS

21import Control.Exception

23import Control.Exception

22−import Data.HashSet (HashSet)

24+import Development.IDE.Types.Location

25+import Development.IDE.Types.Logger

26+import Data.Set (Set)

23−import qualified Data.HashSet as HashSet

27+import qualified Data.Set as Set

24import qualified Data.Text as T

28import qualified Data.Text as T

25import Data.Tuple.Extra

29import Data.Tuple.Extra

26import Data.Functor

30import Data.Functor

27−import Development.Shake

31+import Development.Shake

32+

33+import Development.IDE.Core.Shake

29−import Development.IDE.Types.Location

30−import Development.IDE.Types.Logger

31−import Development.IDE.Core.Shake

34−newtype OfInterestVar = OfInterestVar (Var (HashSet NormalizedFilePath))

37+newtype OfInterestVar = OfInterestVar (Var (Set NormalizedFilePath))

35instance IsIdeGlobal OfInterestVar

38instance IsIdeGlobal OfInterestVar

40+

37−type instance RuleResult GetFilesOfInterest = HashSet NormalizedFilePath

41+type instance RuleResult GetFilesOfInterest = Set NormalizedFilePath

42+

39data GetFilesOfInterest = GetFilesOfInterest

44data GetFilesOfInterest = GetFilesOfInterest

40 deriving (Eq, Show, Typeable, Generic)

45 deriving (Eq, Show, Typeable, Generic)

@@ -43,18 +48,16 @@ instance NFData GetFilesOfInterest

43instance Binary GetFilesOfInterest

48instance Binary GetFilesOfInterest

46−-- | The rule that initialises the files of interest state.

47ofInterestRules :: Rules ()

51ofInterestRules :: Rules ()

48ofInterestRules = do

52ofInterestRules = do

49− addIdeGlobal . OfInterestVar =<< liftIO (newVar HashSet.empty)

53+ addIdeGlobal . OfInterestVar =<< liftIO (newVar Set.empty)

50 defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do

54 defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do

51 alwaysRerun

55 alwaysRerun

52 filesOfInterest <- getFilesOfInterestUntracked

56 filesOfInterest <- getFilesOfInterestUntracked

53 pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest))

57 pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest))

56−-- | Get the files that are open in the IDE.

57−getFilesOfInterest :: Action (HashSet NormalizedFilePath)

60+getFilesOfInterest :: Action (Set NormalizedFilePath)

58getFilesOfInterest = useNoFile_ GetFilesOfInterest

61getFilesOfInterest = useNoFile_ GetFilesOfInterest

@@ -62,21 +65,18 @@ getFilesOfInterest = useNoFile_ GetFilesOfInterest

62------------------------------------------------------------

65------------------------------------------------------------

63-- Exposed API

66-- Exposed API

65−-- | Set the files-of-interest - not usually necessary or advisable.

68+-- | Set the files-of-interest which will be built and kept-up-to-date.

66−-- The LSP client will keep this information up to date.

67−setFilesOfInterest :: IdeState -> HashSet NormalizedFilePath -> IO ()

69+setFilesOfInterest :: IdeState -> Set NormalizedFilePath -> IO ()

68setFilesOfInterest state files = modifyFilesOfInterest state (const files)

70setFilesOfInterest state files = modifyFilesOfInterest state (const files)

70−getFilesOfInterestUntracked :: Action (HashSet NormalizedFilePath)

72+getFilesOfInterestUntracked :: Action (Set NormalizedFilePath)

71getFilesOfInterestUntracked = do

73getFilesOfInterestUntracked = do

72 OfInterestVar var <- getIdeGlobalAction

74 OfInterestVar var <- getIdeGlobalAction

73 liftIO $ readVar var

75 liftIO $ readVar var

75−-- | Modify the files-of-interest - not usually necessary or advisable.

76−-- The LSP client will keep this information up to date.

77−modifyFilesOfInterest :: IdeState -> (HashSet NormalizedFilePath -> HashSet NormalizedFilePath) -> IO ()

77+modifyFilesOfInterest :: IdeState -> (Set NormalizedFilePath -> Set NormalizedFilePath) -> IO ()

78modifyFilesOfInterest state f = do

79 OfInterestVar var <- getIdeGlobalState state

80 files <- modifyVar var $ pure . dupe . f

81− logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashSet.toList files)

81+ logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ Set.toList files)

82 void $ shakeRun state []

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

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

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

3module Development.IDE.Core.PositionMapping

4 ( PositionMapping(..)

5− , fromCurrentPosition

6− , toCurrentPosition

7− , PositionDelta(..)

8− , addDelta

9− , mkDelta

10 , toCurrentRange

5 , toCurrentRange

11 , fromCurrentRange

6 , fromCurrentRange

12 , applyChange

7 , applyChange

13− , zeroMapping

8+ , idMapping

14 -- toCurrent and fromCurrent are mainly exposed for testing

9 -- toCurrent and fromCurrent are mainly exposed for testing

15 , toCurrent

10 , toCurrent

16 , fromCurrent

11 , fromCurrent

@@ -19,25 +14,12 @@ module Development.IDE.Core.PositionMapping

19import Control.Monad

14import Control.Monad

20import qualified Data.Text as T

15import qualified Data.Text as T

21import Language.Haskell.LSP.Types

16import Language.Haskell.LSP.Types

22−import Data.List

24−-- The position delta is the difference between two versions

18+data PositionMapping = PositionMapping

25−data PositionDelta = PositionDelta

26− { toDelta :: !(Position -> Maybe Position)

19+ { toCurrentPosition :: !(Position -> Maybe Position)

27− , fromDelta :: !(Position -> Maybe Position)

20+ , fromCurrentPosition :: !(Position -> Maybe Position)

28 }

21 }

30−fromCurrentPosition :: PositionMapping -> Position -> Maybe Position

31−fromCurrentPosition (PositionMapping pm) = fromDelta pm

32−

33−toCurrentPosition :: PositionMapping -> Position -> Maybe Position

34−toCurrentPosition (PositionMapping pm) = toDelta pm

35−

36−-- A position mapping is the difference from the current version to

37−-- a specific version

38−newtype PositionMapping = PositionMapping PositionDelta

39−

40−

41toCurrentRange :: PositionMapping -> Range -> Maybe Range

23toCurrentRange :: PositionMapping -> Range -> Maybe Range

42toCurrentRange mapping (Range a b) =

24toCurrentRange mapping (Range a b) =

43 Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b

25 Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b

@@ -46,33 +28,13 @@ fromCurrentRange :: PositionMapping -> Range -> Maybe Range

46fromCurrentRange mapping (Range a b) =

28fromCurrentRange mapping (Range a b) =

47 Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b

29 Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b

49−zeroMapping :: PositionMapping

31+idMapping :: PositionMapping

50−zeroMapping = PositionMapping idDelta

32+idMapping = PositionMapping Just Just

51−

52−-- | Compose two position mappings. Composes in the same way as function

53−-- composition (ie the second argument is applyed to the position first).

54−composeDelta :: PositionDelta

55− -> PositionDelta

56− -> PositionDelta

57−composeDelta (PositionDelta to1 from1) (PositionDelta to2 from2) =

58− PositionDelta (to1 <=< to2)

59− (from1 >=> from2)

60−

61−idDelta :: PositionDelta

62−idDelta = PositionDelta Just Just

63−

64−-- | Convert a set of changes into a delta from k to k + 1

65−mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta

66−mkDelta cs = foldl' applyChange idDelta cs

67−

68−-- | Add a new delta onto a Mapping k n to make a Mapping (k - 1) n

69−addDelta :: PositionDelta -> PositionMapping -> PositionMapping

70−addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm)

72−applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta

34+applyChange :: PositionMapping -> TextDocumentContentChangeEvent -> PositionMapping

73−applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta

35+applyChange posMapping (TextDocumentContentChangeEvent (Just r) _ t) = PositionMapping

74− { toDelta = toCurrent r t <=< toDelta

36+ { toCurrentPosition = toCurrent r t <=< toCurrentPosition posMapping

75− , fromDelta = fromDelta <=< fromCurrent r t

37+ , fromCurrentPosition = fromCurrentPosition posMapping <=< fromCurrent r t

76 }

38 }

77applyChange posMapping _ = posMapping

39applyChange posMapping _ = posMapping

src/Development/IDE/Core/Preprocessor.hs+5−78

@@ -18,26 +18,16 @@ import Data.Char

18import DynFlags

19import qualified HeaderInfo as Hdr

20import Development.IDE.Types.Diagnostics

21−import Development.IDE.Types.Location

22import Development.IDE.GHC.Error

21import Development.IDE.GHC.Error

23import SysTools (Option (..), runUnlit, runPp)

22import SysTools (Option (..), runUnlit, runPp)

24import Control.Monad.Trans.Except

23import Control.Monad.Trans.Except

25import qualified GHC.LanguageExtensions as LangExt

24import qualified GHC.LanguageExtensions as LangExt

26import Data.Maybe

25import Data.Maybe

27−import Control.Exception.Safe (catch, throw)

28−import Data.IORef (IORef, modifyIORef, newIORef, readIORef)

29−import Data.Text (Text)

30−import qualified Data.Text as T

31−import Outputable (showSDoc)

32−import Control.DeepSeq (NFData(rnf))

33−import Control.Exception (evaluate)

34−import Control.Monad.IO.Class (MonadIO)

35−import Exception (ExceptionMonad)

38-- | Given a file and some contents, apply any necessary preprocessors,

28-- | Given a file and some contents, apply any necessary preprocessors,

39-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.

29-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.

40−preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)

30+preprocessor :: GhcMonad m => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)

41preprocessor filename mbContents = do

31preprocessor filename mbContents = do

42 -- Perform unlit

32 -- Perform unlit

43 (isOnDisk, contents) <-

33 (isOnDisk, contents) <-

@@ -56,18 +46,7 @@ preprocessor filename mbContents = do

56 if not $ xopt LangExt.Cpp dflags then

46 if not $ xopt LangExt.Cpp dflags then

57 return (isOnDisk, contents, dflags)

47 return (isOnDisk, contents, dflags)

58 else do

48 else do

59− cppLogs <- liftIO $ newIORef []

60− contents <- ExceptT

61− $ liftIO

62− $ (Right <$> (runCpp dflags {log_action = logAction cppLogs} filename

63− $ if isOnDisk then Nothing else Just contents))

49+ contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents

64− `catch`

65− ( \(e :: GhcException) -> do

66− logs <- readIORef cppLogs

67− case diagsFromCPPLogs filename (reverse logs) of

68− [] -> throw e

69− diags -> return $ Left diags

70− )

71 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents

50 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents

72 return (False, contents, dflags)

51 return (False, contents, dflags)

@@ -78,53 +57,6 @@ preprocessor filename mbContents = do

78 contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents

57 contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents

79 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents

58 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents

80 return (contents, dflags)

59 return (contents, dflags)

81− where

82− logAction :: IORef [CPPLog] -> LogAction

83− logAction cppLogs dflags _reason severity srcSpan _style msg = do

84− let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg

85− modifyIORef cppLogs (log :)

86−

87−

88−data CPPLog = CPPLog Severity SrcSpan Text

89− deriving (Show)

90−

91−

92−data CPPDiag

93− = CPPDiag

94− { cdRange :: Range,

95− cdSeverity :: Maybe DiagnosticSeverity,

96− cdMessage :: [Text]

97− }

98− deriving (Show)

99−

100−

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

102−diagsFromCPPLogs filename logs =

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

104− go [] logs

105− where

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

107− -- then additional informational logs with `UnhelpfulSpan`. Collect those

108− -- informational log messages and attaches them to the initial log message.

109− go :: [CPPDiag] -> [CPPLog] -> [CPPDiag]

110− go acc [] = reverse $ map (\d -> d {cdMessage = reverse $ cdMessage d}) acc

111− go acc (CPPLog sev span@(RealSrcSpan _) msg : logs) =

112− let diag = CPPDiag (srcSpanToRange span) (toDSeverity sev) [msg]

113− in go (diag : acc) logs

114− go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) =

115− go (diag {cdMessage = msg : cdMessage diag} : diags) logs

116− go [] (CPPLog _sev (UnhelpfulSpan _) _msg : logs) = go [] logs

117− cppDiagToDiagnostic :: CPPDiag -> Diagnostic

118− cppDiagToDiagnostic d =

119− Diagnostic

120− { _range = cdRange d,

121− _severity = cdSeverity d,

122− _code = Nothing,

123− _source = Just "CPP",

124− _message = T.unlines $ cdMessage d,

125− _relatedInformation = Nothing,

126− _tags = Nothing

127− }

128

129

130isLiterate :: FilePath -> Bool

62isLiterate :: FilePath -> Bool

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

133

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

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

135parsePragmasIntoDynFlags

67parsePragmasIntoDynFlags

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

68+ :: GhcMonad m

137 => FilePath

69 => FilePath

138 -> SB.StringBuffer

70 -> SB.StringBuffer

139 -> m (Either [FileDiagnostic] DynFlags)

71 -> m (Either [FileDiagnostic] DynFlags)

140parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do

72parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do

141− dflags0 <- getDynFlags

73+ dflags0 <- getSessionDynFlags

142 let opts = Hdr.getOptions dflags0 contents fp

74 let opts = Hdr.getOptions dflags0 contents fp

143−

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

145− liftIO $ evaluate $ rnf opts

146−

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

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

148 return dflags

76 return dflags

149

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

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

103 escape (c:cs) = c : escape cs

176 escape [] = []

104 escape [] = []

177

105

106+

178-- | Run CPP on a file

107-- | Run CPP on a file

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

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

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

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

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

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

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

183−

184 case contents of

111 case contents of

185 Nothing -> do

112 Nothing -> do

186 -- Happy case, file is not modified, so run CPP on it in-place

113 -- Happy case, file is not modified, so run CPP on it in-place

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

@@ -15,6 +15,7 @@ import Control.DeepSeq

15import Data.Binary

16import Development.IDE.Import.DependencyInformation

17import Development.IDE.GHC.Util

18+import Development.IDE.Types.Location

18import Data.Hashable

19import Data.Hashable

19import Data.Typeable

20import Data.Typeable

20import qualified Data.Set as S

21import qualified Data.Set as S

@@ -24,9 +25,10 @@ import GHC.Generics (Generic)

24import GHC

25import GHC

25import Module (InstalledUnitId)

26import Module (InstalledUnitId)

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

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

28+import Development.IDE.GHC.Compat

30+import Development.IDE.Core.CompletionsTypes

28import Development.IDE.Spans.Type

31import Development.IDE.Spans.Type

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

32-- NOTATION

34-- NOTATION

@@ -57,27 +59,11 @@ instance Show TcModuleResult where

57instance NFData TcModuleResult where

59instance NFData TcModuleResult where

58 rnf = rwhnf

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

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

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

77type instance RuleResult TypeCheck = TcModuleResult

63type instance RuleResult TypeCheck = TcModuleResult

79-- | Information about what spans occur where, requires TypeCheck

65-- | Information about what spans occur where, requires TypeCheck

80−type instance RuleResult GetSpanInfo = SpansInfo

66+type instance RuleResult GetSpanInfo = [SpanInfo]

82-- | Convert to Core, requires TypeCheck*

68-- | Convert to Core, requires TypeCheck*

83type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)

69type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)

@@ -90,24 +76,19 @@ type instance RuleResult GhcSession = HscEnvEq

91-- | Resolve the imports in a module to the file path of a module

77-- | Resolve the imports in a module to the file path of a module

92-- in the same package or the package id of another package.

78-- in the same package or the package id of another package.

93−type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId)

79+type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe NormalizedFilePath)], S.Set InstalledUnitId)

95-- | This rule is used to report import cycles. It depends on GetDependencyInformation.

81-- | This rule is used to report import cycles. It depends on GetDependencyInformation.

96-- We cannot report the cycles directly from GetDependencyInformation since

82-- We cannot report the cycles directly from GetDependencyInformation since

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

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

98type instance RuleResult ReportImportCycles = ()

84type instance RuleResult ReportImportCycles = ()

100−-- | Read the module interface file

86+-- | Read the given HIE file.

101−type instance RuleResult GetHiFile = HiFileResult

87+type instance RuleResult GetHieFile = HieFile

102

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

89+-- | Produce completions info for a file

104−type instance RuleResult GetModIface = HiFileResult

90+type instance RuleResult ProduceCompletions = (CachedCompletions, TcModuleResult)

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

112data GetParsedModule = GetParsedModule

93data GetParsedModule = GetParsedModule

113 deriving (Eq, Show, Typeable, Generic)

94 deriving (Eq, Show, Typeable, Generic)

@@ -169,26 +150,16 @@ instance Hashable GhcSession

169instance NFData GhcSession

150instance NFData GhcSession

170instance Binary GhcSession

151instance Binary GhcSession

171

152

172−data GetHiFile = GetHiFile

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

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

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

174−instance Hashable GetHiFile

155+data GetHieFile = GetHieFile FilePath

175−instance NFData GetHiFile

176−instance Binary GetHiFile

177−

178−data GetModIface = GetModIface

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

180−instance Hashable GetModIface

181−instance NFData GetModIface

182−instance Binary GetModIface

183−

184−data IsFileOfInterest = IsFileOfInterest

185 deriving (Eq, Show, Typeable, Generic)

156 deriving (Eq, Show, Typeable, Generic)

186−instance Hashable IsFileOfInterest

157+instance Hashable GetHieFile

187−instance NFData IsFileOfInterest

158+instance NFData GetHieFile

188−instance Binary IsFileOfInterest

159+instance Binary GetHieFile

189

160

190−data GetModSummary = GetModSummary

161+data ProduceCompletions = ProduceCompletions

191 deriving (Eq, Show, Typeable, Generic)

162 deriving (Eq, Show, Typeable, Generic)

192−instance Hashable GetModSummary

163+instance Hashable ProduceCompletions

193−instance NFData GetModSummary

164+instance NFData ProduceCompletions

194−instance Binary GetModSummary

165+instance Binary ProduceCompletions

src/Development/IDE/Core/Rules.hs+136−424

@@ -1,18 +1,16 @@

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

4−{-# LANGUAGE CPP #-}

5−{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE TypeFamilies #-}

6−{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE DuplicateRecordFields #-}

6{-# LANGUAGE DuplicateRecordFields #-}

8−#include "ghc-api-version.h"

10-- | A Shake implementation of the compiler service, built

8-- | A Shake implementation of the compiler service, built

11-- using the "Shaker" abstraction layer for in-memory use.

9-- using the "Shaker" abstraction layer for in-memory use.

12--

10--

13module Development.IDE.Core.Rules(

11module Development.IDE.Core.Rules(

14 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),

12 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),

15− Priority(..), GhcSessionIO(..), GhcSessionFun(..),

13+ Priority(..),

16 priorityTypeCheck,

14 priorityTypeCheck,

17 priorityGenerateCore,

15 priorityGenerateCore,

18 priorityFilesOfInterest,

16 priorityFilesOfInterest,

@@ -23,59 +21,52 @@ module Development.IDE.Core.Rules(

23 getDefinition,

21 getDefinition,

24 getDependencies,

22 getDependencies,

25 getParsedModule,

23 getParsedModule,

24+ fileFromParsedModule,

26 generateCore,

25 generateCore,

27 ) where

26 ) where

29import Fingerprint

28import Fingerprint

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

30+import Data.Binary

32−import Data.Bifunctor (first, second)

33−import Control.Monad.Extra

31+import Control.Monad

34import Control.Monad.Trans.Class

32import Control.Monad.Trans.Class

35import Control.Monad.Trans.Maybe

33import Control.Monad.Trans.Maybe

36import Development.IDE.Core.Compile

34import Development.IDE.Core.Compile

37−import Development.IDE.Core.OfInterest

35+import Development.IDE.Core.Completions

38import Development.IDE.Types.Options

36import Development.IDE.Types.Options

39import Development.IDE.Spans.Calculate

37import Development.IDE.Spans.Calculate

40import Development.IDE.Import.DependencyInformation

38import Development.IDE.Import.DependencyInformation

41import Development.IDE.Import.FindImports

39import Development.IDE.Import.FindImports

42−import Development.IDE.Core.FileExists

40+import Development.IDE.Core.FileStore

43−import Development.IDE.Core.FileStore (getFileContents)

44import Development.IDE.Types.Diagnostics

41import Development.IDE.Types.Diagnostics

45import Development.IDE.Types.Location

42import Development.IDE.Types.Location

46−import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)

47import Development.IDE.GHC.Util

43import Development.IDE.GHC.Util

48−import Development.IDE.GHC.WithDynFlags

44+import Data.Coerce

49import Data.Either.Extra

45import Data.Either.Extra

50import Data.Maybe

46import Data.Maybe

51import Data.Foldable

47import Data.Foldable

52import qualified Data.IntMap.Strict as IntMap

48import qualified Data.IntMap.Strict as IntMap

53−import Data.IntMap.Strict (IntMap)

49+import qualified Data.IntSet as IntSet

54import Data.List

50import Data.List

55−import Data.Ord

56import qualified Data.Set as Set

51import qualified Data.Set as Set

57import qualified Data.Text as T

52import qualified Data.Text as T

58import Development.IDE.GHC.Error

53import Development.IDE.GHC.Error

59import Development.Shake hiding (Diagnostic)

54import Development.Shake hiding (Diagnostic)

60import Development.IDE.Core.RuleTypes

55import Development.IDE.Core.RuleTypes

61−import Development.IDE.Spans.Type

62−import qualified Data.ByteString.Char8 as BS

57+import GHC hiding (parseModule, typecheckModule)

64import qualified GHC.LanguageExtensions as LangExt

58import qualified GHC.LanguageExtensions as LangExt

59+import Development.IDE.GHC.Compat (hie_file_result, readHieFile)

60+import UniqSupply

61+import NameCache

65import HscTypes

62import HscTypes

66−import PackageConfig

67−import DynFlags (gopt_set, xopt)

63+import DynFlags (xopt)

68import GHC.Generics(Generic)

64import GHC.Generics(Generic)

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

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

71import Development.IDE.Core.Service

67import Development.IDE.Core.Service

72import Development.IDE.Core.Shake

68import Development.IDE.Core.Shake

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

69+import Development.Shake.Classes

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

75−import Data.ByteString (ByteString)

76−import Control.Concurrent.Async (concurrently)

77−

78−import Control.Monad.State

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

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

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

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

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

89useE k = MaybeT . use k

80useE k = MaybeT . use k

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

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

92−useNoFileE k = useE k emptyFilePath

83+useNoFileE k = useE k ""

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

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

95usesE k = MaybeT . fmap sequence . uses k

86usesE k = MaybeT . fmap sequence . uses k

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

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

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

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

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

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

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

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

101

102

@@ -113,65 +104,18 @@ getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.T

113getAtPoint file pos = fmap join $ runMaybeT $ do

104getAtPoint file pos = fmap join $ runMaybeT $ do

114 opts <- lift getIdeOptions

105 opts <- lift getIdeOptions

115 spans <- useE GetSpanInfo file

106 spans <- useE GetSpanInfo file

107+ files <- transitiveModuleDeps <$> useE GetDependencies file

108+ tms <- usesE TypeCheck (file : files)

116− return $ AtPoint.atPoint opts spans pos

109+ return $ AtPoint.atPoint opts (map tmrModule tms) spans pos

117

110

118-- | Goto Definition.

111-- | Goto Definition.

119getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)

112getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)

120getDefinition file pos = fmap join $ runMaybeT $ do

113getDefinition file pos = fmap join $ runMaybeT $ do

121 opts <- lift getIdeOptions

114 opts <- lift getIdeOptions

122 spans <- useE GetSpanInfo file

115 spans <- useE GetSpanInfo file

116+ pkgState <- hscEnv <$> useE GhcSession file

117+ let getHieFile x = useNoFile (GetHieFile x)

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

118+ lift $ AtPoint.gotoDefinition getHieFile opts pkgState spans pos

124−

125−getHieFile

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

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

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

129−getHieFile file mod = do

130− TransitiveDependencies {transitiveNamedModuleDeps} <- use_ GetDependencies file

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

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

133− let modPath = fromNormalizedFilePath nfp

134− (_diags, hieFile) <- getHomeHieFile nfp

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

136− _ -> getPackageHieFile mod file

137−

138−

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

140−getHomeHieFile f = do

141− ms <- use_ GetModSummary f

142− let normal_hie_f = toNormalizedFilePath' hie_f

143− hie_f = ml_hie_file $ ms_location ms

144− mbHieTimestamp <- use GetModificationTime normal_hie_f

145− srcTimestamp <- use_ GetModificationTime f

146− let isUpToDate

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

148− | otherwise = False

149−

150− unless isUpToDate $

151− void $ use_ TypeCheck f

152−

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

154− return ([], hf)

155−

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

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

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

159−getPackageHieFile mod file = do

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

161− IdeOptions {..} <- getIdeOptions

162− let unitId = moduleUnitId mod

163− case lookupPackageConfig unitId pkgState of

164− Just pkgConfig -> do

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

166− hieFile <- liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod

167− path <- liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod

168− case (hieFile, path) of

169− (Just hiePath, Just modPath) ->

170− -- deliberately loaded outside the Shake graph

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

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

173− _ -> return Nothing

174− _ -> return Nothing

175

119

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

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

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

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

@@ -191,60 +135,26 @@ priorityFilesOfInterest :: Priority

191priorityFilesOfInterest = Priority (-2)

135priorityFilesOfInterest = Priority (-2)

192

136

193getParsedModuleRule :: Rules ()

137getParsedModuleRule :: Rules ()

138+getParsedModuleRule =

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

139+ defineEarlyCutoff $ \GetParsedModule file -> do

140+ (_, contents) <- getFileContents file

195− sess <- use_ GhcSession file

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

196− let hsc = hscEnv sess

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

198− -- parsed module

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

200− opt <- getIdeOptions

142+ opt <- getIdeOptions

201− (_, contents) <- getFileContents file

202−

203− let dflags = hsc_dflags hsc

204− mainParse = getParsedModuleDefinition hsc opt comp_pkgs file contents

205−

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

207− if gopt Opt_Haddock dflags

208− then

209− liftIO mainParse

210− else do

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

212− haddockParse = do

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

214− getParsedModuleDefinition hscHaddock opt comp_pkgs file contents

215− return diagsHaddock

216−

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

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

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

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

221− liftIO $ concurrently mainParse haddockParse

222−

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

224−

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

226−getParsedModuleDefinition packageState opt comp_pkgs file contents = do

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

143+ r <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents

228− case res of

144+ mbFingerprint <- traverse (const $ getSourceFingerprint file) (optShakeFiles opt)

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

230− Just (contents, modu) -> do

231− mbFingerprint <- if isNothing $ optShakeFiles opt

232− then pure Nothing

233− else Just . fingerprintToBS <$> fingerprintFromStringBuffer contents

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

145+ pure (fingerprintToBS <$> mbFingerprint, r)

235

146

236getLocatedImportsRule :: Rules ()

147getLocatedImportsRule :: Rules ()

237getLocatedImportsRule =

148getLocatedImportsRule =

238 define $ \GetLocatedImports file -> do

149 define $ \GetLocatedImports file -> do

239− ms <- use_ GetModSummary file

150+ pm <- use_ GetParsedModule file

151+ let ms = pm_mod_summary pm

240 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]

152 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]

241− env_eq <- use_ GhcSession file

153+ env <- hscEnv <$> use_ GhcSession file

242− let env = hscEnv env_eq

243− let import_dirs = deps env_eq

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

154+ let dflags = addRelativeImport file pm $ hsc_dflags env

245 opt <- getIdeOptions

155 opt <- getIdeOptions

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

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

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

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

248 case diagOrImp of

158 case diagOrImp of

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

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

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

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

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

258 Nothing -> pure (concat diags, Nothing)

168 Nothing -> pure (concat diags, Nothing)

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

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

260

170

261−type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a

262−

263−execRawDepM :: Monad m => StateT (RawDependencyInformation, IntMap a1) m a2 -> m (RawDependencyInformation, IntMap a1)

264−execRawDepM act =

265− execStateT act

266− ( RawDependencyInformation IntMap.empty emptyPathIdMap IntMap.empty

267− , IntMap.empty

268− )

269

171

270-- | Given a target file path, construct the raw dependency results by following

172-- | Given a target file path, construct the raw dependency results by following

271-- imports recursively.

173-- imports recursively.

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

174+rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation

273−rawDependencyInformation fs = do

175+rawDependencyInformation f = do

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

176+ let (initialId, initialMap) = getPathId f emptyPathIdMap

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

177+ go (IntSet.singleton $ getFilePathId initialId)

276− return (rdi { rawBootMap = bm })

178+ (RawDependencyInformation IntMap.empty initialMap)

277 where

179 where

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

180+ go fs rawDepInfo =

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

181+ case IntSet.minView fs of

280− go f = do

182+ -- Queue is empty

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

183+ Nothing -> pure rawDepInfo

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

184+ -- Pop f from the queue and process it

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

185+ Just (f, fs) -> do

284− checkAlreadyProcessed f $ do

186+ let fId = FilePathId f

285− al <- lift $ modSummaryToArtifactsLocation f <$> use_ GetModSummary f

286− -- Get a fresh FilePathId for the new file

287− fId <- getFreshFid al

288− -- Adding an edge to the bootmap so we can make sure to

289− -- insert boot nodes before the real files.

290− addBootMap al fId

291− -- Try to parse the imports of the file

292− importsOrErr <- lift $ use GetLocatedImports f

187+ importsOrErr <- use GetLocatedImports $ idToPath (rawPathIdMap rawDepInfo) fId

293− case importsOrErr of

188+ case importsOrErr of

294− Nothing -> do

189+ Nothing ->

295− -- File doesn't parse so add the module as a failure into the

190+ -- File doesn’t parse

296− -- dependency information, continue processing the other

297− -- elements in the queue

298− modifyRawDepInfo (insertImport fId (Left ModuleParseError))

191+ let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo

299− return fId

192+ in go fs rawDepInfo'

300− Just (modImports, pkgImports) -> do

193+ Just (modImports, pkgImports) -> do

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

194+ let f :: PathIdMap -> (a, Maybe NormalizedFilePath) -> (PathIdMap, (a, Maybe FilePathId))

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

195+ f pathMap (imp, mbPath) = case mbPath of

303− let (no_file, with_file) = splitImports modImports

196+ Nothing -> (pathMap, (imp, Nothing))

304− (mns, ls) = unzip with_file

197+ Just path ->

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

198+ let (pathId, pathMap') = getPathId path pathMap

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

199+ in (pathMap', (imp, Just pathId))

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

200+ -- Convert paths in imports to ids and update the path map

308− -- Associate together the ModuleName with the FilePathId

201+ let (pathIdMap, modImports') = mapAccumL f (rawPathIdMap rawDepInfo) modImports

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

202+ -- Files that we haven’t seen before are added to the queue.

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

203+ let newFiles =

311− -- imports.

204+ IntSet.fromList (coerce $ mapMaybe snd modImports')

205+ IntSet.\\ IntMap.keysSet (rawImports rawDepInfo)

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

206+ let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo

313− return fId

207+ go (newFiles `IntSet.union` fs) (rawDepInfo' { rawPathIdMap = pathIdMap })

314−

315−

316− checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId

317− checkAlreadyProcessed nfp k = do

318− (rawDepInfo, _) <- get

319− maybe k return (lookupPathToId (rawPathIdMap rawDepInfo) nfp)

320−

321− modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation) -> RawDepM ()

322− modifyRawDepInfo f = modify (first f)

323−

324− addBootMap :: ArtifactsLocation -> FilePathId -> RawDepM ()

325− addBootMap al fId =

326− modify (\(rd, ss) -> (rd, if isBootLocation al

327− then IntMap.insert (getFilePathId fId) al ss

328− else ss))

329−

330− getFreshFid :: ArtifactsLocation -> RawDepM FilePathId

331− getFreshFid al = do

332− (rawDepInfo, ss) <- get

333− let (fId, path_map) = getPathId al (rawPathIdMap rawDepInfo)

334− -- Insert the File into the bootmap if it's a boot module

335− let rawDepInfo' = rawDepInfo { rawPathIdMap = path_map }

336− put (rawDepInfo', ss)

337− return fId

338−

339− -- Split in (package imports, local imports)

340− splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)]

341− -> ([Located ModuleName], [(Located ModuleName, ArtifactsLocation)])

342− splitImports = foldr splitImportsLoop ([],[])

343−

344− splitImportsLoop (imp, Nothing) (ns, ls) = (imp:ns, ls)

345− splitImportsLoop (imp, Just artifact) (ns, ls) = (ns, (imp,artifact) : ls)

346−

347− updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =

348− if not artifactIsSource

349− then

350− let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix artifactModLocation)

351− in case msource_mod_id of

352− Just source_mod_id -> insertBootId source_mod_id (FilePathId boot_mod_id) bm

353− Nothing -> bm

354− else bm

355−

356− dropBootSuffix :: ModLocation -> FilePath

357− dropBootSuffix (ModLocation (Just hs_src) _ _) = reverse . drop (length @[] "-boot") . reverse $ hs_src

358− dropBootSuffix _ = error "dropBootSuffix"

359

208

360getDependencyInformationRule :: Rules ()

209getDependencyInformationRule :: Rules ()

361getDependencyInformationRule =

210getDependencyInformationRule =

362 define $ \GetDependencyInformation file -> do

211 define $ \GetDependencyInformation file -> do

363− rawDepInfo <- rawDependencyInformation [file]

212+ rawDepInfo <- rawDependencyInformation file

364 pure ([], Just $ processDependencyInformation rawDepInfo)

213 pure ([], Just $ processDependencyInformation rawDepInfo)

365

214

366reportImportCyclesRule :: Rules ()

215reportImportCyclesRule :: Rules ()

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

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

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

389 , _code = Nothing

238 , _code = Nothing

390 , _relatedInformation = Nothing

239 , _relatedInformation = Nothing

391− , _tags = Nothing

392 }

240 }

393 where loc = srcSpanToLocation (getLoc imp)

241 where loc = srcSpanToLocation (getLoc imp)

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

242+ fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)

395 getModuleName file = do

243 getModuleName file = do

396− ms <- use_ GetModSummary file

244+ pm <- use_ GetParsedModule file

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

245+ pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)

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

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

399

247

400-- returns all transitive dependencies in topological order.

248-- returns all transitive dependencies in topological order.

@@ -402,7 +250,7 @@ reportImportCyclesRule =

402getDependenciesRule :: Rules ()

250getDependenciesRule :: Rules ()

403getDependenciesRule =

251getDependenciesRule =

404 defineEarlyCutoff $ \GetDependencies file -> do

252 defineEarlyCutoff $ \GetDependencies file -> do

405− depInfo <- use_ GetDependencyInformation file

253+ depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file

406 let allFiles = reachableModules depInfo

254 let allFiles = reachableModules depInfo

407 _ <- uses_ ReportImportCycles allFiles

255 _ <- uses_ ReportImportCycles allFiles

408 opts <- getIdeOptions

256 opts <- getIdeOptions

@@ -414,101 +262,61 @@ getSpanInfoRule :: Rules ()

414getSpanInfoRule =

262getSpanInfoRule =

415 define $ \GetSpanInfo file -> do

263 define $ \GetSpanInfo file -> do

416 tc <- use_ TypeCheck file

264 tc <- use_ TypeCheck file

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

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

419− let tdeps = transitiveModuleDeps deps

420−

421−-- When possible, rely on the haddocks embedded in our interface files

422−-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'

423−#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)

424− let parsedDeps = []

425−#else

426− parsedDeps <- uses_ GetParsedModule tdeps

427−#endif

428−

429− ifaces <- uses_ GetModIface tdeps

430 (fileImports, _) <- use_ GetLocatedImports file

265 (fileImports, _) <- use_ GetLocatedImports file

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

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

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

267+ x <- liftIO $ getSrcSpanInfos packageState fileImports tc

433 return ([], Just x)

268 return ([], Just x)

434

269

435-- Typechecks a module.

270-- Typechecks a module.

436typeCheckRule :: Rules ()

271typeCheckRule :: Rules ()

272+typeCheckRule =

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

273+ define $ \TypeCheck file -> do

438− pm <- use_ GetParsedModule file

274+ pm <- use_ GetParsedModule file

439− -- do not generate interface files as this rule is called

440− -- for files of interest on every keystroke

441− typeCheckRuleDefinition file pm SkipGenerationOfInterfaceFiles

442−

443−data GenerateInterfaceFiles

444− = DoGenerateInterfaceFiles

445− | SkipGenerationOfInterfaceFiles

446− deriving (Show)

447−

448−-- This is factored out so it can be directly called from the GetModIface

449−-- rule. Directly calling this rule means that on the initial load we can

450−-- garbage collect all the intermediate typechecked modules rather than

451−-- retain the information forever in the shake graph.

452−typeCheckRuleDefinition

453− :: NormalizedFilePath -- ^ Path to source file

454− -> ParsedModule

455− -> GenerateInterfaceFiles -- ^ Should generate .hi and .hie files ?

456− -> Action (IdeResult TcModuleResult)

457−typeCheckRuleDefinition file pm generateArtifacts = do

458− deps <- use_ GetDependencies file

275+ deps <- use_ GetDependencies file

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

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

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

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

461− let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc

278+ let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph packageState

462− file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)

279+ file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)

463− any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq

280+ any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq

464− mirs <- uses_ GetModIface (transitiveModuleDeps deps)

465− bytecodes <- if any_uses_th_qq

281+ tms <- if any_uses_th_qq

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

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

283+ then do

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

284+ bytecodes <- uses_ GenerateByteCode (transitiveModuleDeps deps)

468− else

285+ tmrs <- uses_ TypeCheck (transitiveModuleDeps deps)

469− pure $ repeat Nothing

286+ pure (zipWith addByteCode bytecodes tmrs)

470−

287+ else uses_ TypeCheck (transitiveModuleDeps deps)

471− setPriority priorityTypeCheck

288+ setPriority priorityTypeCheck

472− IdeOptions { optDefer = defer } <- getIdeOptions

289+ IdeOptions{ optDefer = defer} <- getIdeOptions

473−

474− addUsageDependencies $ liftIO $ do

475− res <- typecheckModule defer hsc (zipWith unpack mirs bytecodes) pm

290+ liftIO $ typecheckModule defer packageState tms pm

476− case res of

477− (diags, Just (hsc,tcm)) | DoGenerateInterfaceFiles <- generateArtifacts -> do

478− diagsHie <- generateAndWriteHieFile hsc (tmrModule tcm)

479− diagsHi <- generateAndWriteHiFile hsc tcm

480− return (diags <> diagsHi <> diagsHie, Just tcm)

481− (diags, res) ->

482− return (diags, snd <$> res)

483− where

291+ where

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

485− uses_th_qq dflags =

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

292+ uses_th_qq dflags = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags

487−

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

293+ addByteCode :: Linkable -> TcModuleResult -> TcModuleResult

489− addUsageDependencies a = do

294+ addByteCode lm tmr = tmr { tmrModInfo = (tmrModInfo tmr) { hm_linkable = Just lm } }

490− r@(_, mtc) <- a

295+

491− forM_ mtc $ \tc -> do

492− let used_files = mapMaybe udep (mi_usages (hm_iface (tmrModInfo tc)))

493− udep (UsageFile fp _h) = Just fp

494− udep _ = Nothing

495− -- Add a dependency on these files which are added by things like

496− -- qAddDependentFile

497− void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files)

498− return r

499−

500−

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

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

502−generateCore runSimplifier file = do

297+generateCore file = do

503 deps <- use_ GetDependencies file

298 deps <- use_ GetDependencies file

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

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

505 setPriority priorityGenerateCore

300 setPriority priorityGenerateCore

506 packageState <- hscEnv <$> use_ GhcSession file

301 packageState <- hscEnv <$> use_ GhcSession file

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

302+ liftIO $ compileModule packageState tms tm

508

303

509generateCoreRule :: Rules ()

304generateCoreRule :: Rules ()

510generateCoreRule =

305generateCoreRule =

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

306+ define $ \GenerateCore -> generateCore

307+

308+produceCompletions :: Rules ()

309+produceCompletions =

310+ define $ \ProduceCompletions file -> do

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

312+ tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)

313+ tm <- fmap fst <$> useWithStale TypeCheck file

314+ dflags <- fmap (hsc_dflags . hscEnv . fst) <$> useWithStale GhcSession file

315+ case (tm, dflags) of

316+ (Just tm', Just dflags') -> do

317+ cdata <- liftIO $ cacheDataProducer dflags' (tmrModule tm') (map tmrModule tms)

318+ return ([], Just (cdata, tm'))

319+ _ -> return ([], Nothing)

512

320

513generateByteCodeRule :: Rules ()

321generateByteCodeRule :: Rules ()

514generateByteCodeRule =

322generateByteCodeRule =

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

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

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

518 session <- hscEnv <$> use_ GhcSession file

326 session <- hscEnv <$> use_ GhcSession file

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

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

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

328+ liftIO $ generateByteCode session tms tm guts

521

329

522-- A local rule type to get caching. We want to use newCache, but it has

330-- A local rule type to get caching. We want to use newCache, but it has

523-- thread killed exception issues, so we lift it to a full rule.

331-- thread killed exception issues, so we lift it to a full rule.

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

529instance NFData GhcSessionIO

337instance NFData GhcSessionIO

530instance Binary GhcSessionIO

338instance Binary GhcSessionIO

531

339

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

340+newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq)

533instance Show GhcSessionFun where show _ = "GhcSessionFun"

341instance Show GhcSessionFun where show _ = "GhcSessionFun"

534instance NFData GhcSessionFun where rnf !_ = ()

342instance NFData GhcSessionFun where rnf !_ = ()

535

343

@@ -538,119 +346,20 @@ loadGhcSession :: Rules ()

538loadGhcSession = do

346loadGhcSession = do

539 defineNoFile $ \GhcSessionIO -> do

347 defineNoFile $ \GhcSessionIO -> do

540 opts <- getIdeOptions

348 opts <- getIdeOptions

541− GhcSessionFun <$> optGhcSession opts

349+ liftIO $ GhcSessionFun <$> optGhcSession opts

542− -- This function should always be rerun because it consults a cache to

543− -- see what HscEnv needs to be used for the file, which can change.

544− -- However, it should also cut-off early if it's the same HscEnv as

545− -- last time

546 defineEarlyCutoff $ \GhcSession file -> do

350 defineEarlyCutoff $ \GhcSession file -> do

547 GhcSessionFun fun <- useNoFile_ GhcSessionIO

351 GhcSessionFun fun <- useNoFile_ GhcSessionIO

548− alwaysRerun

549 val <- fun $ fromNormalizedFilePath file

352 val <- fun $ fromNormalizedFilePath file

550−

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

552 opts <- getIdeOptions

353 opts <- getIdeOptions

553− let cutoffHash =

554− case optShakeFiles opts of

354+ return ("" <$ optShakeFiles opts, ([], Just val))

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

355+

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

557− Just {} -> ""

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

559− -- from last time

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

561− return (Just cutoffHash, val)

562−

563−getHiFileRule :: Rules ()

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

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

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

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

568−

569− ms <- use_ GetModSummary f

570− let hiFile = toNormalizedFilePath'

571− $ case ms_hsc_src ms of

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

573− _ -> ml_hi_file $ ms_location ms

574−

575− case sequence depHis of

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

577− Just deps -> do

578− gotHiFile <- getFileExists hiFile

579− if not gotHiFile

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

581− else do

582− hiVersion <- use_ GetModificationTime hiFile

583− modVersion <- use_ GetModificationTime f

584− let sourceModified = modificationTime hiVersion < modificationTime modVersion

585− if sourceModified

586− then do

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

588− else do

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

590− r <- liftIO $ loadInterface session ms deps

591− case r of

592− Right iface -> do

593− let result = HiFileResult ms iface

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

595− Left err -> do

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

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

598−

599−getModSummaryRule :: Rules ()

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

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

602− (_, mFileContent) <- getFileContents f

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

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

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

606−

607−getModIfaceRule :: Rules ()

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

609− fileOfInterest <- use_ IsFileOfInterest f

610− let useHiFile =

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

612− not fileOfInterest

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

614− case mbHiFile of

615− Just x ->

616− return ([], Just x)

617− Nothing

618− | fileOfInterest -> do

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

620− tmr <- use TypeCheck f

621− return ([], extract tmr)

622− | otherwise -> do

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

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

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

626− sess <- use_ GhcSession f

627− let hsc = hscEnv sess

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

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

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

631− opt <- getIdeOptions

632− (_, contents) <- getFileContents f

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

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

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

636− case mb_pm of

637− Nothing -> return (diags, Nothing)

638− Just pm -> do

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

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

641− let !res = extract tmr

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

643− where

644− extract Nothing = Nothing

645− extract (Just tmr) =

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

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

648

356

649−isFileOfInterestRule :: Rules ()

357+getHieFileRule :: Rules ()

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

358+getHieFileRule =

651− filesOfInterest <- getFilesOfInterest

359+ defineNoFile $ \(GetHieFile f) -> do

652− let res = f `elem` filesOfInterest

360+ u <- liftIO $ mkSplitUniqSupply 'a'

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

361+ let nameCache = initNameCache u []

362+ liftIO $ fmap (hie_file_result . fst) $ readHieFile nameCache f

654

363

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

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

656mainRule :: Rules ()

365mainRule :: Rules ()

@@ -665,7 +374,10 @@ mainRule = do

665 generateCoreRule

374 generateCoreRule

666 generateByteCodeRule

375 generateByteCodeRule

667 loadGhcSession

376 loadGhcSession

668− getHiFileRule

377+ getHieFileRule

669− getModIfaceRule

378+ produceCompletions

670− isFileOfInterestRule

379+

671− getModSummaryRule

380+------------------------------------------------------------

381+

382+fileFromParsedModule :: ParsedModule -> NormalizedFilePath

383+fileFromParsedModule = toNormalizedFilePath . ms_hspp_file . pm_mod_summary

src/Development/IDE/Core/Service.hs+3−10

@@ -23,16 +23,13 @@ import Control.Concurrent.Async

23import Data.Maybe

24import Development.IDE.Types.Options (IdeOptions(..))

25import Control.Monad

26−import Development.IDE.Core.Debouncer

27−import Development.IDE.Core.FileStore (VFSHandle, fileStoreRules)

26+import Development.IDE.Core.FileStore

28−import Development.IDE.Core.FileExists (fileExistsRules)

29import Development.IDE.Core.OfInterest

27import Development.IDE.Core.OfInterest

30import Development.IDE.Types.Logger

28import Development.IDE.Types.Logger

31import Development.Shake

29import Development.Shake

32import Data.Either.Extra

30import Data.Either.Extra

33import qualified Language.Haskell.LSP.Messages as LSP

31import qualified Language.Haskell.LSP.Messages as LSP

34import qualified Language.Haskell.LSP.Types as LSP

32import qualified Language.Haskell.LSP.Types as LSP

35−import qualified Language.Haskell.LSP.Types.Capabilities as LSP

37import Development.IDE.Core.Shake

34import Development.IDE.Core.Shake

@@ -45,21 +42,18 @@ instance IsIdeGlobal GlobalIdeOptions

45-- Exposed API

42-- Exposed API

47-- | Initialise the Compiler Service.

44-- | Initialise the Compiler Service.

48−initialise :: LSP.ClientCapabilities

49− -> Rules ()

45+initialise :: Rules ()

50 -> IO LSP.LspId

46 -> IO LSP.LspId

51 -> (LSP.FromServerMessage -> IO ())

47 -> (LSP.FromServerMessage -> IO ())

52 -> Logger

48 -> Logger

53− -> Debouncer LSP.NormalizedUri

54 -> IdeOptions

49 -> IdeOptions

55 -> VFSHandle

50 -> VFSHandle

56 -> IO IdeState

51 -> IO IdeState

57−initialise caps mainRule getLspId toDiags logger debouncer options vfs =

52+initialise mainRule getLspId toDiags logger options vfs =

58 shakeOpen

53 shakeOpen

59 getLspId

54 getLspId

60 toDiags

55 toDiags

61 logger

56 logger

62− debouncer

63 (optShakeProfiling options)

57 (optShakeProfiling options)

64 (optReportProgress options)

58 (optReportProgress options)

65 shakeOptions

59 shakeOptions

@@ -69,7 +63,6 @@ initialise caps mainRule getLspId toDiags logger debouncer options vfs =

69 addIdeGlobal $ GlobalIdeOptions options

63 addIdeGlobal $ GlobalIdeOptions options

70 fileStoreRules vfs

64 fileStoreRules vfs

71 ofInterestRules

65 ofInterestRules

72− fileExistsRules getLspId caps vfs

73 mainRule

66 mainRule

75writeProfile :: IdeState -> FilePath -> IO ()

68writeProfile :: IdeState -> FilePath -> IO ()

src/Development/IDE/Core/Shake.hs+146−190

@@ -19,28 +19,26 @@

19-- always stored as real Haskell values, whereas Shake serialises all 'A' values

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

21module Development.IDE.Core.Shake(

22− IdeState, shakeExtras,

22+ IdeState,

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

24 IdeRule, IdeResult, GetModificationTime(..),

23 IdeRule, IdeResult, GetModificationTime(..),

25 shakeOpen, shakeShut,

24 shakeOpen, shakeShut,

26 shakeRun,

25 shakeRun,

27 shakeProfile,

26 shakeProfile,

28 use, useWithStale, useNoFile, uses, usesWithStale,

27 use, useWithStale, useNoFile, uses, usesWithStale,

29 use_, useNoFile_, uses_,

28 use_, useNoFile_, uses_,

30− define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,

29+ define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, fingerprintToBS,

31 getDiagnostics, unsafeClearDiagnostics,

30 getDiagnostics, unsafeClearDiagnostics,

32 getHiddenDiagnostics,

31 getHiddenDiagnostics,

33− IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,

32+ IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,

34 garbageCollect,

33 garbageCollect,

35 setPriority,

34 setPriority,

36 sendEvent,

35 sendEvent,

37 ideLogger,

36 ideLogger,

38 actionLogger,

37 actionLogger,

39− FileVersion(..), modificationTime,

38+ FileVersion(..),

40 Priority(..),

39 Priority(..),

41 updatePositionMapping,

40 updatePositionMapping,

42− deleteValue,

43− OnDiskRule(..),

41+ OnDiskRule(..)

44 ) where

42 ) where

46import Development.Shake hiding (ShakeValue, doesFileExist)

44import Development.Shake hiding (ShakeValue, doesFileExist)

@@ -49,27 +47,30 @@ import Development.Shake.Classes

49import Development.Shake.Rule

47import Development.Shake.Rule

50import qualified Data.HashMap.Strict as HMap

48import qualified Data.HashMap.Strict as HMap

51import qualified Data.Map.Strict as Map

49import qualified Data.Map.Strict as Map

50+import qualified Data.Map.Merge.Strict as Map

52import qualified Data.ByteString.Char8 as BS

51import qualified Data.ByteString.Char8 as BS

52+import qualified Data.ByteString.Internal as BS

53import Data.Dynamic

54import Data.Maybe

55import Data.Map.Strict (Map)

56−import Data.List.Extra (partition, takeEnd)

56+import Data.List.Extra

57import qualified Data.Set as Set

58import qualified Data.Text as T

59−import Data.Traversable (for)

60import Data.Tuple.Extra

59import Data.Tuple.Extra

61import Data.Unique

60import Data.Unique

62import Development.IDE.Core.Debouncer

61import Development.IDE.Core.Debouncer

63import Development.IDE.Core.PositionMapping

62import Development.IDE.Core.PositionMapping

64import Development.IDE.Types.Logger hiding (Priority)

63import Development.IDE.Types.Logger hiding (Priority)

64+import Foreign.Ptr

65+import Foreign.Storable

66+import GHC.Fingerprint

65import Language.Haskell.LSP.Diagnostics

67import Language.Haskell.LSP.Diagnostics

66import qualified Data.SortedList as SL

68import qualified Data.SortedList as SL

67import Development.IDE.Types.Diagnostics

69import Development.IDE.Types.Diagnostics

68import Development.IDE.Types.Location

70import Development.IDE.Types.Location

69import Development.IDE.Types.Options

71import Development.IDE.Types.Options

70−import Control.Concurrent.Async

71import Control.Concurrent.Extra

72import Control.Concurrent.Extra

72−import Control.Exception.Extra

73+import Control.Exception

73import Control.DeepSeq

74import Control.DeepSeq

74import System.Time.Extra

75import System.Time.Extra

75import Data.Typeable

76import Data.Typeable

@@ -94,16 +95,12 @@ data ShakeExtras = ShakeExtras

94 ,state :: Var Values

95 ,state :: Var Values

95 ,diagnostics :: Var DiagnosticStore

96 ,diagnostics :: Var DiagnosticStore

96 ,hiddenDiagnostics :: Var DiagnosticStore

97 ,hiddenDiagnostics :: Var DiagnosticStore

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

98+ ,publishedDiagnostics :: Var (Map NormalizedUri [Diagnostic])

98 -- ^ This represents the set of diagnostics that we have published.

99 -- ^ This represents the set of diagnostics that we have published.

99 -- Due to debouncing not every change might get published.

100 -- Due to debouncing not every change might get published.

100− ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))

101+ ,positionMapping :: Var (Map NormalizedUri (Map TextDocumentVersion PositionMapping))

101 -- ^ Map from a text document version to a PositionMapping that describes how to map

102 -- ^ 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 -- positions in a version of that document to positions in the latest version

103− -- First mapping is delta from previous version and second one is an

104− -- accumlation of all previous mappings.

105− ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int)

106− -- ^ How many rules are running for each file

107 }

104 }

108

105

109getShakeExtras :: Action ShakeExtras

106getShakeExtras :: Action ShakeExtras

@@ -116,29 +113,22 @@ getShakeExtrasRules = do

116 Just x <- getShakeExtraRules @ShakeExtras

113 Just x <- getShakeExtraRules @ShakeExtras

117 return x

114 return x

118

115

116+

117+

119class Typeable a => IsIdeGlobal a where

118class Typeable a => IsIdeGlobal a where

120

119

121addIdeGlobal :: IsIdeGlobal a => a -> Rules ()

120addIdeGlobal :: IsIdeGlobal a => a -> Rules ()

122−addIdeGlobal x = do

121+addIdeGlobal x@(typeOf -> ty) = do

123− extras <- getShakeExtrasRules

124− liftIO $ addIdeGlobalExtras extras x

125−

126−addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()

127−addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =

122+ ShakeExtras{globals} <- getShakeExtrasRules

128 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of

123 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of

129− Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty

124+ Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty

130 Nothing -> return $! HMap.insert ty (toDyn x) mp

125 Nothing -> return $! HMap.insert ty (toDyn x) mp

131

126

132

127

133getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a

128getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a

134getIdeGlobalExtras ShakeExtras{globals} = do

129getIdeGlobalExtras ShakeExtras{globals} = do

135− let typ = typeRep (Proxy :: Proxy a)

136− x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals

130+ Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals

137− case x of

131+ return $ fromDyn x $ error "Serious error, corrupt globals"

138− Just x

139− | Just x <- fromDynamic x -> pure x

140− | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")"

141− Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ

142

132

143getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a

133getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a

144getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras

134getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras

@@ -161,7 +151,7 @@ instance Eq Key where

161 | otherwise = False

151 | otherwise = False

162

152

163instance Hashable Key where

153instance Hashable Key where

164− hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)

154+ hashWithSalt salt (Key key) = hashWithSalt salt key

165

155

166-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,

156-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,

167-- and a value is in the Maybe. For operations that throw an error you

157-- and a value is in the Maybe. For operations that throw an error you

@@ -171,6 +161,9 @@ instance Hashable Key where

171-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh

161-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh

172-- errors but still failed.

162-- errors but still failed.

173--

163--

164+-- A rule on a file should only return diagnostics for that given file. It should

165+-- not propagate diagnostic errors through multiple phases.

166+type IdeResult v = ([FileDiagnostic], Maybe v)

174

167

175data Value v

168data Value v

176 = Succeeded TextDocumentVersion v

169 = Succeeded TextDocumentVersion v

@@ -205,14 +198,14 @@ valueVersion = \case

205 Failed -> Nothing

198 Failed -> Nothing

206

199

207mappingForVersion

200mappingForVersion

208− :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))

201+ :: Map NormalizedUri (Map TextDocumentVersion PositionMapping)

209 -> NormalizedFilePath

202 -> NormalizedFilePath

210 -> TextDocumentVersion

203 -> TextDocumentVersion

211 -> PositionMapping

204 -> PositionMapping

212mappingForVersion allMappings file ver =

205mappingForVersion allMappings file ver =

213− maybe zeroMapping snd $

206+ fromMaybe idMapping $

214 Map.lookup ver =<<

207 Map.lookup ver =<<

215− HMap.lookup (filePathToUri' file) allMappings

208+ Map.lookup (filePathToUri' file) allMappings

216

209

217type IdeRule k v =

210type IdeRule k v =

218 ( Shake.RuleResult k ~ v

211 ( Shake.RuleResult k ~ v

@@ -234,15 +227,15 @@ data IdeState = IdeState

234

227

235

228

236-- This is debugging code that generates a series of profiles, if the Boolean is true

229-- This is debugging code that generates a series of profiles, if the Boolean is true

237−shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO ([a], Maybe FilePath)

230+shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO [a]

238shakeRunDatabaseProfile mbProfileDir shakeDb acts = do

231shakeRunDatabaseProfile mbProfileDir shakeDb acts = do

239 (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts

232 (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts

240− proFile <- for mbProfileDir $ \dir -> do

233+ whenJust mbProfileDir $ \dir -> do

241− count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)

234+ count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)

242− let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"

235+ let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"

243− shakeProfileDatabase shakeDb $ dir </> file

236+ shakeProfileDatabase shakeDb $ dir </> file

244− return (dir </> file)

245− return (res, proFile)

237+ return res

238+ where

246

239

247{-# NOINLINE profileStartTime #-}

240{-# NOINLINE profileStartTime #-}

248profileStartTime :: String

241profileStartTime :: String

@@ -262,16 +255,6 @@ setValues state key file val = modifyVar_ state $ \vals -> do

262 -- Force to make sure the old HashMap is not retained

255 -- Force to make sure the old HashMap is not retained

263 evaluate $ HMap.insert (file, Key key) (fmap toDyn val) vals

256 evaluate $ HMap.insert (file, Key key) (fmap toDyn val) vals

264

257

265−-- | Delete the value stored for a given ide build key

266−deleteValue

267− :: (Typeable k, Hashable k, Eq k, Show k)

268− => IdeState

269− -> k

270− -> NormalizedFilePath

271− -> IO ()

272−deleteValue IdeState{shakeExtras = ShakeExtras{state}} key file = modifyVar_ state $ \vals ->

273− evaluate $ HMap.delete (file, Key key) vals

274−

275-- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.

258-- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.

276getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))

259getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))

277getValues state key file = do

260getValues state key file = do

@@ -298,40 +281,34 @@ seqValue v b = case v of

298shakeOpen :: IO LSP.LspId

281shakeOpen :: IO LSP.LspId

299 -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler

282 -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler

300 -> Logger

283 -> Logger

301− -> Debouncer NormalizedUri

302 -> Maybe FilePath

284 -> Maybe FilePath

303 -> IdeReportProgress

285 -> IdeReportProgress

304 -> ShakeOptions

286 -> ShakeOptions

305 -> Rules ()

287 -> Rules ()

306 -> IO IdeState

288 -> IO IdeState

307−shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) opts rules = do

289+shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do

308− inProgress <- newVar HMap.empty

309 shakeExtras <- do

290 shakeExtras <- do

310 globals <- newVar HMap.empty

291 globals <- newVar HMap.empty

311 state <- newVar HMap.empty

292 state <- newVar HMap.empty

312 diagnostics <- newVar mempty

293 diagnostics <- newVar mempty

313 hiddenDiagnostics <- newVar mempty

294 hiddenDiagnostics <- newVar mempty

314 publishedDiagnostics <- newVar mempty

295 publishedDiagnostics <- newVar mempty

296+ debouncer <- newDebouncer

315− positionMapping <- newVar HMap.empty

297+ positionMapping <- newVar Map.empty

316 pure ShakeExtras{..}

298 pure ShakeExtras{..}

317 (shakeDb, shakeClose) <-

299 (shakeDb, shakeClose) <-

318 shakeOpenDatabase

300 shakeOpenDatabase

319 opts

301 opts

320 { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts

302 { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts

321− -- we don't actually use the progress value, but Shake conveniently spawns/kills this thread whenever

322− -- we call into Shake, so abuse it for that purpose

323− , shakeProgress = const $ if reportProgress then lspShakeProgress getLspId eventer inProgress else pure ()

303+ , shakeProgress = if reportProgress then lspShakeProgress getLspId eventer else const (pure ())

324 }

304 }

325 rules

305 rules

326 shakeAbort <- newMVar $ return ()

306 shakeAbort <- newMVar $ return ()

327 shakeDb <- shakeDb

307 shakeDb <- shakeDb

328 return IdeState{..}

308 return IdeState{..}

329

309

330−lspShakeProgress :: Hashable a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (HMap.HashMap a Int) -> IO ()

310+lspShakeProgress :: IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> IO Progress -> IO ()

331−lspShakeProgress getLspId sendMsg inProgress = do

311+lspShakeProgress getLspId sendMsg prog = do

332− -- first sleep a bit, so we only show progress messages if it's going to take

333− -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)

334− sleep 0.1

335 lspId <- getLspId

312 lspId <- getLspId

336 u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique

313 u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique

337 sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest

314 sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest

@@ -359,9 +336,9 @@ lspShakeProgress getLspId sendMsg inProgress = do

359 sample = 0.1

336 sample = 0.1

360 loop id prev = do

337 loop id prev = do

361 sleep sample

338 sleep sample

362− current <- readVar inProgress

339+ p <- prog

363− let done = length $ filter (== 0) $ HMap.elems current

340+ let done = countSkipped p + countBuilt p

364− let todo = HMap.size current

341+ let todo = done + countUnknown p + countTodo p

365 let next = Just $ T.pack $ show done <> "/" <> show todo

342 let next = Just $ T.pack $ show done <> "/" <> show todo

366 when (next /= prev) $

343 when (next /= prev) $

367 sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification

344 sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification

@@ -387,11 +364,11 @@ shakeShut IdeState{..} = withMVar shakeAbort $ \stop -> do

387

364

388-- | This is a variant of withMVar where the first argument is run unmasked and if it throws

365-- | This is a variant of withMVar where the first argument is run unmasked and if it throws

389-- an exception, the previous value is restored while the second argument is executed masked.

366-- an exception, the previous value is restored while the second argument is executed masked.

390−withMVar' :: MVar a -> (a -> IO ()) -> IO (a, c) -> IO c

367+withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c

391withMVar' var unmasked masked = mask $ \restore -> do

368withMVar' var unmasked masked = mask $ \restore -> do

392 a <- takeMVar var

369 a <- takeMVar var

393− restore (unmasked a) `onException` putMVar var a

370+ b <- restore (unmasked a) `onException` putMVar var a

394− (a', c) <- masked

371+ (a', c) <- masked b

395 putMVar var a'

372 putMVar var a'

396 pure c

373 pure c

397

374

@@ -403,33 +380,23 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =

403 (\stop -> do

380 (\stop -> do

404 (stopTime,_) <- duration stop

381 (stopTime,_) <- duration stop

405 logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"

382 logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"

406− )

383+ bar <- newBarrier

384+ start <- offsetTime

385+ pure (start, bar))

407 -- It is crucial to be masked here, otherwise we can get killed

386 -- It is crucial to be masked here, otherwise we can get killed

408 -- between spawning the new thread and updating shakeAbort.

387 -- between spawning the new thread and updating shakeAbort.

409 -- See https://github.com/digital-asset/ghcide/issues/79

388 -- See https://github.com/digital-asset/ghcide/issues/79

410− (do

411− start <- offsetTime

389+ (\(start, bar) -> do

412− aThread <- asyncWithUnmask $ \restore -> do

413− res <- try (restore $ shakeRunDatabaseProfile shakeProfileDir shakeDb acts)

390+ thread <- forkFinally (shakeRunDatabaseProfile shakeProfileDir shakeDb acts) $ \res -> do

414− runTime <- start

391+ runTime <- start

415− let res' = case res of

392+ let res' = case res of

416− Left e -> "exception: " <> displayException e

393+ Left e -> "exception: " <> displayException e

417− Right _ -> "completed"

394+ Right _ -> "completed"

418− profile = case res of

419− Right (_, Just fp) ->

420− let link = case filePathToUri' $ toNormalizedFilePath' fp of

421− NormalizedUri _ x -> x

422− in ", profile saved at " <> T.unpack link

423− _ -> ""

424− let logMsg = logDebug logger $ T.pack $

395+ logDebug logger $ T.pack $

425− "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ profile ++ ")"

396+ "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ ")"

426− return (fst <$> res, logMsg)

397+ signalBarrier bar res

427− let wrapUp (res, _) = do

398+ -- important: we send an async exception to the thread, then wait for it to die, before continuing

428− either (throwIO @SomeException) return res

399+ pure (killThread thread >> void (waitBarrier bar), either throwIO return =<< waitBarrier bar))

429− _ <- async $ do

430− (_, logMsg) <- wait aThread

431− logMsg

432− pure (cancel aThread, wrapUp =<< wait aThread))

433

400

434getDiagnostics :: IdeState -> IO [FileDiagnostic]

401getDiagnostics :: IdeState -> IO [FileDiagnostic]

435getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do

402getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do

@@ -456,9 +423,9 @@ garbageCollect keep = do

456 return $! dupe values

423 return $! dupe values

457 modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags

424 modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags

458 modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags

425 modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags

459− modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags

426+ modifyVar_ publishedDiagnostics $ \diags -> return $! Map.filterWithKey (\uri _ -> keep (fromUri uri)) diags

460 let versionsForFile =

427 let versionsForFile =

461− HMap.fromListWith Set.union $

428+ Map.fromListWith Set.union $

462 mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $

429 mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $

463 HMap.toList newState

430 HMap.toList newState

464 modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings

431 modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings

@@ -476,25 +443,25 @@ useWithStale :: IdeRule k v

476useWithStale key file = head <$> usesWithStale key [file]

443useWithStale key file = head <$> usesWithStale key [file]

477

444

478useNoFile :: IdeRule k v => k -> Action (Maybe v)

445useNoFile :: IdeRule k v => k -> Action (Maybe v)

479−useNoFile key = use key emptyFilePath

446+useNoFile key = use key ""

480

447

481use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v

448use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v

482use_ key file = head <$> uses_ key [file]

449use_ key file = head <$> uses_ key [file]

483

450

484useNoFile_ :: IdeRule k v => k -> Action v

451useNoFile_ :: IdeRule k v => k -> Action v

485−useNoFile_ key = use_ key emptyFilePath

452+useNoFile_ key = use_ key ""

486

453

487uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]

454uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]

488uses_ key files = do

455uses_ key files = do

489 res <- uses key files

456 res <- uses key files

490 case sequence res of

457 case sequence res of

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

458+ Nothing -> liftIO $ throwIO BadDependency

492 Just v -> return v

459 Just v -> return v

493

460

494

461

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

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

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

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

497−data BadDependency = BadDependency String deriving Show

464+data BadDependency = BadDependency deriving Show

498instance Exception BadDependency

465instance Exception BadDependency

499

466

500isBadDependency :: SomeException -> Bool

467isBadDependency :: SomeException -> Bool

@@ -513,10 +480,12 @@ instance Show k => Show (Q k) where

513

480

514-- | Invariant: the 'v' must be in normal form (fully evaluated).

481-- | Invariant: the 'v' must be in normal form (fully evaluated).

515-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database

482-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database

483+-- Note (MK) I am not sure why we need the ShakeValue here, maybe we

484+-- can just remove it?

516−newtype A v = A (Value v)

485+data A v = A (Value v) ShakeValue

517 deriving Show

486 deriving Show

518

487

519−instance NFData (A v) where rnf (A v) = v `seq` ()

488+instance NFData (A v) where rnf (A v x) = v `seq` rnf x

520

489

521-- In the Shake database we only store one type of key/result pairs,

490-- In the Shake database we only store one type of key/result pairs,

522-- namely Q (question) / A (answer).

491-- namely Q (question) / A (answer).

@@ -526,70 +495,59 @@ type instance RuleResult (Q k) = A (RuleResult k)

526-- | Return up2date results. Stale results will be ignored.

495-- | Return up2date results. Stale results will be ignored.

527uses :: IdeRule k v

496uses :: IdeRule k v

528 => k -> [NormalizedFilePath] -> Action [Maybe v]

497 => k -> [NormalizedFilePath] -> Action [Maybe v]

529−uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files)

498+uses key files = map (\(A value _) -> currentValue value) <$> apply (map (Q . (key,)) files)

530

499

531-- | Return the last computed result which might be stale.

500-- | Return the last computed result which might be stale.

532usesWithStale :: IdeRule k v

501usesWithStale :: IdeRule k v

533 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]

502 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]

534usesWithStale key files = do

503usesWithStale key files = do

535− values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files)

504+ values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)

536− zipWithM lastValue files values

505+ mapM (uncurry lastValue) (zip files values)

537−

538−

539−withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b

540−withProgress var file = actionBracket (f succ) (const $ f pred) . const

541− -- This functions are deliberately eta-expanded to avoid space leaks.

542− -- Do not remove the eta-expansion without profiling a session with at

543− -- least 1000 modifications.

544− where f shift = modifyVar_ var $ \x -> evaluate $ HMap.alter (\x -> Just $! shift (fromMaybe 0 x)) file x

545−

546

506

547defineEarlyCutoff

507defineEarlyCutoff

548 :: IdeRule k v

508 :: IdeRule k v

549 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))

509 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))

550 -> Rules ()

510 -> Rules ()

551defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do

511defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do

552− extras@ShakeExtras{state, inProgress} <- getShakeExtras

512+ extras@ShakeExtras{state} <- getShakeExtras

553− -- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key

554− (if show key == "GetFileExists" then id else withProgress inProgress file) $ do

555− val <- case old of

513+ val <- case old of

556− Just old | mode == RunDependenciesSame -> do

514+ Just old | mode == RunDependenciesSame -> do

557− v <- liftIO $ getValues state key file

515+ v <- liftIO $ getValues state key file

558− case v of

516+ case v of

559− -- No changes in the dependencies and we have

517+ -- No changes in the dependencies and we have

560− -- an existing result.

518+ -- an existing result.

561− Just v -> return $ Just $ RunResult ChangedNothing old $ A v

519+ Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)

562− _ -> return Nothing

520+ _ -> return Nothing

563− _ -> return Nothing

521+ _ -> return Nothing

564− case val of

522+ case val of

565− Just res -> return res

523+ Just res -> return res

566− Nothing -> do

524+ Nothing -> do

567− (bs, (diags, res)) <- actionCatch

525+ (bs, (diags, res)) <- actionCatch

568− (do v <- op key file; liftIO $ evaluate $ force v) $

526+ (do v <- op key file; liftIO $ evaluate $ force $ v) $

569− \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))

527+ \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))

570− modTime <- liftIO $ (currentValue =<<) <$> getValues state GetModificationTime file

528+ modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file

571− (bs, res) <- case res of

529+ (bs, res) <- case res of

572− Nothing -> do

530+ Nothing -> do

573− staleV <- liftIO $ getValues state key file

531+ staleV <- liftIO $ getValues state key file

574− pure $ case staleV of

532+ pure $ case staleV of

575− Nothing -> (toShakeValue ShakeResult bs, Failed)

533+ Nothing -> (toShakeValue ShakeResult bs, Failed)

576− Just v -> case v of

534+ Just v -> case v of

577− Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)

535+ Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)

578− Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)

536+ Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)

579− Failed -> (toShakeValue ShakeResult bs, Failed)

537+ Failed -> (toShakeValue ShakeResult bs, Failed)

580− Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)

538+ Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)

581− liftIO $ setValues state key file res

539+ liftIO $ setValues state key file res

582− updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags

540+ updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags

583− let eq = case (bs, fmap decodeShakeValue old) of

541+ let eq = case (bs, fmap decodeShakeValue old) of

584− (ShakeResult a, Just (ShakeResult b)) -> a == b

542+ (ShakeResult a, Just (ShakeResult b)) -> a == b

585− (ShakeStale a, Just (ShakeStale b)) -> a == b

543+ (ShakeStale a, Just (ShakeStale b)) -> a == b

586− -- If we do not have a previous result

544+ -- If we do not have a previous result

587− -- or we got ShakeNoCutoff we always return False.

545+ -- or we got ShakeNoCutoff we always return False.

588− _ -> False

546+ _ -> False

589− return $ RunResult

547+ return $ RunResult

590− (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)

548+ (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)

591− (encodeShakeValue bs) $

549+ (encodeShakeValue bs) $

592− A res

550+ A res bs

593

551

594

552

595-- | Rule type, input file

553-- | Rule type, input file

@@ -657,15 +615,21 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $

657 | otherwise = ChangedRecomputeDiff

615 | otherwise = ChangedRecomputeDiff

658 pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)

616 pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)

659

617

618+fingerprintToBS :: Fingerprint -> BS.ByteString

619+fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do

620+ ptr <- pure $ castPtr ptr

621+ pokeElemOff ptr 0 a

622+ pokeElemOff ptr 1 b

623+

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

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

661needOnDisk k file = do

625needOnDisk k file = do

662 successfull <- apply1 (QDisk k file)

626 successfull <- apply1 (QDisk k file)

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

627+ liftIO $ unless successfull $ throwIO BadDependency

664

628

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

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

666needOnDisks k files = do

630needOnDisks k files = do

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

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

668− liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k)

632+ liftIO $ unless (and successfulls) $ throwIO BadDependency

669

633

670toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue

634toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue

671toShakeValue = maybe ShakeNoCutoff

635toShakeValue = maybe ShakeNoCutoff

@@ -704,7 +668,7 @@ updateFileDiagnostics ::

704 -> [(ShowDiagnostic,Diagnostic)] -- ^ current results

668 -> [(ShowDiagnostic,Diagnostic)] -- ^ current results

705 -> Action ()

669 -> Action ()

706updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do

670updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do

707− modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp

671+ modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp

708 let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current

672 let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current

709 mask_ $ do

673 mask_ $ do

710 -- Mask async exceptions to ensure that updated diagnostics are always

674 -- Mask async exceptions to ensure that updated diagnostics are always

@@ -717,7 +681,7 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, published

717 let newDiags = getFileDiagnostics fp newDiagsStore

681 let newDiags = getFileDiagnostics fp newDiagsStore

718 _ <- evaluate newDiagsStore

682 _ <- evaluate newDiagsStore

719 _ <- evaluate newDiags

683 _ <- evaluate newDiags

720− pure (newDiagsStore, newDiags)

684+ pure $! (newDiagsStore, newDiags)

721 modifyVar_ hiddenDiagnostics $ \old -> do

685 modifyVar_ hiddenDiagnostics $ \old -> do

722 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)

686 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)

723 (T.pack $ show k) (map snd currentHidden) old

687 (T.pack $ show k) (map snd currentHidden) old

@@ -729,10 +693,10 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, published

729 let delay = if null newDiags then 0.1 else 0

693 let delay = if null newDiags then 0.1 else 0

730 registerEvent debouncer delay uri $ do

694 registerEvent debouncer delay uri $ do

731 mask_ $ modifyVar_ publishedDiagnostics $ \published -> do

695 mask_ $ modifyVar_ publishedDiagnostics $ \published -> do

732− let lastPublish = HMap.lookupDefault [] uri published

696+ let lastPublish = Map.findWithDefault [] uri published

733 when (lastPublish /= newDiags) $

697 when (lastPublish /= newDiags) $

734 eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags

698 eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags

735− pure $! HMap.insert uri newDiags published

699+ pure $! Map.insert uri newDiags published

736

700

737publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage

701publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage

738publishDiagnosticsNotification uri diags =

702publishDiagnosticsNotification uri diags =

@@ -743,7 +707,7 @@ publishDiagnosticsNotification uri diags =

743newtype Priority = Priority Double

707newtype Priority = Priority Double

744

708

745setPriority :: Priority -> Action ()

709setPriority :: Priority -> Action ()

746−setPriority (Priority p) = reschedule p

710+setPriority (Priority p) = deprioritize p

747

711

748sendEvent :: LSP.FromServerMessage -> Action ()

712sendEvent :: LSP.FromServerMessage -> Action ()

749sendEvent e = do

713sendEvent e = do

@@ -768,22 +732,19 @@ instance Binary GetModificationTime

768-- | Get the modification time of a file.

732-- | Get the modification time of a file.

769type instance RuleResult GetModificationTime = FileVersion

733type instance RuleResult GetModificationTime = FileVersion

770

734

771−data FileVersion

735+-- | We store the modification time as a ByteString since we need

772− = VFSVersion !Int

736+-- a ByteString anyway for Shake and we do not care about how times

737+-- are represented.

773− | ModificationTime

738+data FileVersion = VFSVersion Int | ModificationTime BS.ByteString

774− !Int -- ^ Large unit (platform dependent, do not make assumptions)

775− !Int -- ^ Small unit (platform dependent, do not make assumptions)

776 deriving (Show, Generic)

739 deriving (Show, Generic)

777

740

778instance NFData FileVersion

741instance NFData FileVersion

779

742

780vfsVersion :: FileVersion -> Maybe Int

743vfsVersion :: FileVersion -> Maybe Int

781vfsVersion (VFSVersion i) = Just i

744vfsVersion (VFSVersion i) = Just i

782−vfsVersion ModificationTime{} = Nothing

745+vfsVersion (ModificationTime _) = Nothing

746+

783

747

784−modificationTime :: FileVersion -> Maybe (Int, Int)

785−modificationTime VFSVersion{} = Nothing

786−modificationTime (ModificationTime large small) = Just (large, small)

787

748

788getDiagnosticsFromStore :: StoreItem -> [Diagnostic]

749getDiagnosticsFromStore :: StoreItem -> [Diagnostic]

789getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags

750getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags

@@ -808,7 +769,7 @@ getAllDiagnostics ::

808 DiagnosticStore ->

769 DiagnosticStore ->

809 [FileDiagnostic]

770 [FileDiagnostic]

810getAllDiagnostics =

771getAllDiagnostics =

811− concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList

772+ concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . Map.toList

812

773

813getFileDiagnostics ::

774getFileDiagnostics ::

814 NormalizedFilePath ->

775 NormalizedFilePath ->

@@ -816,34 +777,29 @@ getFileDiagnostics ::

816 [LSP.Diagnostic]

777 [LSP.Diagnostic]

817getFileDiagnostics fp ds =

778getFileDiagnostics fp ds =

818 maybe [] getDiagnosticsFromStore $

779 maybe [] getDiagnosticsFromStore $

819− HMap.lookup (filePathToUri' fp) ds

780+ Map.lookup (filePathToUri' fp) ds

820

781

821filterDiagnostics ::

782filterDiagnostics ::

822 (NormalizedFilePath -> Bool) ->

783 (NormalizedFilePath -> Bool) ->

823 DiagnosticStore ->

784 DiagnosticStore ->

824 DiagnosticStore

785 DiagnosticStore

825filterDiagnostics keep =

786filterDiagnostics keep =

826− HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri)

787+ Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)

827

788

828filterVersionMap

789filterVersionMap

829− :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)

790+ :: Map NormalizedUri (Set.Set TextDocumentVersion)

830− -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)

791+ -> Map NormalizedUri (Map TextDocumentVersion a)

831− -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)

792+ -> Map NormalizedUri (Map TextDocumentVersion a)

832filterVersionMap =

793filterVersionMap =

794+ Map.merge Map.dropMissing Map.dropMissing $

833− HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep

795+ Map.zipWithMatched $ \_ versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep

834

796

835updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()

797updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()

836−updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do

798+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do

837 modifyVar_ positionMapping $ \allMappings -> do

799 modifyVar_ positionMapping $ \allMappings -> do

838 let uri = toNormalizedUri _uri

800 let uri = toNormalizedUri _uri

839− let mappingForUri = HMap.lookupDefault Map.empty uri allMappings

801+ let mappingForUri = Map.findWithDefault Map.empty uri allMappings

840− let (_, updatedMapping) =

802+ let updatedMapping =

841− -- Very important to use mapAccum here so that the tails of

803+ Map.insert _version idMapping $

842− -- each mapping can be shared, otherwise quadratic space is

804+ Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri

843− -- used which is evident in long running sessions.

844− Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))

845− zeroMapping

846− (Map.insert _version (shared_change, zeroMapping) mappingForUri)

847− pure $! HMap.insert uri updatedMapping allMappings

805+ pure $! Map.insert uri updatedMapping allMappings

848− where

849− shared_change = mkDelta changes

src/Development/IDE/GHC/CPP.hs+5−34

@@ -19,8 +19,7 @@

19--

20-----------------------------------------------------------------------------

22−module Development.IDE.GHC.CPP(doCpp, addOptP)

22+module Development.IDE.GHC.CPP(doCpp) where

23−where

25import Development.IDE.GHC.Compat

24import Development.IDE.GHC.Compat

26import Packages

25import Packages

@@ -29,15 +28,9 @@ import Module

29import DynFlags

28import DynFlags

30import Panic

29import Panic

31import FileCleanup

30import FileCleanup

32−#if MIN_GHC_API_VERSION(8,8,2)

31+#if MIN_GHC_API_VERSION(8,8,0)

33−import LlvmCodeGen (llvmVersionList)

34−#elif MIN_GHC_API_VERSION(8,8,0)

35import LlvmCodeGen (LlvmVersion (..))

32import LlvmCodeGen (LlvmVersion (..))

36#endif

33#endif

37−#if MIN_GHC_API_VERSION (8,10,0)

38−import Fingerprint

39−import ToolSettings

40−#endif

42import System.Directory

35import System.Directory

43import System.FilePath

36import System.FilePath

@@ -64,11 +57,7 @@ doCpp dflags raw input_fn output_fn = do

64 let verbFlags = getVerbFlags dflags

57 let verbFlags = getVerbFlags dflags

66 let cpp_prog args | raw = SysTools.runCpp dflags args

59 let cpp_prog args | raw = SysTools.runCpp dflags args

67−#if MIN_GHC_API_VERSION(8,10,0)

68− | otherwise = SysTools.runCc Nothing

69−#else

70 | otherwise = SysTools.runCc

60 | otherwise = SysTools.runCc

71−#endif

72 dflags (SysTools.Option "-E" : args)

61 dflags (SysTools.Option "-E" : args)

74 let target_defs =

63 let target_defs =

@@ -125,6 +114,8 @@ doCpp dflags raw input_fn output_fn = do

125 ++ map SysTools.Option sse_defs

114 ++ map SysTools.Option sse_defs

126 ++ map SysTools.Option avx_defs

115 ++ map SysTools.Option avx_defs

127 ++ mb_macro_include

116 ++ mb_macro_include

117+ -- Define a special macro "__GHCIDE__"

118+ ++ [ SysTools.Option "-D__GHCIDE__"]

128 -- Set the language mode to assembler-with-cpp when preprocessing. This

119 -- Set the language mode to assembler-with-cpp when preprocessing. This

129 -- alleviates some of the C99 macro rules relating to whitespace and the hash

120 -- alleviates some of the C99 macro rules relating to whitespace and the hash

130 -- operator, which we tend to abuse. Clang in particular is not very happy

121 -- operator, which we tend to abuse. Clang in particular is not very happy

@@ -148,11 +139,7 @@ getBackendDefs :: DynFlags -> IO [String]

148getBackendDefs dflags | hscTarget dflags == HscLlvm = do

139getBackendDefs dflags | hscTarget dflags == HscLlvm = do

149 llvmVer <- figureLlvmVersion dflags

140 llvmVer <- figureLlvmVersion dflags

150 return $ case llvmVer of

141 return $ case llvmVer of

151−#if MIN_GHC_API_VERSION(8,8,2)

142+#if MIN_GHC_API_VERSION(8,8,0)

152− Just v

153− | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ]

154− | m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ]

155−#elif MIN_GHC_API_VERSION(8,8,0)

156 Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]

143 Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]

157 Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]

144 Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]

158#else

145#else

@@ -167,22 +154,6 @@ getBackendDefs dflags | hscTarget dflags == HscLlvm = do

167getBackendDefs _ =

154getBackendDefs _ =

168 return []

155 return []

169

156

170−addOptP :: String -> DynFlags -> DynFlags

171−#if MIN_GHC_API_VERSION (8,10,0)

172−addOptP f = alterToolSettings $ \s -> s

173− { toolSettings_opt_P = f : toolSettings_opt_P s

174− , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)

175− }

176− where

177− fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss

178− alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }

179−#else

180−addOptP opt = onSettings (onOptP (opt:))

181− where

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

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

184−#endif

185−

186-- ---------------------------------------------------------------------------

157-- ---------------------------------------------------------------------------

187-- Macros (cribbed from Cabal)

158-- Macros (cribbed from Cabal)

188

159

src/Development/IDE/GHC/Compat.hs+32−198

@@ -7,101 +7,67 @@

8-- | Attempt at hiding the GHC version differences we can.

9module Development.IDE.GHC.Compat(

10− getHeaderImports,

11 HieFileResult(..),

10 HieFileResult(..),

12− HieFile,

11+ HieFile(..),

13− hieExportNames,

14− hie_module,

15 mkHieFile,

12 mkHieFile,

16 writeHieFile,

13 writeHieFile,

17 readHieFile,

14 readHieFile,

18− supportsHieFiles,

19− setDefaultHieDir,

20− dontWriteHieFiles,

21−#if !MIN_GHC_API_VERSION(8,8,0)

22− ml_hie_file,

23−#endif

24 hPutStringBuffer,

15 hPutStringBuffer,

25 includePathsGlobal,

16 includePathsGlobal,

26 includePathsQuote,

17 includePathsQuote,

27 addIncludePathsQuote,

18 addIncludePathsQuote,

28− getModuleHash,

19+ ghcEnumerateExtensions,

29− getPackageName,

30 pattern DerivD,

20 pattern DerivD,

31 pattern ForD,

21 pattern ForD,

32 pattern InstD,

22 pattern InstD,

33 pattern TyClD,

23 pattern TyClD,

34 pattern ValD,

24 pattern ValD,

35 pattern ClassOpSig,

25 pattern ClassOpSig,

36− pattern IEThingAll,

37− pattern IEThingWith,

38− GHC.ModLocation,

39− Module.addBootSuffix,

40− pattern ModLocation,

41− getConArgs,

42−

43 module GHC

26 module GHC

44 ) where

27 ) where

46import StringBuffer

29import StringBuffer

47import DynFlags

30import DynFlags

48−import FieldLabel

31+import GHC.LanguageExtensions.Type

49−import Fingerprint (Fingerprint)

50−import qualified Module

51−import Packages

53−import qualified GHC

54−import GHC hiding (

55− ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation

56−#if MIN_GHC_API_VERSION(8,6,0)

33+#if MIN_GHC_API_VERSION(8,8,0)

57− , getConArgs

34+import Data.List.Extra (enumerate)

58#endif

35#endif

59− )

60−import qualified HeaderInfo as Hdr

61−import Avail

62−import ErrUtils (ErrorMessages)

63−import FastString (FastString)

65−#if MIN_GHC_API_VERSION(8,10,0)

37+import qualified GHC

66−import HscTypes (mi_mod_hash)

38+import GHC hiding (ClassOpSig, DerivD, ForD, InstD, TyClD, ValD)

67−#endif

69#if MIN_GHC_API_VERSION(8,8,0)

40#if MIN_GHC_API_VERSION(8,8,0)

70−import Control.Applicative ((<|>))

41+import HieAst

71−import Development.IDE.GHC.HieAst (mkHieFile)

72import HieBin

42import HieBin

73import HieTypes

43import HieTypes

74−

75−supportsHieFiles :: Bool

76−supportsHieFiles = True

77−

78−hieExportNames :: HieFile -> [(SrcSpan, Name)]

79−hieExportNames = nameListFromAvails . hie_exports

80−

81#else

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

92−import GhcPlugins hiding (ModLocation)

45+import GhcPlugins

93import NameCache

46import NameCache

47+import Avail

94import TcRnTypes

48import TcRnTypes

95import System.IO

49import System.IO

96import Foreign.ForeignPtr

50import Foreign.ForeignPtr

97−import MkIface

53+#if !MIN_GHC_API_VERSION(8,8,0)

100hPutStringBuffer :: Handle -> StringBuffer -> IO ()

54hPutStringBuffer :: Handle -> StringBuffer -> IO ()

101hPutStringBuffer hdl (StringBuffer buf len cur)

55hPutStringBuffer hdl (StringBuffer buf len cur)

102 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->

56 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->

103 hPutBuf hdl ptr len

57 hPutBuf hdl ptr len

58+#endif

59+

60+mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile

61+mkHieFile _ _ _ = return (HieFile () [])

62+

63+writeHieFile :: FilePath -> HieFile -> IO ()

64+writeHieFile _ _ = return ()

104

66+readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())

67+readHieFile _ _ = return (HieFileResult (HieFile () []), ())

68+

69+data HieFile = HieFile {hie_module :: (), hie_exports :: [AvailInfo]}

70+data HieFileResult = HieFileResult { hie_file_result :: HieFile }

105#endif

71#endif

106

107#if !MIN_GHC_API_VERSION(8,6,0)

73#if !MIN_GHC_API_VERSION(8,6,0)

@@ -119,6 +85,15 @@ addIncludePathsQuote path x = x{includePaths = f $ includePaths x}

119addIncludePathsQuote path x = x{includePaths = path : includePaths x}

85addIncludePathsQuote path x = x{includePaths = path : includePaths x}

120#endif

86#endif

121

88+ghcEnumerateExtensions :: [Extension]

89+#if MIN_GHC_API_VERSION(8,8,0)

90+ghcEnumerateExtensions = enumerate

91+#elif MIN_GHC_API_VERSION(8,6,0)

92+ghcEnumerateExtensions = [Cpp .. StarIsType]

93+#else

94+ghcEnumerateExtensions = [Cpp .. EmptyDataDeriving]

95+#endif

96+

122pattern DerivD :: DerivDecl p -> HsDecl p

97pattern DerivD :: DerivDecl p -> HsDecl p

123pattern DerivD x <-

98pattern DerivD x <-

124#if MIN_GHC_API_VERSION(8,6,0)

99#if MIN_GHC_API_VERSION(8,6,0)

@@ -166,144 +141,3 @@ pattern ClassOpSig a b c <-

166#else

141#else

167 GHC.ClassOpSig a b c

142 GHC.ClassOpSig a b c

168#endif

143#endif

169−

170−pattern IEThingWith :: LIEWrappedName (IdP pass) -> IEWildcard -> [LIEWrappedName (IdP pass)] -> [Located (FieldLbl (IdP pass))] -> IE pass

171−pattern IEThingWith a b c d <-

172−#if MIN_GHC_API_VERSION(8,6,0)

173− GHC.IEThingWith _ a b c d

174−#else

175− GHC.IEThingWith a b c d

176−#endif

177−

178−pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation

179−pattern ModLocation a b c <-

180−#if MIN_GHC_API_VERSION(8,8,0)

181− GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c ""

182−#else

183− GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c

184−#endif

185−

186−pattern IEThingAll :: LIEWrappedName (IdP pass) -> IE pass

187−pattern IEThingAll a <-

188−#if MIN_GHC_API_VERSION(8,6,0)

189− GHC.IEThingAll _ a

190−#else

191− GHC.IEThingAll a

192−#endif

193−

194−setDefaultHieDir :: FilePath -> DynFlags -> DynFlags

195−setDefaultHieDir _f d =

196−#if MIN_GHC_API_VERSION(8,8,0)

197− d { hieDir = hieDir d <|> Just _f}

198−#else

199− d

200−#endif

201−

202−dontWriteHieFiles :: DynFlags -> DynFlags

203−dontWriteHieFiles d =

204−#if MIN_GHC_API_VERSION(8,8,0)

205− gopt_unset d Opt_WriteHie

206−#else

207− d

208−#endif

209−

210−nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)]

211−nameListFromAvails as =

212− map (\n -> (nameSrcSpan n, n)) (concatMap availNames as)

213−

214−#if !MIN_GHC_API_VERSION(8,8,0)

215−-- Reimplementations of functions for HIE files for GHC 8.6

216−

217−mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> ByteString -> Hsc HieFile

218−mkHieFile ms ts _ _ = return (HieFile (ms_mod ms) es)

219− where

220− es = nameListFromAvails (mkIfaceExports (tcg_exports ts))

221−

222−ml_hie_file :: GHC.ModLocation -> FilePath

223−ml_hie_file ml = ml_hi_file ml ++ ".hie"

224−

225−data HieFile = HieFile {hie_module :: Module, hie_exports :: [(SrcSpan, Name)]}

226−

227−hieExportNames :: HieFile -> [(SrcSpan, Name)]

228−hieExportNames = hie_exports

229−

230−instance Binary HieFile where

231− put_ bh (HieFile m es) = do

232− put_ bh m

233− put_ bh es

234−

235− get bh = do

236− mod <- get bh

237− es <- get bh

238− return (HieFile mod es)

239−

240−data HieFileResult = HieFileResult { hie_file_result :: HieFile }

241−

242−writeHieFile :: FilePath -> HieFile -> IO ()

243−readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())

244−supportsHieFiles :: Bool

245−

246−#if MIN_GHC_API_VERSION(8,6,0)

247−

248−writeHieFile fp hie = do

249− bh <- openBinMem (1024 * 1024)

250− putWithUserData (const $ return ()) bh hie

251− writeBinMem bh fp

252−

253−readHieFile nc fp = do

254− bh <- readBinMem fp

255− nc' <- newIORef nc

256− hie_file <- getWithUserData (NCU (atomicModifyIORef' nc')) bh

257− return (HieFileResult hie_file, ())

258−

259−supportsHieFiles = True

260−

261−#else

262−

263−supportsHieFiles = False

264−

265−writeHieFile _ _ = return ()

266−

267−readHieFile _ _ = return undefined

268−

269−#endif

270−

271−#endif

272−

273−getHeaderImports

274− :: DynFlags

275− -> StringBuffer

276− -> FilePath

277− -> FilePath

278− -> IO

279− ( Either

280− ErrorMessages

281− ( [(Maybe FastString, Located ModuleName)]

282− , [(Maybe FastString, Located ModuleName)]

283− , Located ModuleName

284− )

285− )

286−#if MIN_GHC_API_VERSION(8,8,0)

287−getHeaderImports = Hdr.getImports

288−#else

289−getHeaderImports a b c d =

290− catch (Right <$> Hdr.getImports a b c d)

291− (return . Left . srcErrorMessages)

292−#endif

293−

294−getModuleHash :: ModIface -> Fingerprint

295−#if MIN_GHC_API_VERSION(8,10,0)

296−getModuleHash = mi_mod_hash . mi_final_exts

297−#else

298−getModuleHash = mi_mod_hash

299−#endif

300−

301−getConArgs :: ConDecl pass -> HsConDeclDetails pass

302−#if MIN_GHC_API_VERSION(8,6,0)

303−getConArgs = GHC.getConArgs

304−#else

305−getConArgs = GHC.getConDetails

306−#endif

307−

308−getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName

309−getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i))

src/Development/IDE/GHC/Error.hs+4−36

@@ -9,7 +9,6 @@ module Development.IDE.GHC.Error

9 , diagFromStrings

10 , diagFromGhcException

11 , catchSrcErrors

12− , mergeDiagnostics

14 -- * utilities working with spans

13 -- * utilities working with spans

15 , srcSpanToLocation

14 , srcSpanToLocation

@@ -17,11 +16,6 @@ module Development.IDE.GHC.Error

17 , srcSpanToFilename

16 , srcSpanToFilename

18 , zeroSpan

17 , zeroSpan

19 , realSpan

18 , realSpan

20− , isInsideSrcSpan

21− , noSpan

22−

23− -- * utilities working with severities

24− , toDSeverity

25 ) where

19 ) where

27import Development.IDE.Types.Diagnostics as D

21import Development.IDE.Types.Diagnostics as D

@@ -37,12 +31,11 @@ import Panic

37import ErrUtils

31import ErrUtils

38import SrcLoc

32import SrcLoc

39import qualified Outputable as Out

33import qualified Outputable as Out

40−import Exception (ExceptionMonad)

44diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic

37diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic

45−diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename loc,ShowDiag,)

38+diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,ShowDiag,)

46 Diagnostic

39 Diagnostic

47 { _range = srcSpanToRange loc

40 { _range = srcSpanToRange loc

48 , _severity = Just sev

41 , _severity = Just sev

@@ -50,39 +43,18 @@ diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename

50 , _message = msg

43 , _message = msg

51 , _code = Nothing

44 , _code = Nothing

52 , _relatedInformation = Nothing

45 , _relatedInformation = Nothing

53− , _tags = Nothing

54 }

46 }

56-- | Produce a GHC-style error from a source span and a message.

48-- | Produce a GHC-style error from a source span and a message.

57diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]

49diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]

58diagFromErrMsg diagSource dflags e =

50diagFromErrMsg diagSource dflags e =

59− [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $

51+ [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $ ErrUtils.pprLocErrMsg e

60− ErrUtils.formatErrDoc dflags $ ErrUtils.errMsgDoc e

61 | Just sev <- [toDSeverity $ errMsgSeverity e]]

52 | Just sev <- [toDSeverity $ errMsgSeverity e]]

64diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]

55diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]

65diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList

56diagFromErrMsgs 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

87-- | Convert a GHC SrcSpan to a DAML compiler Range

59-- | Convert a GHC SrcSpan to a DAML compiler Range

88srcSpanToRange :: SrcSpan -> Range

60srcSpanToRange :: SrcSpan -> Range

@@ -103,11 +75,7 @@ srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real

103srcSpanToLocation :: SrcSpan -> Location

75srcSpanToLocation :: SrcSpan -> Location

104srcSpanToLocation src =

76srcSpanToLocation src =

105 -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code

77 -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code

106− Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ srcSpanToFilename src) (srcSpanToRange src)

78+ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath $ srcSpanToFilename src) (srcSpanToRange src)

107−

108−isInsideSrcSpan :: Position -> SrcSpan -> Bool

109−p `isInsideSrcSpan` r = sp <= p && p <= ep

110− where Range sp ep = srcSpanToRange r

111

112-- | Convert a GHC severity to a DAML compiler Severity. Severities below

80-- | Convert a GHC severity to a DAML compiler Severity. Severities below

113-- "Warning" level are dropped (returning Nothing).

81-- "Warning" level are dropped (returning Nothing).

@@ -150,7 +118,7 @@ realSpan = \case

150

118

151-- | Run something in a Ghc monad and catch the errors (SourceErrors and

119-- | Run something in a Ghc monad and catch the errors (SourceErrors and

152-- compiler-internal exceptions like Panic or InstallationError).

120-- compiler-internal exceptions like Panic or InstallationError).

153−catchSrcErrors :: (HasDynFlags m, ExceptionMonad m) => T.Text -> m a -> m (Either [FileDiagnostic] a)

121+catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)

154catchSrcErrors fromWhere ghcM = do

122catchSrcErrors fromWhere ghcM = do

155 dflags <- getDynFlags

123 dflags <- getDynFlags

156 handleGhcException (ghcExceptionToDiagnostics dflags) $

124 handleGhcException (ghcExceptionToDiagnostics dflags) $

src/Development/IDE/GHC/Orphans.hs+3−10

@@ -1,10 +1,8 @@

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

4−{-# LANGUAGE CPP #-}

5{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

6{-# OPTIONS_GHC -Wno-orphans #-}

5{-# OPTIONS_GHC -Wno-orphans #-}

7−#include "ghc-api-version.h"

9-- | Orphan instances for GHC.

7-- | Orphan instances for GHC.

10-- Note that the 'NFData' instances may not be law abiding.

8-- Note that the 'NFData' instances may not be law abiding.

@@ -33,7 +31,7 @@ instance NFData Linkable where rnf = rwhnf

33instance Show InstalledUnitId where

31instance Show InstalledUnitId where

34 show = installedUnitIdString

32 show = installedUnitIdString

36−instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS

34+instance NFData InstalledUnitId where rnf = rwhnf

38instance NFData SB.StringBuffer where rnf = rwhnf

36instance NFData SB.StringBuffer where rnf = rwhnf

@@ -42,8 +40,8 @@ instance Show Module where

43instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint

41instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint

45−instance (NFData l, NFData e) => NFData (GenLocated l e) where

43+instance NFData (GenLocated SrcSpan ModuleName) where

46− rnf (L l e) = rnf l `seq` rnf e

44+ rnf = rwhnf

48instance Show ModSummary where

46instance Show ModSummary where

49 show = show . ms_mod

47 show = show . ms_mod

@@ -54,11 +52,6 @@ instance Show ParsedModule where

54instance NFData ModSummary where

52instance NFData ModSummary where

55 rnf = rwhnf

53 rnf = rwhnf

57−#if !MIN_GHC_API_VERSION(8,10,0)

58−instance NFData FastString where

59− rnf = rwhnf

60−#endif

61−

62instance NFData ParsedModule where

55instance NFData ParsedModule where

63 rnf = rwhnf

56 rnf = rwhnf

src/Development/IDE/GHC/Util.hs+65−146

@@ -1,83 +1,65 @@

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

4−-- | General utility functions, mostly focused around GHC operations.

4+{-# OPTIONS_GHC -Wno-missing-fields #-} -- to enable prettyPrint

5+{-# LANGUAGE CPP #-}

6+#include "ghc-api-version.h"

8+-- | GHC utility functions. Importantly, code using our GHC should never:

9+--

10+-- * Call runGhc, use runGhcFast instead. It's faster and doesn't require config we don't have.

11+--

12+-- * Call setSessionDynFlags, use modifyDynFlags instead. It's faster and avoids loading packages.

5module Development.IDE.GHC.Util(

13module Development.IDE.GHC.Util(

6− -- * HcsEnv and environment

14+ lookupPackageConfig,

7− HscEnvEq(GhcVersionMismatch, compileTime, runTime), hscEnv, newHscEnvEq,

8 modifyDynFlags,

15 modifyDynFlags,

9− evalGhcEnv,

16+ fakeDynFlags,

10− runGhcEnv,

11− deps,

12− -- * GHC wrappers

13 prettyPrint,

17 prettyPrint,

14− printRdrName,

18+ runGhcEnv,

15− printName,

16− ParseResult(..), runParser,

17− lookupPackageConfig,

18 textToStringBuffer,

19 textToStringBuffer,

19− stringBufferToByteString,

20 moduleImportPath,

21− cgGutsToCoreModule,

21+ HscEnvEq, hscEnv, newHscEnvEq,

22− fingerprintToBS,

23− fingerprintFromStringBuffer,

24− -- * General utilities

25 readFileUtf8,

22 readFileUtf8,

26 hDuplicateTo',

23 hDuplicateTo',

27− setDefaultHieDir,

24+ cgGutsToCoreModule

28− dontWriteHieFiles

29 ) where

25 ) where

27+import Config

31import Control.Concurrent

28import Control.Concurrent

32import Data.List.Extra

29import Data.List.Extra

33−import Data.ByteString.Internal (ByteString(..))

34import Data.Maybe

30import Data.Maybe

35import Data.Typeable

31import Data.Typeable

36−import qualified Data.ByteString.Internal as BS

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

37import Fingerprint

33import Fingerprint

34+#endif

35+import GHC

38import GhcMonad

36import GhcMonad

39−import Control.Exception

37+import GhcPlugins hiding (Unique)

40import Data.IORef

38import Data.IORef

41−import Data.Version (showVersion, Version)

39+import Control.Exception

42import FileCleanup

40import FileCleanup

43−import Foreign.Ptr

44−import Foreign.ForeignPtr

45−import Foreign.Storable

46import GHC.IO.BufferedIO (BufferedIO)

41import GHC.IO.BufferedIO (BufferedIO)

47import GHC.IO.Device as IODevice

42import GHC.IO.Device as IODevice

48import GHC.IO.Encoding

43import GHC.IO.Encoding

49import GHC.IO.Exception

44import GHC.IO.Exception

50import GHC.IO.Handle.Types

45import GHC.IO.Handle.Types

51import GHC.IO.Handle.Internals

46import GHC.IO.Handle.Internals

47+import Platform

52import Data.Unique

48import Data.Unique

53import Development.Shake.Classes

49import Development.Shake.Classes

54import qualified Data.Text as T

50import qualified Data.Text as T

55import qualified Data.Text.Encoding as T

51import qualified Data.Text.Encoding as T

56import qualified Data.Text.Encoding.Error as T

52import qualified Data.Text.Encoding.Error as T

57import qualified Data.ByteString as BS

53import qualified Data.ByteString as BS

58−import Lexer

59import StringBuffer

54import StringBuffer

60import System.FilePath

55import System.FilePath

61−import HscTypes (cg_binds, md_types, cg_module, ModDetails, CgGuts, ic_dflags, hsc_IC, HscEnv(hsc_dflags))

62−import PackageConfig (PackageConfig)

63−import Outputable (showSDocUnsafe, ppr, showSDoc, Outputable)

64−import Packages (getPackageConfigMap, lookupPackage')

65−import SrcLoc (mkRealSrcLoc)

66−import FastString (mkFastString)

67−import DynFlags (emptyFilesToClean, unsafeGlobalDynFlags)

68−import Module (moduleNameSlashes, InstalledUnitId)

69−import OccName (parenSymOcc)

70−import RdrName (nameRdrName, rdrNameOcc)

72−import Development.IDE.GHC.Compat as GHC

73import Development.IDE.Types.Location

57import Development.IDE.Types.Location

76----------------------------------------------------------------------

60----------------------------------------------------------------------

77-- GHC setup

61-- GHC setup

79−-- | Used to modify dyn flags in preference to calling 'setSessionDynFlags',

80−-- since that function also reloads packages (which is very slow).

81modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()

63modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()

82modifyDynFlags f = do

64modifyDynFlags f = do

83 newFlags <- f <$> getSessionDynFlags

65 newFlags <- f <$> getSessionDynFlags

@@ -86,7 +68,6 @@ modifyDynFlags f = do

86 modifySession $ \h ->

68 modifySession $ \h ->

87 h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} }

69 h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} }

89−-- | Given a 'UnitId' try and find the associated 'PackageConfig' in the environment.

90lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig

71lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig

91lookupPackageConfig unitId env =

72lookupPackageConfig unitId env =

92 lookupPackage' False pkgConfigMap unitId

73 lookupPackage' False pkgConfigMap unitId

@@ -97,134 +78,86 @@ lookupPackageConfig unitId env =

97 getPackageConfigMap $ hsc_dflags env

78 getPackageConfigMap $ hsc_dflags env

100−-- | Convert from the @text@ package to the @GHC@ 'StringBuffer'.

81+-- would be nice to do this more efficiently...

101−-- Currently implemented somewhat inefficiently (if it ever comes up in a profile).

102textToStringBuffer :: T.Text -> StringBuffer

82textToStringBuffer :: T.Text -> StringBuffer

103textToStringBuffer = stringToStringBuffer . T.unpack

83textToStringBuffer = stringToStringBuffer . T.unpack

104

105−runParser :: DynFlags -> String -> P a -> ParseResult a

106−runParser flags str parser = unP parser parseState

107− where

108− filename = "<interactive>"

109− location = mkRealSrcLoc (mkFastString filename) 1 1

110− buffer = stringToStringBuffer str

111− parseState = mkPState flags buffer location

112−

113−stringBufferToByteString :: StringBuffer -> ByteString

114−stringBufferToByteString StringBuffer{..} = PS buf cur len

115

116−-- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.

117prettyPrint :: Outputable a => a -> String

86prettyPrint :: Outputable a => a -> String

118−prettyPrint = showSDoc unsafeGlobalDynFlags . ppr

87+prettyPrint = showSDoc fakeDynFlags . ppr

119−

120−-- | Pretty print a 'RdrName' wrapping operators in parens

121−printRdrName :: RdrName -> String

122−printRdrName name = showSDocUnsafe $ parenSymOcc rn (ppr rn)

123− where

124− rn = rdrNameOcc name

125

126−-- | Pretty print a 'Name' wrapping operators in parens

127−printName :: Name -> String

128−printName = printRdrName . nameRdrName

129−

130−-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required

131−-- pieces, but designed to be more efficient than a standard 'runGhc'.

132−evalGhcEnv :: HscEnv -> Ghc b -> IO b

133−evalGhcEnv env act = snd <$> runGhcEnv env act

134−

135−-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required

136−-- pieces, but designed to be more efficient than a standard 'runGhc'.

137−runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a)

89+runGhcEnv :: HscEnv -> Ghc a -> IO a

138runGhcEnv env act = do

90runGhcEnv env act = do

139 filesToClean <- newIORef emptyFilesToClean

91 filesToClean <- newIORef emptyFilesToClean

140 dirsToClean <- newIORef mempty

92 dirsToClean <- newIORef mempty

141 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}

93 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}

142 ref <- newIORef env{hsc_dflags=dflags}

94 ref <- newIORef env{hsc_dflags=dflags}

143− res <- unGhc act (Session ref) `finally` do

95+ unGhc act (Session ref) `finally` do

144 cleanTempFiles dflags

96 cleanTempFiles dflags

145 cleanTempDirs dflags

97 cleanTempDirs dflags

146− (,res) <$> readIORef ref

147

148−-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.

99+-- Fake DynFlags which are mostly undefined, but define enough to do a

149−-- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory

100+-- little bit.

150−-- @\/usr\/Test@ should be on the include path to find sibling modules.

101+fakeDynFlags :: DynFlags

102+fakeDynFlags = defaultDynFlags settings mempty

103+ where

104+ settings = Settings

105+ { sTargetPlatform = platform

106+ , sPlatformConstants = platformConstants

107+ , sProgramName = "ghc"

108+ , sProjectVersion = cProjectVersion

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

110+ , sOpt_P_fingerprint = fingerprint0

111+#endif

112+ }

113+ platform = Platform

114+ { platformWordSize=8

115+ , platformOS=OSUnknown

116+ , platformUnregisterised=True

117+ }

118+ platformConstants = PlatformConstants

119+ { pc_DYNAMIC_BY_DEFAULT=False

120+ , pc_WORD_SIZE=8

121+ }

122+

151−moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath

123+moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath

152-- The call to takeDirectory is required since DAML does not require that

124-- The call to takeDirectory is required since DAML does not require that

153-- the file name matches the module name in the last component.

125-- the file name matches the module name in the last component.

154-- Once that has changed we can get rid of this.

126-- Once that has changed we can get rid of this.

155−moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn

127+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm

156 -- This happens for single-component modules since takeDirectory "A" == "."

128 -- This happens for single-component modules since takeDirectory "A" == "."

157 | modDir == "." = Just pathDir

129 | modDir == "." = Just pathDir

158 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir

130 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir

159 where

131 where

132+ ms = GHC.pm_mod_summary pm

133+ mod' = GHC.ms_mod ms

160 -- A for module A.B

134 -- A for module A.B

161 modDir =

135 modDir =

162 takeDirectory $

136 takeDirectory $

163− fromNormalizedFilePath $ toNormalizedFilePath' $

137+ fromNormalizedFilePath $ toNormalizedFilePath $

164− moduleNameSlashes mn

138+ moduleNameSlashes $ GHC.moduleName mod'

165

139

166−-- | An 'HscEnv' with equality. Two values are considered equal

140+-- | An HscEnv with equality.

167−-- if they are created with the same call to 'newHscEnvEq'.

168−data HscEnvEq

169− = HscEnvEq !Unique !HscEnv

141+data HscEnvEq = HscEnvEq Unique HscEnv

170− [(InstalledUnitId, DynFlags)] -- In memory components for this HscEnv

171− -- This is only used at the moment for the import dirs in

172− -- the DynFlags

173− | GhcVersionMismatch { compileTime :: !Version

174− , runTime :: !Version

175− }

176

142

177−-- | Unwrap an 'HsEnvEq'.

178hscEnv :: HscEnvEq -> HscEnv

143hscEnv :: HscEnvEq -> HscEnv

179−hscEnv = either error id . hscEnv'

180−

181−hscEnv' :: HscEnvEq -> Either String HscEnv

182−hscEnv' (HscEnvEq _ x _) = Right x

144+hscEnv (HscEnvEq _ x) = x

183−hscEnv' GhcVersionMismatch{..} = Left $

184− unwords

185− ["ghcide compiled against GHC"

186− ,showVersion compileTime

187− ,"but currently using"

188− ,showVersion runTime

189− ,". This is unsupported, ghcide must be compiled with the same GHC version as the project."

190− ]

191−

192−deps :: HscEnvEq -> [(InstalledUnitId, DynFlags)]

193−deps (HscEnvEq _ _ u) = u

194−deps GhcVersionMismatch{} = []

195

145

196−-- | Wrap an 'HscEnv' into an 'HscEnvEq'.

197−newHscEnvEq :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq

146+newHscEnvEq :: HscEnv -> IO HscEnvEq

198−newHscEnvEq e uids = do u <- newUnique; return $ HscEnvEq u e uids

147+newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e

199

148

200instance Show HscEnvEq where

149instance Show HscEnvEq where

201− show (HscEnvEq a _ _) = "HscEnvEq " ++ show (hashUnique a)

150+ show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)

202− show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)

203

151

204instance Eq HscEnvEq where

152instance Eq HscEnvEq where

205− HscEnvEq a _ _ == HscEnvEq b _ _ = a == b

153+ HscEnvEq a _ == HscEnvEq b _ = a == b

206− GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d

207− _ == _ = False

208

154

209instance NFData HscEnvEq where

155instance NFData HscEnvEq where

210− rnf (HscEnvEq a b c) = rnf (hashUnique a) `seq` b `seq` c `seq` ()

156+ rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()

211− rnf GhcVersionMismatch{} = rnf runTime

212

157

213−instance Hashable HscEnvEq where

214− hashWithSalt s (HscEnvEq a _b _c) = hashWithSalt s a

215− hashWithSalt salt GhcVersionMismatch{..} = hashWithSalt salt (compileTime, runTime)

216−

217−-- Fake instance needed to persuade Shake to accept this type as a key.

218−-- No harm done as ghcide never persists these keys currently

219−instance Binary HscEnvEq where

220− put _ = error "not really"

221− get = error "not really"

222−

223−-- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error.

224readFileUtf8 :: FilePath -> IO T.Text

158readFileUtf8 :: FilePath -> IO T.Text

225readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f

159readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f

226

160

227−-- | Convert from a 'CgGuts' to a 'CoreModule'.

228cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule

161cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule

229cgGutsToCoreModule safeMode guts modDetails = CoreModule

162cgGutsToCoreModule safeMode guts modDetails = CoreModule

230 (cg_module guts)

163 (cg_module guts)

@@ -232,22 +165,8 @@ cgGutsToCoreModule safeMode guts modDetails = CoreModule

232 (cg_binds guts)

165 (cg_binds guts)

233 safeMode

166 safeMode

234

167

235−-- | Convert a 'Fingerprint' to a 'ByteString' by copying the byte across.

236−-- Will produce an 8 byte unreadable ByteString.

237−fingerprintToBS :: Fingerprint -> BS.ByteString

238−fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do

239− ptr <- pure $ castPtr ptr

240− pokeElemOff ptr 0 a

241− pokeElemOff ptr 1 b

242−

243−-- | Take the 'Fingerprint' of a 'StringBuffer'.

244−fingerprintFromStringBuffer :: StringBuffer -> IO Fingerprint

245−fingerprintFromStringBuffer (StringBuffer buf len cur) =

246− withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len

247−

248−

249−-- | A slightly modified version of 'hDuplicateTo' from GHC.

168+-- This is a slightly modified version of hDuplicateTo in GHC.

250−-- Importantly, it avoids the bug listed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2318.

169+-- See the inline comment for more details.

251hDuplicateTo' :: Handle -> Handle -> IO ()

170hDuplicateTo' :: Handle -> Handle -> IO ()

252hDuplicateTo' h1@(FileHandle path m1) h2@(FileHandle _ m2) = do

171hDuplicateTo' h1@(FileHandle path m1) h2@(FileHandle _ m2) = do

253 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do

172 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do

src/Development/IDE/GHC/WithDynFlags.hsdeleted−30

@@ -1,30 +0,0 @@

1−module Development.IDE.GHC.WithDynFlags

2−( WithDynFlags

3−, evalWithDynFlags

4−) where

5−

6−import Control.Monad.Trans.Reader (ask, ReaderT(..))

7−import GHC (DynFlags)

8−import Control.Monad.IO.Class (MonadIO)

9−import Exception (ExceptionMonad(..))

10−import Control.Monad.Trans.Class (MonadTrans(..))

11−import GhcPlugins (HasDynFlags(..))

12−

13−-- | A monad transformer implementing the 'HasDynFlags' effect

14−newtype WithDynFlags m a = WithDynFlags {withDynFlags :: ReaderT DynFlags m a}

15− deriving (Applicative, Functor, Monad, MonadIO, MonadTrans)

16−

17−evalWithDynFlags :: DynFlags -> WithDynFlags m a -> m a

18−evalWithDynFlags dflags = flip runReaderT dflags . withDynFlags

19−

20−instance Monad m => HasDynFlags (WithDynFlags m) where

21− getDynFlags = WithDynFlags ask

22−

23−instance ExceptionMonad m => ExceptionMonad (WithDynFlags m) where

24− gmask f = WithDynFlags $ ReaderT $ \env ->

25− gmask $ \restore ->

26− let restore' = lift . restore . flip runReaderT env . withDynFlags

27− in runReaderT (withDynFlags $ f restore') env

28−

29− gcatch (WithDynFlags act) handle = WithDynFlags $ ReaderT $ \env ->

30− gcatch (runReaderT act env) (flip runReaderT env . withDynFlags . handle)

src/Development/IDE/Import/DependencyInformation.hs+34−121

@@ -9,33 +9,26 @@ module Development.IDE.Import.DependencyInformation

9 , ModuleParseError(..)

10 , TransitiveDependencies(..)

11 , FilePathId(..)

12− , NamedModuleDep(..)

14 , PathIdMap

13 , PathIdMap

15 , emptyPathIdMap

14 , emptyPathIdMap

16 , getPathId

15 , getPathId

17− , lookupPathToId

18 , insertImport

16 , insertImport

19 , pathToId

17 , pathToId

20 , idToPath

18 , idToPath

21 , reachableModules

19 , reachableModules

20+

22 , processDependencyInformation

21 , processDependencyInformation

23 , transitiveDeps

22 , transitiveDeps

24−

25− , BootIdMap

26− , insertBootId

27 ) where

23 ) where

29import Control.DeepSeq

25import Control.DeepSeq

30import Data.Bifunctor

26import Data.Bifunctor

31import Data.Coerce

27import Data.Coerce

32import Data.List

28import Data.List

33−import Data.Tuple.Extra hiding (first, second)

34import Development.IDE.GHC.Orphans()

29import Development.IDE.GHC.Orphans()

35import Data.Either

30import Data.Either

36import Data.Graph

31import Data.Graph

37−import Data.HashMap.Strict (HashMap)

38−import qualified Data.HashMap.Strict as HMS

39import Data.List.NonEmpty (NonEmpty(..), nonEmpty)

32import Data.List.NonEmpty (NonEmpty(..), nonEmpty)

40import qualified Data.List.NonEmpty as NonEmpty

33import qualified Data.List.NonEmpty as NonEmpty

41import Data.IntMap (IntMap)

34import Data.IntMap (IntMap)

@@ -43,14 +36,16 @@ import qualified Data.IntMap.Strict as IntMap

43import qualified Data.IntMap.Lazy as IntMapLazy

36import qualified Data.IntMap.Lazy as IntMapLazy

44import Data.IntSet (IntSet)

37import Data.IntSet (IntSet)

45import qualified Data.IntSet as IntSet

38import qualified Data.IntSet as IntSet

39+import Data.Map (Map)

40+import qualified Data.Map.Strict as MS

46import Data.Maybe

41import Data.Maybe

47import Data.Set (Set)

42import Data.Set (Set)

48import qualified Data.Set as Set

43import qualified Data.Set as Set

44+import Data.Tuple.Extra (fst3)

49import GHC.Generics (Generic)

45import GHC.Generics (Generic)

51import Development.IDE.Types.Diagnostics

47import Development.IDE.Types.Diagnostics

52import Development.IDE.Types.Location

48import Development.IDE.Types.Location

53−import Development.IDE.Import.FindImports (ArtifactsLocation(..))

55import GHC

50import GHC

56import Module

51import Module

@@ -62,100 +57,69 @@ data ModuleImports = ModuleImports

62 -- that module on disk (if we found it)

57 -- that module on disk (if we found it)

63 , packageImports :: !(Set InstalledUnitId)

58 , packageImports :: !(Set InstalledUnitId)

64 -- ^ Transitive package dependencies unioned for all imports.

59 -- ^ Transitive package dependencies unioned for all imports.

65− } deriving Show

60+ }

67−-- | For processing dependency information, we need lots of maps and sets of

62+-- | For processing dependency information, we need lots of maps and sets

68−-- filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet

63+-- of filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet

69−-- instead and only convert at the edges.

64+-- instead and only convert at the edges

65+-- and

70newtype FilePathId = FilePathId { getFilePathId :: Int }

66newtype FilePathId = FilePathId { getFilePathId :: Int }

71 deriving (Show, NFData, Eq, Ord)

67 deriving (Show, NFData, Eq, Ord)

73−-- | Map from 'FilePathId'

74−type FilePathIdMap = IntMap

75−

76−-- | Set of 'FilePathId's

77−type FilePathIdSet = IntSet

78−

79data PathIdMap = PathIdMap

69data PathIdMap = PathIdMap

80− { idToPathMap :: !(FilePathIdMap ArtifactsLocation)

70+ { idToPathMap :: !(IntMap NormalizedFilePath)

81− , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)

71+ , pathToIdMap :: !(Map NormalizedFilePath FilePathId)

82 }

72 }

83 deriving (Show, Generic)

73 deriving (Show, Generic)

85instance NFData PathIdMap

75instance NFData PathIdMap

87emptyPathIdMap :: PathIdMap

77emptyPathIdMap :: PathIdMap

88−emptyPathIdMap = PathIdMap IntMap.empty HMS.empty

78+emptyPathIdMap = PathIdMap IntMap.empty MS.empty

90−getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap)

80+getPathId :: NormalizedFilePath -> PathIdMap -> (FilePathId, PathIdMap)

91getPathId path m@PathIdMap{..} =

81getPathId path m@PathIdMap{..} =

92− case HMS.lookup (artifactFilePath path) pathToIdMap of

82+ case MS.lookup path pathToIdMap of

93 Nothing ->

83 Nothing ->

94− let !newId = FilePathId $ HMS.size pathToIdMap

84+ let !newId = FilePathId $ MS.size pathToIdMap

95 in (newId, insertPathId path newId m)

85 in (newId, insertPathId path newId m)

96 Just id -> (id, m)

86 Just id -> (id, m)

98−insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap

88+insertPathId :: NormalizedFilePath -> FilePathId -> PathIdMap -> PathIdMap

99insertPathId path id PathIdMap{..} =

89insertPathId path id PathIdMap{..} =

100− PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert (artifactFilePath path) id pathToIdMap)

90+ PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (MS.insert path id pathToIdMap)

101

102insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation

92insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation

103insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }

93insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }

104

105pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId

95pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId

106−pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path

96+pathToId PathIdMap{pathToIdMap} path = pathToIdMap MS.! path

107−

108−lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId

109−lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap

110

111idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath

98idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath

112−idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId

113−

114−idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation

115−idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id

99+idToPath PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id

116−

117−type BootIdMap = FilePathIdMap FilePathId

118−

119−insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap

120−insertBootId k = IntMap.insert (getFilePathId k)

121

100

122-- | Unprocessed results that we find by following imports recursively.

101-- | Unprocessed results that we find by following imports recursively.

123data RawDependencyInformation = RawDependencyInformation

102data RawDependencyInformation = RawDependencyInformation

124− { rawImports :: !(FilePathIdMap (Either ModuleParseError ModuleImports))

103+ { rawImports :: !(IntMap (Either ModuleParseError ModuleImports))

125 , rawPathIdMap :: !PathIdMap

104 , rawPathIdMap :: !PathIdMap

126− -- The rawBootMap maps the FilePathId of a hs-boot file to its

105+ }

127− -- corresponding hs file. It is used when topologically sorting as we

106+

128− -- need to add edges between .hs-boot and .hs so that the .hs files

129− -- appear later in the sort.

130− , rawBootMap :: !BootIdMap

131− } deriving Show

132−

133−pkgDependencies :: RawDependencyInformation -> FilePathIdMap (Set InstalledUnitId)

107+pkgDependencies :: RawDependencyInformation -> IntMap (Set InstalledUnitId)

134pkgDependencies RawDependencyInformation{..} =

108pkgDependencies RawDependencyInformation{..} =

135 IntMap.map (either (const Set.empty) packageImports) rawImports

109 IntMap.map (either (const Set.empty) packageImports) rawImports

136

110

137data DependencyInformation =

111data DependencyInformation =

138 DependencyInformation

112 DependencyInformation

139− { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError))

113+ { depErrorNodes :: !(IntMap (NonEmpty NodeError))

140 -- ^ Nodes that cannot be processed correctly.

114 -- ^ Nodes that cannot be processed correctly.

141− , depModuleNames :: !(FilePathIdMap ShowableModuleName)

142− , depModuleDeps :: !(FilePathIdMap FilePathIdSet)

115+ , depModuleDeps :: !(IntMap IntSet)

143 -- ^ For a non-error node, this contains the set of module immediate dependencies

116 -- ^ For a non-error node, this contains the set of module immediate dependencies

144 -- in the same package.

117 -- in the same package.

145− , depPkgDeps :: !(FilePathIdMap (Set InstalledUnitId))

118+ , depPkgDeps :: !(IntMap (Set InstalledUnitId))

146 -- ^ For a non-error node, this contains the set of immediate pkg deps.

119 -- ^ For a non-error node, this contains the set of immediate pkg deps.

147 , depPathIdMap :: !PathIdMap

120 , depPathIdMap :: !PathIdMap

148− -- ^ Map from FilePath to FilePathId

149− , depBootMap :: !BootIdMap

150− -- ^ Map from hs-boot file to the corresponding hs file

151 } deriving (Show, Generic)

121 } deriving (Show, Generic)

152

122

153−newtype ShowableModuleName =

154− ShowableModuleName {showableModuleName :: ModuleName}

155− deriving NFData

156−

157−instance Show ShowableModuleName where show = moduleNameString . showableModuleName

158−

159reachableModules :: DependencyInformation -> [NormalizedFilePath]

123reachableModules :: DependencyInformation -> [NormalizedFilePath]

160reachableModules DependencyInformation{..} =

124reachableModules DependencyInformation{..} =

161 map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps

125 map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps

@@ -222,32 +186,23 @@ processDependencyInformation rawDepInfo@RawDependencyInformation{..} =

222 DependencyInformation

186 DependencyInformation

223 { depErrorNodes = IntMap.fromList errorNodes

187 { depErrorNodes = IntMap.fromList errorNodes

224 , depModuleDeps = moduleDeps

188 , depModuleDeps = moduleDeps

225− , depModuleNames = IntMap.fromList $ coerce moduleNames

226 , depPkgDeps = pkgDependencies rawDepInfo

189 , depPkgDeps = pkgDependencies rawDepInfo

227 , depPathIdMap = rawPathIdMap

190 , depPathIdMap = rawPathIdMap

228− , depBootMap = rawBootMap

229 }

191 }

230 where resultGraph = buildResultGraph rawImports

192 where resultGraph = buildResultGraph rawImports

231 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph

193 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph

232− moduleNames :: [(FilePathId, ModuleName)]

233− moduleNames =

234− [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports]

235 successEdges :: [(FilePathId, FilePathId, [FilePathId])]

194 successEdges :: [(FilePathId, FilePathId, [FilePathId])]

236 successEdges =

195 successEdges =

237− map

238− (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports))

196+ map (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports)) successNodes

239− successNodes

240 moduleDeps =

197 moduleDeps =

241− IntMap.fromList $

242− map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs))

198+ IntMap.fromList $ map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs)) successEdges

243− successEdges

244

199

245-- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:

200-- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:

246-- 1. Mark each node that is part of an import cycle as an error node.

201-- 1. Mark each node that is part of an import cycle as an error node.

247-- 2. Mark each node that has a parse error as an error node.

202-- 2. Mark each node that has a parse error as an error node.

248-- 3. Mark each node whose immediate children could not be located as an error.

203-- 3. Mark each node whose immediate children could not be located as an error.

249-- 4. Recursively propagate errors to parents if they are not already error nodes.

204-- 4. Recursively propagate errors to parents if they are not already error nodes.

250−buildResultGraph :: FilePathIdMap (Either ModuleParseError ModuleImports) -> FilePathIdMap NodeResult

205+buildResultGraph :: IntMap (Either ModuleParseError ModuleImports) -> IntMap NodeResult

251buildResultGraph g = propagatedErrors

206buildResultGraph g = propagatedErrors

252 where

207 where

253 sccs = stronglyConnComp (graphEdges g)

208 sccs = stronglyConnComp (graphEdges g)

@@ -294,7 +249,7 @@ buildResultGraph g = propagatedErrors

294 Right ModuleImports{moduleImports} ->

249 Right ModuleImports{moduleImports} ->

295 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports

250 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports

296

251

297−graphEdges :: FilePathIdMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]

252+graphEdges :: IntMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]

298graphEdges g =

253graphEdges g =

299 map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g

254 map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g

300 where deps :: Either e ModuleImports -> [FilePathId]

255 where deps :: Either e ModuleImports -> [FilePathId]

@@ -306,71 +261,29 @@ partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest

306partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest

261partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest

307partitionSCC [] = ([], [])

262partitionSCC [] = ([], [])

308

263

309−

310transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies

264transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies

311transitiveDeps DependencyInformation{..} file = do

265transitiveDeps DependencyInformation{..} file = do

312 let !fileId = pathToId depPathIdMap file

266 let !fileId = pathToId depPathIdMap file

313 reachableVs <-

267 reachableVs <-

314− -- Delete the starting node

315 IntSet.delete (getFilePathId fileId) .

268 IntSet.delete (getFilePathId fileId) .

316 IntSet.fromList . map (fst3 . fromVertex) .

269 IntSet.fromList . map (fst3 . fromVertex) .

317 reachable g <$> toVertex (getFilePathId fileId)

270 reachable g <$> toVertex (getFilePathId fileId)

318− let transitiveModuleDepIds =

319− filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs

271+ let transitiveModuleDepIds = filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs

320 let transitivePkgDeps =

272 let transitivePkgDeps =

321 Set.toList $ Set.unions $

273 Set.toList $ Set.unions $

322 map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $

274 map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $

323 getFilePathId fileId : transitiveModuleDepIds

275 getFilePathId fileId : transitiveModuleDepIds

324− let transitiveModuleDeps =

325− map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds

276+ let transitiveModuleDeps = map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds

326− let transitiveNamedModuleDeps =

327− [ NamedModuleDep (idToPath depPathIdMap (FilePathId fid)) mn artifactModLocation

328− | (fid, ShowableModuleName mn) <- IntMap.toList depModuleNames

329− , let ArtifactsLocation{artifactModLocation} = idToPathMap depPathIdMap IntMap.! fid

330− ]

331 pure TransitiveDependencies {..}

277 pure TransitiveDependencies {..}

332− where

333− (g, fromVertex, toVertex) = graphFromEdges edges

334− edges = map (\(f, fs) -> (f, f, IntSet.toList fs ++ boot_edge f)) $ IntMap.toList depModuleDeps

278+ where (g, fromVertex, toVertex) = graphFromEdges (map (\(f, fs) -> (f, f, IntSet.toList fs)) $ IntMap.toList depModuleDeps)

335−

336− -- Need to add an edge between the .hs and .hs-boot file if it exists

337− -- so the .hs file gets loaded after the .hs-boot file and the right

338− -- stuff ends up in the HPT. If you don't have this check then GHC will

339− -- fail to work with ghcide.

340− boot_edge f = [getFilePathId f' | Just f' <- [IntMap.lookup f depBootMap]]

341−

342− vs = topSort g

279+ vs = topSort g

343

280

344data TransitiveDependencies = TransitiveDependencies

281data TransitiveDependencies = TransitiveDependencies

345 { transitiveModuleDeps :: [NormalizedFilePath]

282 { transitiveModuleDeps :: [NormalizedFilePath]

346 -- ^ Transitive module dependencies in topological order.

283 -- ^ Transitive module dependencies in topological order.

347 -- The module itself is not included.

284 -- The module itself is not included.

348− , transitiveNamedModuleDeps :: [NamedModuleDep]

349− -- ^ Transitive module dependencies in topological order.

350− -- The module itself is not included.

351 , transitivePkgDeps :: [InstalledUnitId]

285 , transitivePkgDeps :: [InstalledUnitId]

352 -- ^ Transitive pkg dependencies in unspecified order.

286 -- ^ Transitive pkg dependencies in unspecified order.

353 } deriving (Eq, Show, Generic)

287 } deriving (Eq, Show, Generic)

354

288

355instance NFData TransitiveDependencies

289instance NFData TransitiveDependencies

356−

357−data NamedModuleDep = NamedModuleDep {

358− nmdFilePath :: !NormalizedFilePath,

359− nmdModuleName :: !ModuleName,

360− nmdModLocation :: !ModLocation

361− }

362− deriving Generic

363−

364−instance Eq NamedModuleDep where

365− a == b = nmdFilePath a == nmdFilePath b

366−

367−instance NFData NamedModuleDep where

368− rnf NamedModuleDep{..} =

369− rnf nmdFilePath `seq`

370− rnf nmdModuleName `seq`

371− -- 'ModLocation' lacks an 'NFData' instance

372− rwhnf nmdModLocation

373−

374−instance Show NamedModuleDep where

375− show NamedModuleDep{..} = show nmdFilePath

376−

src/Development/IDE/Import/FindImports.hs+17−63

@@ -7,19 +7,16 @@

7module Development.IDE.Import.FindImports

8 ( locateModule

9 , Import(..)

10− , ArtifactsLocation(..)

11− , modSummaryToArtifactsLocation

12− , isBootLocation

13− , mkImportDirs

14 ) where

10 ) where

16import Development.IDE.GHC.Error as ErrUtils

12import Development.IDE.GHC.Error as ErrUtils

17import Development.IDE.GHC.Orphans()

13import Development.IDE.GHC.Orphans()

18import Development.IDE.Types.Diagnostics

14import Development.IDE.Types.Diagnostics

19import Development.IDE.Types.Location

15import Development.IDE.Types.Location

20−import Development.IDE.GHC.Compat

21-- GHC imports

16-- GHC imports

17+import DynFlags

22import FastString

18import FastString

19+import GHC

23import qualified Module as M

20import qualified Module as M

24import Packages

21import Packages

25import Outputable (showSDoc, ppr, pprPanic)

22import Outputable (showSDoc, ppr, pprPanic)

@@ -30,107 +27,64 @@ import Control.DeepSeq

30import Control.Monad.Extra

27import Control.Monad.Extra

31import Control.Monad.IO.Class

28import Control.Monad.IO.Class

32import System.FilePath

29import System.FilePath

33−import DriverPhases

34−import Data.Maybe

36data Import

31data Import

37− = FileImport !ArtifactsLocation

32+ = FileImport !NormalizedFilePath

38 | PackageImport !M.InstalledUnitId

33 | PackageImport !M.InstalledUnitId

39 deriving (Show)

34 deriving (Show)

41−data ArtifactsLocation = ArtifactsLocation

42− { artifactFilePath :: !NormalizedFilePath

43− , artifactModLocation :: !ModLocation

44− , artifactIsSource :: !Bool -- ^ True if a module is a source input

45− }

46− deriving (Show)

47−

48−instance NFData ArtifactsLocation where

49− rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource

50−

51−isBootLocation :: ArtifactsLocation -> Bool

52−isBootLocation = not . artifactIsSource

53−

54instance NFData Import where

36instance NFData Import where

55 rnf (FileImport x) = rnf x

37 rnf (FileImport x) = rnf x

56 rnf (PackageImport x) = rnf x

38 rnf (PackageImport x) = rnf x

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−

65-- | locate a module in the file system. Where we go from *daml to Haskell

41-- | locate a module in the file system. Where we go from *daml to Haskell

66locateModuleFile :: MonadIO m

42locateModuleFile :: MonadIO m

67− => [[FilePath]]

43+ => DynFlags

68 -> [String]

44 -> [String]

69 -> (NormalizedFilePath -> m Bool)

45 -> (NormalizedFilePath -> m Bool)

70 -> Bool

46 -> Bool

71 -> ModuleName

47 -> ModuleName

72 -> m (Maybe NormalizedFilePath)

48 -> m (Maybe NormalizedFilePath)

73−locateModuleFile import_dirss exts doesExist isSource modName = do

49+locateModuleFile dflags exts doesExist isSource modName = do

74− let candidates import_dirs =

50+ let candidates =

75− [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)

51+ [ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)

76− | prefix <- import_dirs , ext <- exts]

52+ | prefix <- importPaths dflags, ext <- exts]

77− findM doesExist (concatMap candidates import_dirss)

53+ findM doesExist candidates

78 where

54 where

79 maybeBoot ext

55 maybeBoot ext

80 | isSource = ext ++ "-boot"

56 | isSource = ext ++ "-boot"

81 | otherwise = ext

57 | otherwise = ext

83−-- | This function is used to map a package name to a set of import paths.

84−-- It only returns Just for unit-ids which are possible to import into the

85−-- current module. In particular, it will return Nothing for 'main' components

86−-- as they can never be imported into another package.

87−mkImportDirs :: DynFlags -> (M.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath])

88−mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i

89−

90-- | locate a module in either the file system or the package database. Where we go from *daml to

59-- | locate a module in either the file system or the package database. Where we go from *daml to

91-- Haskell

60-- Haskell

92locateModule

61locateModule

93 :: MonadIO m

62 :: MonadIO m

94 => DynFlags

63 => DynFlags

95− -> [(M.InstalledUnitId, DynFlags)] -- Sets import directories to look in

96 -> [String]

64 -> [String]

97 -> (NormalizedFilePath -> m Bool)

65 -> (NormalizedFilePath -> m Bool)

98 -> Located ModuleName

66 -> Located ModuleName

99 -> Maybe FastString

67 -> Maybe FastString

100 -> Bool

68 -> Bool

101 -> m (Either [FileDiagnostic] Import)

69 -> m (Either [FileDiagnostic] Import)

102−locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do

70+locateModule dflags exts doesExist modName mbPkgName isSource = do

103 case mbPkgName of

71 case mbPkgName of

104 -- "this" means that we should only look in the current package

72 -- "this" means that we should only look in the current package

105 Just "this" -> do

73 Just "this" -> do

106− lookupLocal [importPaths dflags]

74+ mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName

75+ case mbFile of

76+ Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []

77+ Just file -> return $ Right $ FileImport file

107 -- if a package name is given we only go look for a package

78 -- if a package name is given we only go look for a package

108− Just pkgName

109− | Just dirs <- lookup (PackageName pkgName) import_paths

110− -> lookupLocal [dirs]

111− | otherwise -> lookupInPackageDB dflags

79+ Just _pkgName -> lookupInPackageDB dflags

112 Nothing -> do

80 Nothing -> do

113 -- first try to find the module as a file. If we can't find it try to find it in the package

81 -- first try to find the module as a file. If we can't find it try to find it in the package

114 -- database.

82 -- database.

115− -- Here the importPaths for the current modules are added to the front of the import paths from the other components.

116− -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in

117− -- each component will end up being found in the wrong place and cause a multi-cradle match failure.

118− mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts doesExist isSource $ unLoc modName

83+ mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName

119 case mbFile of

84 case mbFile of

120 Nothing -> lookupInPackageDB dflags

85 Nothing -> lookupInPackageDB dflags

121− Just file -> toModLocation file

86+ Just file -> return $ Right $ FileImport file

122 where

87 where

123− import_paths = mapMaybe (mkImportDirs dflags) comp_info

124− toModLocation file = liftIO $ do

125− loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)

126− return $ Right $ FileImport $ ArtifactsLocation file loc (not isSource)

127−

128− lookupLocal dirs = do

129− mbFile <- locateModuleFile dirs exts doesExist isSource $ unLoc modName

130− case mbFile of

131− Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []

132− Just file -> toModLocation file

133−

134 lookupInPackageDB dfs =

88 lookupInPackageDB dfs =

135 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of

89 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of

136 LookupFound _m pkgConfig -> return $ Right $ PackageImport $ unitId pkgConfig

90 LookupFound _m pkgConfig -> return $ Right $ PackageImport $ unitId pkgConfig

src/Development/IDE/LSP/CodeAction.hsnew file+356

@@ -0,0 +1,356 @@

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

4+{-# LANGUAGE DuplicateRecordFields #-}

5+{-# LANGUAGE CPP #-}

6+#include "ghc-api-version.h"

8+-- | Go to the definition of a variable.

9+module Development.IDE.LSP.CodeAction

10+ ( setHandlersCodeAction

11+ , setHandlersCodeLens

12+ ) where

13+

14+import Language.Haskell.LSP.Types

15+import Development.IDE.GHC.Compat

16+import Development.IDE.Core.Rules

17+import Development.IDE.Core.RuleTypes

18+import Development.IDE.Core.Shake

19+import Development.IDE.LSP.Server

20+import Development.IDE.Types.Location

21+import qualified Data.HashMap.Strict as Map

22+import qualified Data.HashSet as Set

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

24+import Language.Haskell.LSP.VFS

25+import Language.Haskell.LSP.Messages

26+import qualified Data.Rope.UTF16 as Rope

27+import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))

28+import Control.Monad.Trans.Maybe

29+import Data.Char

30+import Data.Maybe

31+import Data.List.Extra

32+import qualified Data.Text as T

33+import Text.Regex.TDFA ((=~), (=~~))

34+import Text.Regex.TDFA.Text()

35+

36+-- | Generate code actions.

37+codeAction

38+ :: LSP.LspFuncs ()

39+ -> IdeState

40+ -> CodeActionParams

41+ -> IO (List CAResult)

42+codeAction lsp _ CodeActionParams{_textDocument=TextDocumentIdentifier uri,_context=CodeActionContext{_diagnostics=List xs}} = do

43+ -- disable logging as its quite verbose

44+ -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg

45+ contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri

46+ let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents

47+ pure $ List

48+ [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing

49+ | x <- xs, (title, tedit) <- suggestAction text x

50+ , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

51+ ]

52+

53+-- | Generate code lenses.

54+codeLens

55+ :: LSP.LspFuncs ()

56+ -> IdeState

57+ -> CodeLensParams

58+ -> IO (List CodeLens)

59+codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do

60+ case uriToFilePath' uri of

61+ Just (toNormalizedFilePath -> filePath) -> do

62+ _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath

63+ diag <- getDiagnostics ideState

64+ hDiag <- getHiddenDiagnostics ideState

65+ pure $ List

66+ [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing

67+ | (dFile, _, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag ++ hDiag

68+ , dFile == filePath

69+ , (title, tedit) <- suggestSignature False dDiag

70+ , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

71+ ]

72+ Nothing -> pure $ List []

73+

74+-- | Execute the "typesignature.add" command.

75+executeAddSignatureCommand

76+ :: LSP.LspFuncs ()

77+ -> IdeState

78+ -> ExecuteCommandParams

79+ -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

80+executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}

81+ | _command == "typesignature.add"

82+ , Just (List [edit]) <- _arguments

83+ , Success wedit <- fromJSON edit

84+ = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))

85+ | otherwise

86+ = return (Null, Nothing)

87+

88+suggestAction :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

89+suggestAction contents diag@Diagnostic{_range=_range@Range{..},..}

90+-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant

91+ | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"

92+ , Just c <- contents

93+ , importLine <- textInRange _range c

94+ = [( "Remove " <> bindings <> " from import"

95+ , [TextEdit _range (dropBindingsFromImportLine (T.splitOn "," bindings) importLine)])]

96+

97+-- File.hs:16:1: warning:

98+-- The import of `Data.List' is redundant

99+-- except perhaps to import instances from `Data.List'

100+-- To import instances alone, use: import Data.List()

101+ | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)

102+ = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]

103+

104+-- File.hs:52:41: error:

105+-- * Variable not in scope:

106+-- suggestAcion :: Maybe T.Text -> Range -> Range

107+-- * Perhaps you meant ‘suggestAction’ (line 83)

108+-- File.hs:94:37: error:

109+-- Not in scope: ‘T.isPrfixOf’

110+-- Perhaps you meant one of these:

111+-- ‘T.isPrefixOf’ (imported from Data.Text),

112+-- ‘T.isInfixOf’ (imported from Data.Text),

113+-- ‘T.isSuffixOf’ (imported from Data.Text)

114+-- Module ‘Data.Text’ does not export ‘isPrfixOf’.

115+ | renameSuggestions@(_:_) <- extractRenamableTerms _message

116+ = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]

117+

118+-- Foo.hs:3:8: error:

119+-- * Found type wildcard `_' standing for `p -> p1 -> p'

120+

121+ | "Found type wildcard" `T.isInfixOf` _message

122+ , " standing for " `T.isInfixOf` _message

123+ , typeSignature <- extractWildCardTypeSignature _message

124+ = [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]

125+

126+-- File.hs:22:8: error:

127+-- Illegal lambda-case (use -XLambdaCase)

128+-- File.hs:22:6: error:

129+-- Illegal view pattern: x -> foo

130+-- Use ViewPatterns to enable view patterns

131+-- File.hs:26:8: error:

132+-- Illegal `..' in record pattern

133+-- Use RecordWildCards to permit this

134+-- File.hs:53:28: error:

135+-- Illegal tuple section: use TupleSections

136+-- File.hs:238:29: error:

137+-- * Can't make a derived instance of `Data FSATrace':

138+-- You need DeriveDataTypeable to derive an instance for this class

139+-- * In the data declaration for `FSATrace'

140+-- C:\Neil\shake\src\Development\Shake\Command.hs:515:31: error:

141+-- * Illegal equational constraint a ~ ()

142+-- (Use GADTs or TypeFamilies to permit this)

143+-- * In the context: a ~ ()

144+-- While checking an instance declaration

145+-- In the instance declaration for `Unit (m a)'

146+ | exts@(_:_) <- filter (`Set.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message

147+ = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts]

148+

149+-- src/Development/IDE/Core/Compile.hs:58:1: error:

150+-- Could not find module ‘Data.Cha’

151+-- Perhaps you meant Data.Char (from base-4.12.0.0)

152+ | "Could not find module" `T.isInfixOf` _message

153+ , "Perhaps you meant" `T.isInfixOf` _message = let

154+ findSuggestedModules = map (head . T.words) . drop 2 . T.lines

155+ proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])

156+ in map proposeModule $ nubOrd $ findSuggestedModules _message

157+

158+-- ...Development/IDE/LSP/CodeAction.hs:103:9: warning:

159+-- * Found hole: _ :: Int -> String

160+-- * In the expression: _

161+-- In the expression: _ a

162+-- In an equation for ‘foo’: foo a = _ a

163+-- * Relevant bindings include

164+-- a :: Int

165+-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:5)

166+-- foo :: Int -> String

167+-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)

168+-- Valid hole fits include

169+-- foo :: Int -> String

170+-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)

171+-- show :: forall a. Show a => a -> String

172+-- with show @Int

173+-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37

174+-- (and originally defined in ‘GHC.Show’))

175+-- mempty :: forall a. Monoid a => a

176+-- with mempty @(Int -> String)

177+-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37

178+-- (and originally defined in ‘GHC.Base’)) (lsp-ui)

179+

180+ | topOfHoleFitsMarker `T.isInfixOf` _message = let

181+ findSuggestedHoleFits :: T.Text -> [T.Text]

182+ findSuggestedHoleFits = extractFitNames . selectLinesWithFits . dropPreceding . T.lines

183+ proposeHoleFit name = ("replace hole `" <> holeName <> "` with " <> name, [TextEdit _range name])

184+ holeName = T.strip $ last $ T.splitOn ":" $ head . T.splitOn "::" $ head $ filter ("Found hole" `T.isInfixOf`) $ T.lines _message

185+ dropPreceding = dropWhile (not . (topOfHoleFitsMarker `T.isInfixOf`))

186+ selectLinesWithFits = filter ("::" `T.isInfixOf`)

187+ extractFitNames = map (T.strip . head . T.splitOn " :: ")

188+ in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message

189+

190+ | tlb@[_] <- suggestSignature True diag = tlb

191+

192+suggestAction _ _ = []

193+

194+suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]

195+suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}

196+ | "Top-level binding with no type signature" `T.isInfixOf` _message = let

197+ filterNewlines = T.concat . T.lines

198+ unifySpaces = T.unwords . T.words

199+ signature = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message

200+ startOfLine = Position (_line _start) 0

201+ beforeLine = Range startOfLine startOfLine

202+ title = if isQuickFix then "add signature: " <> signature else signature

203+ action = TextEdit beforeLine $ signature <> "\n"

204+ in [(title, [action])]

205+suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}

206+ | "Polymorphic local binding with no type signature" `T.isInfixOf` _message = let

207+ filterNewlines = T.concat . T.lines

208+ unifySpaces = T.unwords . T.words

209+ signature = removeInitialForAll

210+ $ T.takeWhile (\x -> x/='*' && x/='•')

211+ $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message

212+ startOfLine = Position (_line _start) (_character _start)

213+ beforeLine = Range startOfLine startOfLine

214+ title = if isQuickFix then "add signature: " <> signature else signature

215+ action = TextEdit beforeLine $ signature <> "\n" <> T.replicate (_character _start) " "

216+ in [(title, [action])]

217+ where removeInitialForAll :: T.Text -> T.Text

218+ removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))

219+ | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))

220+ | otherwise = nm <> ty

221+suggestSignature _ _ = []

222+

223+topOfHoleFitsMarker :: T.Text

224+topOfHoleFitsMarker =

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

226+ "Valid hole fits include"

227+#else

228+ "Valid substitutions include"

229+#endif

230+

231+mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit

232+mkRenameEdit contents range name =

233+ if fromMaybe False maybeIsInfixFunction

234+ then TextEdit range ("`" <> name <> "`")

235+ else TextEdit range name

236+ where

237+ maybeIsInfixFunction = do

238+ curr <- textInRange range <$> contents

239+ pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr

240+

241+extractWildCardTypeSignature :: T.Text -> T.Text

242+extractWildCardTypeSignature =

243+ -- inferring when parens are actually needed around the type signature would

244+ -- require understanding both the precedence of the context of the _ and of

245+ -- the signature itself. Inserting them unconditionally is ugly but safe.

246+ ("(" `T.append`) . (`T.append` ")") .

247+ T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') .

248+ snd . T.breakOnEnd "standing for "

249+

250+extractRenamableTerms :: T.Text -> [T.Text]

251+extractRenamableTerms msg

252+ -- Account for both "Variable not in scope" and "Not in scope"

253+ | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg

254+ | otherwise = []

255+ where

256+ extractSuggestions = map getEnclosed

257+ . concatMap singleSuggestions

258+ . filter isKnownSymbol

259+ . T.lines

260+ singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited

261+ isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t

262+ getEnclosed = T.dropWhile (== '‘')

263+ . T.dropWhileEnd (== '’')

264+ . T.dropAround (\c -> c /= '‘' && c /= '’')

265+

266+-- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace

267+-- between the end of the range and the next newline), extend the range to take up the whole line.

268+extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range

269+extendToWholeLineIfPossible contents range@Range{..} =

270+ let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents

271+ extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line

272+ in if extend then Range _start (Position (_line _end + 1) 0) else range

273+

274+-- | All the GHC extensions

275+ghcExtensions :: Set.HashSet T.Text

276+ghcExtensions = Set.fromList $ map (T.pack . show) ghcEnumerateExtensions

277+

278+splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)

279+splitTextAtPosition (Position row col) x

280+ | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x

281+ , (preCol, postCol) <- T.splitAt col mid

282+ = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)

283+ | otherwise = (x, T.empty)

284+

285+textInRange :: Range -> T.Text -> T.Text

286+textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =

287+ case compare startRow endRow of

288+ LT ->

289+ let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine

290+ (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of

291+ [] -> ("", [])

292+ firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)

293+ maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines

294+ in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)

295+ EQ ->

296+ let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)

297+ in T.take (endCol - startCol) (T.drop startCol line)

298+ GT -> ""

299+ where

300+ linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)

301+

302+-- | Drop all occurrences of a binding in an import line.

303+-- Preserves well-formedness but not whitespace between bindings.

304+--

305+-- >>> dropBindingsFromImportLine ["bA", "bC"] "import A(bA, bB,bC ,bA)"

306+-- "import A(bB)"

307+--

308+-- >>> dropBindingsFromImportLine ["+"] "import "P" qualified A as B ((+))"

309+-- "import "P" qualified A() as B hiding (bB)"

310+dropBindingsFromImportLine :: [T.Text] -> T.Text -> T.Text

311+dropBindingsFromImportLine bindings_ importLine =

312+ importPre <> "(" <> importRest'

313+ where

314+ bindings = map (wrapOperatorInParens . removeQualified) bindings_

315+

316+ (importPre, importRest) = T.breakOn "(" importLine

317+

318+ wrapOperatorInParens x = if isAlpha (T.head x) then x else "(" <> x <> ")"

319+

320+ removeQualified x = case T.breakOn "." x of

321+ (_qualifier, T.uncons -> Just (_, unqualified)) -> unqualified

322+ _ -> x

323+

324+ importRest' = case T.uncons importRest of

325+ Just (_, x) ->

326+ T.intercalate ","

327+ $ joinCloseParens

328+ $ mapMaybe (filtering . T.strip)

329+ $ T.splitOn "," x

330+ Nothing -> importRest

331+

332+ filtering x = case () of

333+ () | x `elem` bindings -> Nothing

334+ () | x `elem` map (<> ")") bindings -> Just ")"

335+ _ -> Just x

336+

337+ joinCloseParens (x : ")" : rest) = (x <> ")") : joinCloseParens rest

338+ joinCloseParens (x : rest) = x : joinCloseParens rest

339+ joinCloseParens [] = []

340+

341+-- | Returns Just (the submatches) for the first capture, or Nothing.

342+matchRegex :: T.Text -> T.Text -> Maybe [T.Text]

343+matchRegex message regex = case message =~~ regex of

344+ Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings

345+ Nothing -> Nothing

346+

347+setHandlersCodeAction :: PartialHandlers

348+setHandlersCodeAction = PartialHandlers $ \WithMessage{..} x -> return x{

349+ LSP.codeActionHandler = withResponse RspCodeAction codeAction

350+ }

351+

352+setHandlersCodeLens :: PartialHandlers

353+setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{

354+ LSP.codeLensHandler = withResponse RspCodeLens codeLens,

355+ LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand

356+ }

src/Development/IDE/LSP/Completions.hsnew file+46

@@ -0,0 +1,46 @@

1+module Development.IDE.LSP.Completions (

2+ setHandlersCompletion

3+) where

5+import Language.Haskell.LSP.Messages

6+import Language.Haskell.LSP.Types

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

8+import qualified Language.Haskell.LSP.VFS as VFS

9+import Language.Haskell.LSP.Types.Capabilities

10+

11+import Development.IDE.Core.Service

12+import Development.IDE.Core.Completions

13+import Development.IDE.Types.Location

14+import Development.IDE.Core.PositionMapping

15+import Development.IDE.Core.RuleTypes

16+import Development.IDE.Core.Shake

17+import Development.IDE.LSP.Server

18+

19+-- | Generate code actions.

20+getCompletionsLSP

21+ :: LSP.LspFuncs ()

22+ -> IdeState

23+ -> CompletionParams

24+ -> IO CompletionResponseResult

25+getCompletionsLSP lsp ide CompletionParams{_textDocument=TextDocumentIdentifier uri,_position=position} = do

26+ contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri

27+ case (contents, uriToFilePath' uri) of

28+ (Just cnts, Just path) -> do

29+ let npath = toNormalizedFilePath path

30+ compls <- runAction ide (useWithStale ProduceCompletions npath)

31+ case compls of

32+ Just ((cci', tm'), mapping) -> do

33+ let position' = fromCurrentPosition mapping position

34+ pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'

35+ case pfix of

36+ Just pfix' -> do

37+ let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing

38+ Completions . List <$> getCompletions cci' (tmrModule tm') pfix' fakeClientCapabilities (WithSnippets True)

39+ _ -> return (Completions $ List [])

40+ _ -> return (Completions $ List [])

41+ _ -> return (Completions $ List [])

42+

43+setHandlersCompletion :: PartialHandlers

44+setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{

45+ LSP.completionHandler = withResponse RspCompletion getCompletionsLSP

46+ }

src/Development/IDE/LSP/HoverDefinition.hs+6−9

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

6module Development.IDE.LSP.HoverDefinition

7 ( setHandlersHover

8 , setHandlersDefinition

9− -- * For haskell-language-server

10− , hover

11− , gotoDefinition

12 ) where

9 ) where

14import Development.IDE.Core.Rules

11import Development.IDE.Core.Rules

@@ -23,8 +20,8 @@ import Language.Haskell.LSP.Types

24import qualified Data.Text as T

21import qualified Data.Text as T

26−gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)

23+gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO LocationResponseParams

27−hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))

24+hover :: IdeState -> TextDocumentPositionParams -> IO (Maybe Hover)

28gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc

25gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc

29hover = request "Hover" getAtPoint Nothing foundHover

26hover = request "Hover" getAtPoint Nothing foundHover

@@ -32,7 +29,7 @@ foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover

32foundHover (mbRange, contents) =

29foundHover (mbRange, contents) =

33 Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange

30 Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange

35−setHandlersDefinition, setHandlersHover :: PartialHandlers c

32+setHandlersDefinition, setHandlersHover :: PartialHandlers

36setHandlersDefinition = PartialHandlers $ \WithMessage{..} x ->

33setHandlersDefinition = PartialHandlers $ \WithMessage{..} x ->

37 return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition}

34 return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition}

38setHandlersHover = PartialHandlers $ \WithMessage{..} x ->

35setHandlersHover = PartialHandlers $ \WithMessage{..} x ->

@@ -46,16 +43,16 @@ request

46 -> (a -> b)

43 -> (a -> b)

47 -> IdeState

44 -> IdeState

48 -> TextDocumentPositionParams

45 -> TextDocumentPositionParams

49− -> IO (Either ResponseError b)

46+ -> IO b

50request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do

47request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do

51 mbResult <- case uriToFilePath' uri of

48 mbResult <- case uriToFilePath' uri of

52 Just path -> logAndRunRequest label getResults ide pos path

49 Just path -> logAndRunRequest label getResults ide pos path

53 Nothing -> pure Nothing

50 Nothing -> pure Nothing

54− pure $ Right $ maybe notFound found mbResult

51+ pure $ maybe notFound found mbResult

56logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b

53logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b

57logAndRunRequest label getResults ide pos path = do

54logAndRunRequest label getResults ide pos path = do

58− let filePath = toNormalizedFilePath' path

55+ let filePath = toNormalizedFilePath path

59 logInfo (ideLogger ide) $

56 logInfo (ideLogger ide) $

60 label <> " request at position " <> T.pack (showPosition pos) <>

57 label <> " request at position " <> T.pack (showPosition pos) <>

61 " in file: " <> T.pack path

58 " in file: " <> T.pack path

src/Development/IDE/LSP/LanguageServer.hs+31−54

@@ -28,25 +28,23 @@ import GHC.IO.Handle (hDuplicate)

28import System.IO

29import Control.Monad.Extra

31−import Development.IDE.Core.IdeConfiguration

32−import Development.IDE.Core.Shake

33import Development.IDE.LSP.HoverDefinition

31import Development.IDE.LSP.HoverDefinition

32+import Development.IDE.LSP.CodeAction

33+import Development.IDE.LSP.Completions

34import Development.IDE.LSP.Notifications

35import Development.IDE.LSP.Outline

36+import Development.IDE.Core.Service

36import Development.IDE.Types.Logger

37import Development.IDE.Types.Logger

37import Development.IDE.Core.FileStore

38import Development.IDE.Core.FileStore

38import Language.Haskell.LSP.Core (LspFuncs(..))

39import Language.Haskell.LSP.Core (LspFuncs(..))

39import Language.Haskell.LSP.Messages

40import Language.Haskell.LSP.Messages

41runLanguageServer

42runLanguageServer

42− :: forall config. (Show config)

43− => LSP.Options

43+ :: LSP.Options

44− -> PartialHandlers config

44+ -> PartialHandlers

45− -> (InitializeRequest -> Either T.Text config)

46− -> (DidChangeConfigurationNotification -> Either T.Text config)

47 -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)

45 -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)

48 -> IO ()

46 -> IO ()

49−runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do

47+runLanguageServer options userHandlers getIdeState = do

50 -- Move stdout to another file descriptor and duplicate stderr

48 -- Move stdout to another file descriptor and duplicate stderr

51 -- to stdout. This guards against stray prints from corrupting the JSON-RPC

49 -- to stdout. This guards against stray prints from corrupting the JSON-RPC

52 -- message stream.

50 -- message stream.

@@ -63,7 +61,7 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

64 -- Send everything over a channel, since you need to wait until after initialise before

62 -- Send everything over a channel, since you need to wait until after initialise before

65 -- LspFuncs is available

63 -- LspFuncs is available

66− clientMsgChan :: Chan (Message config) <- newChan

64+ clientMsgChan :: Chan Message <- newChan

68 -- These barriers are signaled when the threads reading from these chans exit.

66 -- These barriers are signaled when the threads reading from these chans exit.

69 -- This should not happen but if it does, we will make sure that the whole server

67 -- This should not happen but if it does, we will make sure that the whole server

@@ -82,7 +80,6 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

82 let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do

80 let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do

83 atomically $ modifyTVar pendingRequests (Set.insert _id)

81 atomically $ modifyTVar pendingRequests (Set.insert _id)

84 writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f

82 writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f

85− let withInitialize f = Just $ \r -> writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x)

86 let cancelRequest reqId = atomically $ do

83 let cancelRequest reqId = atomically $ do

87 queued <- readTVar pendingRequests

84 queued <- readTVar pendingRequests

88 -- We want to avoid that the list of cancelled requests

85 -- We want to avoid that the list of cancelled requests

@@ -99,20 +96,21 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

99 cancelled <- readTVar cancelledRequests

96 cancelled <- readTVar cancelledRequests

100 unless (reqId `Set.member` cancelled) retry

97 unless (reqId `Set.member` cancelled) retry

101 let PartialHandlers parts =

98 let PartialHandlers parts =

102− initializeRequestHandler <>

103 setHandlersIgnore <> -- least important

99 setHandlersIgnore <> -- least important

104 setHandlersDefinition <> setHandlersHover <>

100 setHandlersDefinition <> setHandlersHover <>

101+ setHandlersCodeAction <> setHandlersCodeLens <> -- useful features someone may override

102+ setHandlersCompletion <>

105 setHandlersOutline <>

103 setHandlersOutline <>

106 userHandlers <>

104 userHandlers <>

107 setHandlersNotifications <> -- absolutely critical, join them with user notifications

105 setHandlersNotifications <> -- absolutely critical, join them with user notifications

108 cancelHandler cancelRequest

106 cancelHandler cancelRequest

109 -- Cancel requests are special since they need to be handled

107 -- Cancel requests are special since they need to be handled

110 -- out of order to be useful. Existing handlers are run afterwards.

108 -- out of order to be useful. Existing handlers are run afterwards.

111− handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def

109+ handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def

112

110

113 let initializeCallbacks = LSP.InitializeCallbacks

111 let initializeCallbacks = LSP.InitializeCallbacks

114− { LSP.onInitialConfiguration = onInitialConfig

112+ { LSP.onInitialConfiguration = const $ Right ()

115− , LSP.onConfigurationChange = onConfigChange

113+ , LSP.onConfigurationChange = const $ Right ()

116 , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan

114 , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan

117 }

115 }

118

116

@@ -127,11 +125,9 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

127 , void $ waitBarrier clientMsgBarrier

125 , void $ waitBarrier clientMsgBarrier

128 ]

126 ]

129 where

127 where

130− handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan (Message config) -> LSP.LspFuncs config -> IO (Maybe err)

128+ handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs () -> IO (Maybe err)

131 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do

129 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do

132−

133 ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities

130 ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities

134−

135 _ <- flip forkFinally (const exitClientMsg) $ forever $ do

131 _ <- flip forkFinally (const exitClientMsg) $ forever $ do

136 msg <- readChan clientMsgChan

132 msg <- readChan clientMsgChan

137 case msg of

133 case msg of

@@ -142,25 +138,17 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

142 "Message: " ++ show x ++ "\n" ++

138 "Message: " ++ show x ++ "\n" ++

143 "Exception: " ++ show e

139 "Exception: " ++ show e

144 Response x@RequestMessage{_id, _params} wrap act ->

140 Response x@RequestMessage{_id, _params} wrap act ->

145− checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

141+ checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

146− \case

147− Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)

142+ \res -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing

148− Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)

149 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->

143 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->

150 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

144 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

151 \(res, newReq) -> do

145 \(res, newReq) -> do

146+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing

152− case res of

147+ case newReq of

153− Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)

148+ Nothing -> return ()

154− Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)

155− whenJust newReq $ \(rm, newReqParams) -> do

149+ Just (rm, newReqParams) -> do

156 reqId <- getNextReqId

150 reqId <- getNextReqId

157 sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams

151 sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams

158− InitialParams x@RequestMessage{_id, _params} act -> do

159− catch (act lspFuncs ide _params) $ \(e :: SomeException) ->

160− logError (ideLogger ide) $ T.pack $

161− "Unexpected exception on InitializeRequest handler, please report!\n" ++

162− "Message: " ++ show x ++ "\n" ++

163− "Exception: " ++ show e

164 pure Nothing

152 pure Nothing

165

153

166 checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =

154 checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =

@@ -175,39 +163,28 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

175 Left () -> do

163 Left () -> do

176 logDebug (ideLogger ide) $ T.pack $

164 logDebug (ideLogger ide) $ T.pack $

177 "Cancelled request " <> show _id

165 "Cancelled request " <> show _id

178− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left

166+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $

179− $ ResponseError RequestCancelled "" Nothing

167+ Just $ ResponseError RequestCancelled "" Nothing

180 Right res -> k res

168 Right res -> k res

181 ) $ \(e :: SomeException) -> do

169 ) $ \(e :: SomeException) -> do

182 logError (ideLogger ide) $ T.pack $

170 logError (ideLogger ide) $ T.pack $

183 "Unexpected exception on request, please report!\n" ++

171 "Unexpected exception on request, please report!\n" ++

184 "Message: " ++ show msg ++ "\n" ++

172 "Message: " ++ show msg ++ "\n" ++

185 "Exception: " ++ show e

173 "Exception: " ++ show e

186− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left

174+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $

187− $ ResponseError InternalError (T.pack $ show e) Nothing

175+ Just $ ResponseError InternalError (T.pack $ show e) Nothing

188

176

189−initializeRequestHandler :: PartialHandlers config

190−initializeRequestHandler = PartialHandlers $ \WithMessage{..} x -> return x{

191− LSP.initializeRequestHandler = withInitialize initHandler

192− }

193−

194−initHandler

195− :: LSP.LspFuncs c

196− -> IdeState

197− -> InitializeParams

198− -> IO ()

199−initHandler _ ide params = registerIdeConfiguration (shakeExtras ide) (parseConfiguration params)

200

177

201-- | Things that get sent to us, but we don't deal with.

178-- | Things that get sent to us, but we don't deal with.

202-- Set them to avoid a warning in VS Code output.

179-- Set them to avoid a warning in VS Code output.

203−setHandlersIgnore :: PartialHandlers config

180+setHandlersIgnore :: PartialHandlers

204setHandlersIgnore = PartialHandlers $ \_ x -> return x

181setHandlersIgnore = PartialHandlers $ \_ x -> return x

205 {LSP.initializedHandler = none

182 {LSP.initializedHandler = none

206 ,LSP.responseHandler = none

183 ,LSP.responseHandler = none

207 }

184 }

208 where none = Just $ const $ return ()

185 where none = Just $ const $ return ()

209

186

210−cancelHandler :: (LspId -> IO ()) -> PartialHandlers config

187+cancelHandler :: (LspId -> IO ()) -> PartialHandlers

211cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x

188cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x

212 {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do

189 {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do

213 cancelRequest _id

190 cancelRequest _id

@@ -217,18 +194,18 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x

217

194

218-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety

195-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety

219-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)

196-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)

220−data Message c

197+data Message

221− = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp))

198+ = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO resp)

222 -- | Used for cases in which we need to send not only a response,

199 -- | Used for cases in which we need to send not only a response,

223 -- but also an additional request to the client.

200 -- but also an additional request to the client.

224 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.

201 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.

225− | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))

202+ | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams)))

226− | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())

203+ | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ())

227− -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler.

204+

228− | InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())

229

205

230modifyOptions :: LSP.Options -> LSP.Options

206modifyOptions :: LSP.Options -> LSP.Options

231modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS

207modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS

208+ , LSP.executeCommandCommands = Just ["typesignature.add"]

232 }

209 }

233 where

210 where

234 tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}

211 tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}

src/Development/IDE/LSP/Notifications.hs+13−39

@@ -2,37 +2,32 @@

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

4{-# LANGUAGE DuplicateRecordFields #-}

5−{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE RankNTypes #-}

7module Development.IDE.LSP.Notifications

8 ( setHandlersNotifications

9 ) where

11−import Development.IDE.LSP.Server

12−import qualified Language.Haskell.LSP.Core as LSP

13import Language.Haskell.LSP.Types

11import Language.Haskell.LSP.Types

12+import Development.IDE.LSP.Server

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

14−import qualified Language.Haskell.LSP.Types as LSP

14+import qualified Language.Haskell.LSP.Types as LSP

16−import Development.IDE.Core.IdeConfiguration

16+import Development.IDE.Types.Logger

17−import Development.IDE.Core.Service

17+import Development.IDE.Core.Service

18−import Development.IDE.Types.Location

18+import Development.IDE.Types.Location

19−import Development.IDE.Types.Logger

21−import Control.Monad.Extra

20+import Control.Monad.Extra

22−import Data.Foldable as F

23−import Data.Maybe

24−import qualified Data.HashSet as S

21+import qualified Data.Set as S

25−import qualified Data.Text as Text

27−import Development.IDE.Core.FileStore (setSomethingModified)

23+import Development.IDE.Core.FileStore

28−import Development.IDE.Core.FileExists (modifyFileExists)

29−import Development.IDE.Core.OfInterest

24+import Development.IDE.Core.OfInterest

32whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()

27whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()

33−whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'

28+whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath

35−setHandlersNotifications :: PartialHandlers c

30+setHandlersNotifications :: PartialHandlers

36setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x

31setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x

37 {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $

32 {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $

38 \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do

33 \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do

@@ -57,25 +52,4 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x

57 whenUriFile _uri $ \file -> do

52 whenUriFile _uri $ \file -> do

58 modifyFilesOfInterest ide (S.delete file)

53 modifyFilesOfInterest ide (S.delete file)

59 logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri

54 logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri

60− ,LSP.didChangeWatchedFilesNotificationHandler = withNotification (LSP.didChangeWatchedFilesNotificationHandler x) $

61− \_ ide (DidChangeWatchedFilesParams fileEvents) -> do

62− let events =

63− mapMaybe

64− (\(FileEvent uri ev) ->

65− (, ev /= FcDeleted) . toNormalizedFilePath'

66− <$> LSP.uriToFilePath uri

67− )

68− ( F.toList fileEvents )

69− let msg = Text.pack $ show events

70− logInfo (ideLogger ide) $ "Files created or deleted: " <> msg

71− modifyFileExists ide events

72− setSomethingModified ide

73−

74− ,LSP.didChangeWorkspaceFoldersNotificationHandler = withNotification (LSP.didChangeWorkspaceFoldersNotificationHandler x) $

75− \_ ide (DidChangeWorkspaceFoldersParams events) -> do

76− let add = S.union

77− substract = flip S.difference

78− modifyWorkspaceFolders ide

79− $ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events))

80− . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events))

81 }

55 }

src/Development/IDE/LSP/Outline.hs+10−49

@@ -4,8 +4,6 @@

5module Development.IDE.LSP.Outline

6 ( setHandlersOutline

7− -- * For haskell-language-server

8− , moduleOutline

9 )

7 )

10where

8where

@@ -30,20 +28,20 @@ import Outputable ( Outputable

30 , showSDocUnsafe

28 , showSDocUnsafe

31 )

29 )

33−setHandlersOutline :: PartialHandlers c

31+setHandlersOutline :: PartialHandlers

34setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x

32setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x

35 { LSP.documentSymbolHandler = withResponse RspDocumentSymbols moduleOutline

33 { LSP.documentSymbolHandler = withResponse RspDocumentSymbols moduleOutline

36 }

34 }

38moduleOutline

36moduleOutline

39− :: LSP.LspFuncs c -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)

37+ :: LSP.LspFuncs () -> IdeState -> DocumentSymbolParams -> IO DSResult

40moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }

38moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }

41 = case uriToFilePath uri of

39 = case uriToFilePath uri of

42− Just (toNormalizedFilePath' -> fp) -> do

40+ Just (toNormalizedFilePath -> fp) -> do

43 mb_decls <- runAction ideState $ use GetParsedModule fp

41 mb_decls <- runAction ideState $ use GetParsedModule fp

44− pure $ Right $ case mb_decls of

42+ pure $ case mb_decls of

45 Nothing -> DSDocumentSymbols (List [])

43 Nothing -> DSDocumentSymbols (List [])

46− Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } }

44+ Just (ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } })

47 -> let

45 -> let

48 declSymbols = mapMaybe documentSymbolForDecl hsmodDecls

46 declSymbols = mapMaybe documentSymbolForDecl hsmodDecls

49 moduleSymbol = hsmodName <&> \(L l m) ->

47 moduleSymbol = hsmodName <&> \(L l m) ->

@@ -52,9 +50,7 @@ moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentI

52 , _kind = SkFile

50 , _kind = SkFile

53 , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0

51 , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0

54 }

52 }

55− importSymbols = maybe [] pure $

56− documentSymbolForImportSummary

57− (mapMaybe documentSymbolForImport hsmodImports)

53+ importSymbols = mapMaybe documentSymbolForImport hsmodImports

58 allSymbols = case moduleSymbol of

54 allSymbols = case moduleSymbol of

59 Nothing -> importSymbols <> declSymbols

55 Nothing -> importSymbols <> declSymbols

60 Just x ->

56 Just x ->

@@ -65,7 +61,7 @@ moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentI

65 DSDocumentSymbols (List allSymbols)

61 DSDocumentSymbols (List allSymbols)

68− Nothing -> pure $ Right $ DSDocumentSymbols (List [])

64+ Nothing -> pure $ DSDocumentSymbols (List [])

70documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol

66documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol

71documentSymbolForDecl (L l (TyClD FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))

67documentSymbolForDecl (L l (TyClD FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))

@@ -108,39 +104,27 @@ documentSymbolForDecl (L l (TyClD DataDecl { tcdLName = L _ name, tcdDataDefn =

108 { _name = showRdrName n

104 { _name = showRdrName n

109 , _kind = SkConstructor

105 , _kind = SkConstructor

110 , _selectionRange = srcSpanToRange l'

106 , _selectionRange = srcSpanToRange l'

111− , _children = conArgRecordFields (getConArgs x)

112 }

107 }

113 | L l x <- dd_cons

108 | L l x <- dd_cons

114 , L l' n <- getConNames x

109 , L l' n <- getConNames x

115 ]

110 ]

116 }

111 }

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

128documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just

112documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just

129 (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n

113 (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n

130 , _kind = SkTypeParameter

114 , _kind = SkTypeParameter

131 , _selectionRange = srcSpanToRange l'

115 , _selectionRange = srcSpanToRange l'

132 }

116 }

133−documentSymbolForDecl (L l (InstD ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))

117+documentSymbolForDecl (L l (InstD (ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })))

134 = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty

118 = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty

135 , _kind = SkInterface

119 , _kind = SkInterface

136 }

120 }

137−documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))

121+documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) }))

138 = Just (defDocumentSymbol l :: DocumentSymbol)

122 = Just (defDocumentSymbol l :: DocumentSymbol)

139 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

123 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

140 (map pprText feqn_pats)

124 (map pprText feqn_pats)

141 , _kind = SkInterface

125 , _kind = SkInterface

142 }

126 }

143−documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))

127+documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) }))

144 = Just (defDocumentSymbol l :: DocumentSymbol)

128 = Just (defDocumentSymbol l :: DocumentSymbol)

145 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

129 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

146 (map pprText feqn_pats)

130 (map pprText feqn_pats)

@@ -183,35 +167,12 @@ documentSymbolForDecl (L l (ForD x)) = Just

183

167

184documentSymbolForDecl _ = Nothing

168documentSymbolForDecl _ = Nothing

185

169

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−

205documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol

170documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol

206documentSymbolForImport (L l ImportDecl { ideclName, ideclQualified }) = Just

171documentSymbolForImport (L l ImportDecl { ideclName, ideclQualified }) = Just

207 (defDocumentSymbol l :: DocumentSymbol)

172 (defDocumentSymbol l :: DocumentSymbol)

208 { _name = "import " <> pprText ideclName

173 { _name = "import " <> pprText ideclName

209 , _kind = SkModule

174 , _kind = SkModule

210−#if MIN_GHC_API_VERSION(8,10,0)

211− , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" }

212−#else

213 , _detail = if ideclQualified then Just "qualified" else Nothing

175 , _detail = if ideclQualified then Just "qualified" else Nothing

214−#endif

215 }

176 }

216#if MIN_GHC_API_VERSION(8,6,0)

177#if MIN_GHC_API_VERSION(8,6,0)

217documentSymbolForImport (L _ XImportDecl {}) = Nothing

178documentSymbolForImport (L _ XImportDecl {}) = Nothing

src/Development/IDE/LSP/Server.hs+10−11

@@ -16,32 +16,31 @@ import qualified Language.Haskell.LSP.Core as LSP

16import qualified Language.Haskell.LSP.Messages as LSP

17import Development.IDE.Core.Service

19+

19−data WithMessage c = WithMessage

20+data WithMessage = WithMessage

20 {withResponse :: forall m req resp . (Show m, Show req) =>

21 {withResponse :: forall m req resp . (Show m, Show req) =>

21 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

22 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

22− (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work

23+ (LSP.LspFuncs () -> IdeState -> req -> IO resp) -> -- actual work

23 Maybe (LSP.Handler (RequestMessage m req resp))

24 Maybe (LSP.Handler (RequestMessage m req resp))

24 ,withNotification :: forall m req . (Show m, Show req) =>

25 ,withNotification :: forall m req . (Show m, Show req) =>

25 Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler

26 Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler

26− (LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work

27+ (LSP.LspFuncs () -> IdeState -> req -> IO ()) -> -- actual work

27 Maybe (LSP.Handler (NotificationMessage m req))

28 Maybe (LSP.Handler (NotificationMessage m req))

28− ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody .

29+ ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.

29 (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>

30 (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>

30 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

31 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

31 (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req

32 (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req

32− (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work

33+ (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work

33 Maybe (LSP.Handler (RequestMessage m req resp))

34 Maybe (LSP.Handler (RequestMessage m req resp))

34− , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())

35− -> Maybe (LSP.Handler InitializeRequest)

36 }

35 }

38−newtype PartialHandlers c = PartialHandlers (WithMessage c -> LSP.Handlers -> IO LSP.Handlers)

37+newtype PartialHandlers = PartialHandlers (WithMessage -> LSP.Handlers -> IO LSP.Handlers)

40−instance Default (PartialHandlers c) where

39+instance Default PartialHandlers where

41 def = PartialHandlers $ \_ x -> pure x

40 def = PartialHandlers $ \_ x -> pure x

43−instance Semigroup (PartialHandlers c) where

42+instance Semigroup PartialHandlers where

44 PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w

43 PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w

46−instance Monoid (PartialHandlers c) where

45+instance Monoid PartialHandlers where

47 mempty = def

46 mempty = def

src/Development/IDE/Plugin.hsdeleted−60

@@ -1,60 +0,0 @@

1−

2−module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules,makeLspCommandId,getPid) where

3−

4−import Data.Default

5−import qualified Data.Text as T

6−import Development.Shake

7−import Development.IDE.LSP.Server

8−

9−import Language.Haskell.LSP.Types

10−import Development.IDE.Compat

11−import Development.IDE.Core.Rules

12−import qualified Language.Haskell.LSP.Core as LSP

13−import Language.Haskell.LSP.Messages

14−

15−

16−data Plugin c = Plugin

17− {pluginRules :: Rules ()

18− ,pluginHandler :: PartialHandlers c

19− }

20−

21−instance Default (Plugin c) where

22− def = Plugin mempty def

23−

24−instance Semigroup (Plugin c) where

25− Plugin x1 y1 <> Plugin x2 y2 = Plugin (x1<>x2) (y1<>y2)

26−

27−instance Monoid (Plugin c) where

28− mempty = def

29−

30−

31−codeActionPlugin :: (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c

32−codeActionPlugin = codeActionPluginWithRules mempty

33−

34−codeActionPluginWithRules :: Rules () -> (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c

35−codeActionPluginWithRules rr f = Plugin rr $ PartialHandlers $ \WithMessage{..} x -> return x{

36− LSP.codeActionHandler = withResponse RspCodeAction g

37− }

38− where

39− g lsp state (CodeActionParams a b c _) = fmap List <$> f lsp state a b c

40−

41−-- | Prefix to uniquely identify commands sent to the client. This

42−-- has two parts

43−--

44−-- - A representation of the process id to make sure that a client has

45−-- unique commands if it is running multiple servers, since some

46−-- clients have a global command table and get confused otherwise.

47−--

48−-- - A string to identify ghcide, to ease integration into

49−-- haskell-language-server, which routes commands to plugins based

50−-- on that.

51−makeLspCommandId :: T.Text -> IO T.Text

52−makeLspCommandId command = do

53− pid <- getPid

54− return $ pid <> ":ghcide:" <> command

55−

56−-- | Get the operating system process id for the running server

57−-- instance. This should be the same for the lifetime of the instance,

58−-- and different from that of any other currently running instance.

59−getPid :: IO T.Text

60−getPid = T.pack . show <$> getProcessID

src/Development/IDE/Plugin/CodeAction.hsdeleted−570

@@ -1,570 +0,0 @@

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

3−

4−{-# LANGUAGE DuplicateRecordFields #-}

5−{-# LANGUAGE CPP #-}

6−#include "ghc-api-version.h"

7−

8−-- | Go to the definition of a variable.

9−module Development.IDE.Plugin.CodeAction

10− (

11− plugin

12−

13− -- * For haskell-language-server

14− , codeAction

15− , codeLens

16− , rulePackageExports

17− , executeAddSignatureCommand

18− ) where

19−

20−import Language.Haskell.LSP.Types

21−import Control.Monad (join)

22−import Development.IDE.Plugin

23−import Development.IDE.GHC.Compat

24−import Development.IDE.Core.Rules

25−import Development.IDE.Core.RuleTypes

26−import Development.IDE.Core.Service

27−import Development.IDE.Core.Shake

28−import Development.IDE.GHC.Error

29−import Development.IDE.GHC.Util

30−import Development.IDE.LSP.Server

31−import Development.IDE.Plugin.CodeAction.PositionIndexed

32−import Development.IDE.Plugin.CodeAction.RuleTypes

33−import Development.IDE.Plugin.CodeAction.Rules

34−import Development.IDE.Types.Location

35−import Development.IDE.Types.Options

36−import Development.Shake (Rules)

37−import qualified Data.HashMap.Strict as Map

38−import qualified Language.Haskell.LSP.Core as LSP

39−import Language.Haskell.LSP.VFS

40−import Language.Haskell.LSP.Messages

41−import qualified Data.Rope.UTF16 as Rope

42−import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))

43−import Control.Monad.Trans.Maybe

44−import Data.Char

45−import Data.Maybe

46−import Data.List.Extra

47−import qualified Data.Text as T

48−import Data.Tuple.Extra ((&&&))

49−import HscTypes

50−import Parser

51−import Text.Regex.TDFA ((=~), (=~~))

52−import Text.Regex.TDFA.Text()

53−import Outputable (ppr, showSDocUnsafe)

54−import DynFlags (xFlags, FlagSpec(..))

55−import GHC.LanguageExtensions.Type (Extension)

56−

57−plugin :: Plugin c

58−plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens

59−

60−rules :: Rules ()

61−rules = rulePackageExports

62−

63−-- | Generate code actions.

64−codeAction

65− :: LSP.LspFuncs c

66− -> IdeState

67− -> TextDocumentIdentifier

68− -> Range

69− -> CodeActionContext

70− -> IO (Either ResponseError [CAResult])

71−codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do

72− -- disable logging as its quite verbose

73− -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg

74− contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri

75− let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents

76− mbFile = toNormalizedFilePath' <$> uriToFilePath uri

77− (ideOptions, parsedModule, join -> env) <- runAction state $

78− (,,) <$> getIdeOptions

79− <*> getParsedModule `traverse` mbFile

80− <*> use GhcSession `traverse` mbFile

81− pkgExports <- runAction state $ (useNoFile_ . PackageExports) `traverse` env

82− let dflags = hsc_dflags . hscEnv <$> env

83− pure $ Right

84− [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing

85− | x <- xs, (title, tedit) <- suggestAction dflags (fromMaybe mempty pkgExports) ideOptions ( join parsedModule ) text x

86− , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

87− ]

88−

89−-- | Generate code lenses.

90−codeLens

91− :: LSP.LspFuncs c

92− -> IdeState

93− -> CodeLensParams

94− -> IO (Either ResponseError (List CodeLens))

95−codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do

96− commandId <- makeLspCommandId "typesignature.add"

97− fmap (Right . List) $ case uriToFilePath' uri of

98− Just (toNormalizedFilePath' -> filePath) -> do

99− _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath

100− diag <- getDiagnostics ideState

101− hDiag <- getHiddenDiagnostics ideState

102− pure

103− [ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing

104− | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag

105− , dFile == filePath

106− , (title, tedit) <- suggestSignature False dDiag

107− , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

108− ]

109− Nothing -> pure []

110−

111−-- | Execute the "typesignature.add" command.

112−executeAddSignatureCommand

113− :: LSP.LspFuncs c

114− -> IdeState

115− -> ExecuteCommandParams

116− -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

117−executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}

118− -- _command is prefixed with a process ID, because certain clients

119− -- have a global command registry, and all commands must be

120− -- unique. And there can be more than one ghcide instance running

121− -- at a time against the same client.

122− | T.isSuffixOf "typesignature.add" _command

123− , Just (List [edit]) <- _arguments

124− , Success wedit <- fromJSON edit

125− = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))

126− | otherwise

127− = return (Right Null, Nothing)

128−

129−suggestAction

130− :: Maybe DynFlags

131− -> PackageExportsMap

132− -> IdeOptions

133− -> Maybe ParsedModule

134− -> Maybe T.Text

135− -> Diagnostic

136− -> [(T.Text, [TextEdit])]

137−suggestAction dflags packageExports ideOptions parsedModule text diag = concat

138− [ suggestAddExtension diag

139− , suggestExtendImport dflags text diag

140− , suggestFillHole diag

141− , suggestFillTypeWildcard diag

142− , suggestFixConstructorImport text diag

143− , suggestModuleTypo diag

144− , suggestReplaceIdentifier text diag

145− , suggestSignature True diag

146− ] ++ concat

147− [ suggestNewDefinition ideOptions pm text diag

148− ++ suggestRemoveRedundantImport pm text diag

149− ++ suggestNewImport packageExports pm diag

150− | Just pm <- [parsedModule]]

151−

152−

153−suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

154−suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..}

155−-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant

156− | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"

157− , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports

158− , Just c <- contents

159− , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)

160− , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)

161− , not (null ranges')

162− = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]

163−

164−-- File.hs:16:1: warning:

165−-- The import of `Data.List' is redundant

166−-- except perhaps to import instances from `Data.List'

167−-- To import instances alone, use: import Data.List()

168− | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)

169− = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]

170− | otherwise = []

171−

172−suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

173−suggestReplaceIdentifier contents Diagnostic{_range=_range,..}

174−-- File.hs:52:41: error:

175−-- * Variable not in scope:

176−-- suggestAcion :: Maybe T.Text -> Range -> Range

177−-- * Perhaps you meant ‘suggestAction’ (line 83)

178−-- File.hs:94:37: error:

179−-- Not in scope: ‘T.isPrfixOf’

180−-- Perhaps you meant one of these:

181−-- ‘T.isPrefixOf’ (imported from Data.Text),

182−-- ‘T.isInfixOf’ (imported from Data.Text),

183−-- ‘T.isSuffixOf’ (imported from Data.Text)

184−-- Module ‘Data.Text’ does not export ‘isPrfixOf’.

185− | renameSuggestions@(_:_) <- extractRenamableTerms _message

186− = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]

187− | otherwise = []

188−

189−suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

190−suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range}

191−-- * Variable not in scope:

192−-- suggestAcion :: Maybe T.Text -> Range -> Range

193− | Just [name, typ] <- matchRegex message "Variable not in scope: ([^ ]+) :: ([^*•]+)"

194− = newDefinitionAction ideOptions parsedModule _range name typ

195− | Just [name, typ] <- matchRegex message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps"

196− , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ

197− = [(label, mkRenameEdit contents _range name : newDefinitionEdits)]

198− | otherwise = []

199− where

200− message = unifySpaces _message

201−

202−newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])]

203−newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ

204− | Range _ lastLineP : _ <-

205− [ srcSpanToRange l

206− | (L l _) <- hsmodDecls

207− , _start `isInsideSrcSpan` l]

208− , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0}

209− = [ ("Define " <> sig

210− , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = error \"not implemented\""])]

211− )]

212− | otherwise = []

213− where

214− colon = if optNewColonConvention then " : " else " :: "

215− sig = name <> colon <> T.dropWhileEnd isSpace typ

216− ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule

217−

218−

219−suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]

220−suggestFillTypeWildcard Diagnostic{_range=_range,..}

221−-- Foo.hs:3:8: error:

222−-- * Found type wildcard `_' standing for `p -> p1 -> p'

223−

224− | "Found type wildcard" `T.isInfixOf` _message

225− , " standing for " `T.isInfixOf` _message

226− , typeSignature <- extractWildCardTypeSignature _message

227− = [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]

228− | otherwise = []

229−

230−suggestAddExtension :: Diagnostic -> [(T.Text, [TextEdit])]

231−suggestAddExtension Diagnostic{_range=_range,..}

232−-- File.hs:22:8: error:

233−-- Illegal lambda-case (use -XLambdaCase)

234−-- File.hs:22:6: error:

235−-- Illegal view pattern: x -> foo

236−-- Use ViewPatterns to enable view patterns

237−-- File.hs:26:8: error:

238−-- Illegal `..' in record pattern

239−-- Use RecordWildCards to permit this

240−-- File.hs:53:28: error:

241−-- Illegal tuple section: use TupleSections

242−-- File.hs:238:29: error:

243−-- * Can't make a derived instance of `Data FSATrace':

244−-- You need DeriveDataTypeable to derive an instance for this class

245−-- * In the data declaration for `FSATrace'

246−-- C:\Neil\shake\src\Development\Shake\Command.hs:515:31: error:

247−-- * Illegal equational constraint a ~ ()

248−-- (Use GADTs or TypeFamilies to permit this)

249−-- * In the context: a ~ ()

250−-- While checking an instance declaration

251−-- In the instance declaration for `Unit (m a)'

252− | exts@(_:_) <- filter (`Map.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message

253− = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts]

254− | otherwise = []

255−

256−-- | All the GHC extensions

257−ghcExtensions :: Map.HashMap T.Text Extension

258−ghcExtensions = Map.fromList . map ( ( T.pack . flagSpecName ) &&& flagSpecFlag ) $ xFlags

259−

260−suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]

261−suggestModuleTypo Diagnostic{_range=_range,..}

262−-- src/Development/IDE/Core/Compile.hs:58:1: error:

263−-- Could not find module ‘Data.Cha’

264−-- Perhaps you meant Data.Char (from base-4.12.0.0)

265− | "Could not find module" `T.isInfixOf` _message

266− , "Perhaps you meant" `T.isInfixOf` _message = let

267− findSuggestedModules = map (head . T.words) . drop 2 . T.lines

268− proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])

269− in map proposeModule $ nubOrd $ findSuggestedModules _message

270− | otherwise = []

271−

272−suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])]

273−suggestFillHole Diagnostic{_range=_range,..}

274−-- ...Development/IDE/LSP/CodeAction.hs:103:9: warning:

275−-- * Found hole: _ :: Int -> String

276−-- * In the expression: _

277−-- In the expression: _ a

278−-- In an equation for ‘foo’: foo a = _ a

279−-- * Relevant bindings include

280−-- a :: Int

281−-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:5)

282−-- foo :: Int -> String

283−-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)

284−-- Valid hole fits include

285−-- foo :: Int -> String

286−-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)

287−-- show :: forall a. Show a => a -> String

288−-- with show @Int

289−-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37

290−-- (and originally defined in ‘GHC.Show’))

291−-- mempty :: forall a. Monoid a => a

292−-- with mempty @(Int -> String)

293−-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37

294−-- (and originally defined in ‘GHC.Base’)) (lsp-ui)

295−

296− | topOfHoleFitsMarker `T.isInfixOf` _message = let

297− findSuggestedHoleFits :: T.Text -> [T.Text]

298− findSuggestedHoleFits = extractFitNames . selectLinesWithFits . dropPreceding . T.lines

299− proposeHoleFit name = ("replace hole `" <> holeName <> "` with " <> name, [TextEdit _range name])

300− holeName = T.strip $ last $ T.splitOn ":" $ head . T.splitOn "::" $ head $ filter ("Found hole" `T.isInfixOf`) $ T.lines _message

301− dropPreceding = dropWhile (not . (topOfHoleFitsMarker `T.isInfixOf`))

302− selectLinesWithFits = filter ("::" `T.isInfixOf`)

303− extractFitNames = map (T.strip . head . T.splitOn " :: ")

304− in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message

305−

306− | otherwise = []

307−

308−suggestExtendImport :: Maybe DynFlags -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

309−suggestExtendImport (Just dflags) contents Diagnostic{_range=_range,..}

310− | Just [binding, mod, srcspan] <-

311− matchRegex _message

312− "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\$(.*)\$.$"

313− , Just c <- contents

314− , POk _ (L _ name) <- runParser dflags (T.unpack binding) parseIdentifier

315− = let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of

316− [s] -> let x = srcSpanToRange s

317− in x{_end = (_end x){_character = succ (_character (_end x))}}

318− _ -> error "bug in srcspan parser"

319− importLine = textInRange range c

320− in [("Add " <> binding <> " to the import list of " <> mod

321− , [TextEdit range (addBindingToImportList (T.pack $ printRdrName name) importLine)])]

322− | otherwise = []

323−suggestExtendImport Nothing _ _ = []

324−

325−suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

326−suggestFixConstructorImport _ Diagnostic{_range=_range,..}

327− -- ‘Success’ is a data constructor of ‘Result’

328− -- To import it use

329− -- import Data.Aeson.Types( Result( Success ) )

330− -- or

331− -- import Data.Aeson.Types( Result(..) ) (lsp-ui)

332− | Just [constructor, typ] <-

333− matchRegex _message

334− "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use"

335− = let fixedImport = typ <> "(" <> constructor <> ")"

336− in [("Fix import of " <> fixedImport, [TextEdit _range fixedImport])]

337− | otherwise = []

338−

339−suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]

340−suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}

341− | _message =~

342− ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) = let

343− signature = removeInitialForAll

344− $ T.takeWhile (\x -> x/='*' && x/='•')

345− $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message

346− startOfLine = Position (_line _start) startCharacter

347− beforeLine = Range startOfLine startOfLine

348− title = if isQuickFix then "add signature: " <> signature else signature

349− action = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " "

350− in [(title, [action])]

351− where removeInitialForAll :: T.Text -> T.Text

352− removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))

353− | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))

354− | otherwise = nm <> ty

355− startCharacter

356− | "Polymorphic local binding" `T.isPrefixOf` _message

357− = _character _start

358− | otherwise

359− = 0

360−

361−suggestSignature _ _ = []

362−

363−-------------------------------------------------------------------------------------------------

364−

365−suggestNewImport :: PackageExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]

366−suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message}

367− | msg <- unifySpaces _message

368− , Just name <- extractNotInScopeName msg

369− , Just insertLine <- case hsmodImports of

370− [] -> case srcSpanStart $ getLoc (head hsmodDecls) of

371− RealSrcLoc s -> Just $ srcLocLine s - 1

372− _ -> Nothing

373− _ -> case srcSpanEnd $ getLoc (last hsmodImports) of

374− RealSrcLoc s -> Just $ srcLocLine s

375− _ -> Nothing

376− , insertPos <- Position insertLine 0

377− , extendImportSuggestions <- matchRegex msg

378− "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"

379− = [(imp, [TextEdit (Range insertPos insertPos) (imp <> "\n")])

380− | imp <- constructNewImportSuggestions packageExportsMap name extendImportSuggestions

381− ]

382−suggestNewImport _ _ _ = []

383−

384−constructNewImportSuggestions

385− :: PackageExportsMap -> NotInScope -> Maybe [T.Text] -> [T.Text]

386−constructNewImportSuggestions exportsMap thingMissing notTheseModules = nubOrd

387− [ renderNewImport identInfo m

388− | (identInfo, m) <- fromMaybe [] $ Map.lookup name exportsMap

389− , canUseIdent thingMissing identInfo

390− , m `notElem` fromMaybe [] notTheseModules

391− ]

392− where

393− renderNewImport identInfo m

394− | Just q <- qual = "import qualified " <> m <> " as " <> q

395− | otherwise = "import " <> m <> " (" <> importWhat identInfo <> ")"

396−

397− (qual, name) = case T.splitOn "." (notInScope thingMissing) of

398− [n] -> (Nothing, n)

399− segments -> (Just (T.concat $ init segments), last segments)

400− importWhat IdentInfo {parent, rendered}

401− | Just p <- parent = p <> "(" <> rendered <> ")"

402− | otherwise = rendered

403−

404−canUseIdent :: NotInScope -> IdentInfo -> Bool

405−canUseIdent NotInScopeDataConstructor{} = isDatacon

406−canUseIdent _ = const True

407−

408−data NotInScope

409− = NotInScopeDataConstructor T.Text

410− | NotInScopeTypeConstructorOrClass T.Text

411− | NotInScopeThing T.Text

412− deriving Show

413−

414−notInScope :: NotInScope -> T.Text

415−notInScope (NotInScopeDataConstructor t) = t

416−notInScope (NotInScopeTypeConstructorOrClass t) = t

417−notInScope (NotInScopeThing t) = t

418−

419−extractNotInScopeName :: T.Text -> Maybe NotInScope

420−extractNotInScopeName x

421− | Just [name] <- matchRegex x "Data constructor not in scope: ([^ ]+)"

422− = Just $ NotInScopeDataConstructor name

423− | Just [name] <- matchRegex x "Not in scope: data constructor [^‘]*‘([^’]*)’"

424− = Just $ NotInScopeDataConstructor name

425− | Just [name] <- matchRegex x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"

426− = Just $ NotInScopeTypeConstructorOrClass name

427− | Just [name] <- matchRegex x "ot in scope: \$([^‘ ]+)\$"

428− = Just $ NotInScopeThing name

429− | Just [name] <- matchRegex x "ot in scope: ([^‘ ]+)"

430− = Just $ NotInScopeThing name

431− | Just [name] <- matchRegex x "ot in scope:[^‘]*‘([^’]*)’"

432− = Just $ NotInScopeThing name

433− | otherwise

434− = Nothing

435−

436−-------------------------------------------------------------------------------------------------

437−

438−topOfHoleFitsMarker :: T.Text

439−topOfHoleFitsMarker =

440−#if MIN_GHC_API_VERSION(8,6,0)

441− "Valid hole fits include"

442−#else

443− "Valid substitutions include"

444−#endif

445−

446−mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit

447−mkRenameEdit contents range name =

448− if maybeIsInfixFunction == Just True

449− then TextEdit range ("`" <> name <> "`")

450− else TextEdit range name

451− where

452− maybeIsInfixFunction = do

453− curr <- textInRange range <$> contents

454− pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr

455−

456−extractWildCardTypeSignature :: T.Text -> T.Text

457−extractWildCardTypeSignature =

458− -- inferring when parens are actually needed around the type signature would

459− -- require understanding both the precedence of the context of the _ and of

460− -- the signature itself. Inserting them unconditionally is ugly but safe.

461− ("(" `T.append`) . (`T.append` ")") .

462− T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') .

463− snd . T.breakOnEnd "standing for "

464−

465−extractRenamableTerms :: T.Text -> [T.Text]

466−extractRenamableTerms msg

467− -- Account for both "Variable not in scope" and "Not in scope"

468− | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg

469− | otherwise = []

470− where

471− extractSuggestions = map getEnclosed

472− . concatMap singleSuggestions

473− . filter isKnownSymbol

474− . T.lines

475− singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited

476− isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t

477− getEnclosed = T.dropWhile (== '‘')

478− . T.dropWhileEnd (== '’')

479− . T.dropAround (\c -> c /= '‘' && c /= '’')

480−

481−-- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace

482−-- between the end of the range and the next newline), extend the range to take up the whole line.

483−extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range

484−extendToWholeLineIfPossible contents range@Range{..} =

485− let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents

486− extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line

487− in if extend then Range _start (Position (_line _end + 1) 0) else range

488−

489−splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)

490−splitTextAtPosition (Position row col) x

491− | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x

492− , (preCol, postCol) <- T.splitAt col mid

493− = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)

494− | otherwise = (x, T.empty)

495−

496−-- | Returns [start .. end[

497−textInRange :: Range -> T.Text -> T.Text

498−textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =

499− case compare startRow endRow of

500− LT ->

501− let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine

502− (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of

503− [] -> ("", [])

504− firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)

505− maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines

506− in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)

507− EQ ->

508− let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)

509− in T.take (endCol - startCol) (T.drop startCol line)

510− GT -> ""

511− where

512− linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)

513−

514−-- | Returns the ranges for a binding in an import declaration

515−rangesForBinding :: ImportDecl GhcPs -> String -> [Range]

516−rangesForBinding ImportDecl{ideclHiding = Just (False, L _ lies)} b =

517− concatMap (map srcSpanToRange . rangesForBinding' b') lies

518− where

519− b' = wrapOperatorInParens (unqualify b)

520−

521− wrapOperatorInParens x = if isAlpha (head x) then x else "(" <> x <> ")"

522−

523− unqualify x = snd $ breakOnEnd "." x

524−

525−rangesForBinding _ _ = []

526−

527−rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]

528−rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]

529−rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]

530−rangesForBinding' b (L l (IEThingAll x)) | showSDocUnsafe (ppr x) == b = [l]

531−rangesForBinding' b (L l (IEThingWith thing _ inners labels))

532− | showSDocUnsafe (ppr thing) == b = [l]

533− | otherwise =

534− [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] ++

535− [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b]

536−rangesForBinding' _ _ = []

537−

538−-- | Extends an import list with a new binding.

539−-- Assumes an import statement of the form:

540−-- import (qualified) A (..) ..

541−-- Places the new binding first, preserving whitespace.

542−-- Copes with multi-line import lists

543−addBindingToImportList :: T.Text -> T.Text -> T.Text

544−addBindingToImportList binding importLine = case T.breakOn "(" importLine of

545− (pre, T.uncons -> Just (_, rest)) ->

546− case T.uncons (T.dropWhile isSpace rest) of

547− Just (')', _) -> T.concat [pre, "(", binding, rest]

548− _ -> T.concat [pre, "(", binding, ", ", rest]

549− _ ->

550− error

551− $ "importLine does not have the expected structure: "

552− <> T.unpack importLine

553−

554−-- | Returns Just (the submatches) for the first capture, or Nothing.

555−matchRegex :: T.Text -> T.Text -> Maybe [T.Text]

556−matchRegex message regex = case unifySpaces message =~~ regex of

557− Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings

558− Nothing -> Nothing

559−

560−setHandlersCodeLens :: PartialHandlers c

561−setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{

562− LSP.codeLensHandler = withResponse RspCodeLens codeLens,

563− LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand

564− }

565−

566−filterNewlines :: T.Text -> T.Text

567−filterNewlines = T.concat . T.lines

568−

569−unifySpaces :: T.Text -> T.Text

570−unifySpaces = T.unwords . T.words

src/Development/IDE/Plugin/CodeAction/PositionIndexed.hsdeleted−112

@@ -1,112 +0,0 @@

1−-- | Position indexed streams of characters

2−module Development.IDE.Plugin.CodeAction.PositionIndexed

3− ( PositionIndexed

4− , PositionIndexedString

5− , indexedByPosition

6− , indexedByPositionStartingFrom

7− , extendAllToIncludeCommaIfPossible

8− , mergeRanges

9− )

10−where

11−

12−import Data.Char

13−import Data.List

14−import Language.Haskell.LSP.Types

15−

16−type PositionIndexed a = [(Position, a)]

17−

18−type PositionIndexedString = PositionIndexed Char

19−

20−-- | Add position indexing to a String.

21−--

22−-- > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡

23−-- > [ ((0,0),'h')

24−-- > , ((0,1),'e')

25−-- > , ((0,2),'y')

26−-- > , ((0,3),'\n')

27−-- > , ((1,0),' ')

28−-- > , ((1,1),'h')

29−-- > , ((1,2),'o')

30−-- > ]

31−indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString

32−indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where

33− f (_, []) = Nothing

34− f (p@(Position l _), '\n' : rest) =

35− Just ((p, '\n'), (Position (l + 1) 0, rest))

36− f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest))

37−

38−-- | Add position indexing to a String.

39−--

40−-- > indexedByPosition = indexedByPositionStartingFrom (Position 0 0)

41−indexedByPosition :: String -> PositionIndexedString

42−indexedByPosition = indexedByPositionStartingFrom (Position 0 0)

43−

44−-- | Returns a tuple (before, contents, after) if the range is present.

45−-- The range is present only if both its start and end positions are present

46−unconsRange

47− :: Range

48− -> PositionIndexed a

49− -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a)

50−unconsRange Range {..} indexedString

51− | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString

52− , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest

53− = Just (before, mid, after)

54− | otherwise

55− = Nothing

56−

57−-- | Strips out all the positions included in the range.

58−-- Returns 'Nothing' if the start or end of the range are not included in the input.

59−stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a)

60−stripRange r s = case unconsRange r s of

61− Just (b, _, a) -> Just (b ++ a)

62− Nothing -> Nothing

63−

64−-- | Returns the smallest possible set of disjoint ranges that is equivalent to the input.

65−-- Assumes input ranges are sorted on the start positions.

66−mergeRanges :: [Range] -> [Range]

67−mergeRanges (r : r' : rest)

68− |

69− -- r' is contained in r

70− _end r > _end r' = mergeRanges (r : rest)

71− |

72− -- r and r' are overlapping

73− _end r > _start r' = mergeRanges (r { _end = _end r' } : rest)

74−

75− | otherwise = r : mergeRanges (r' : rest)

76−mergeRanges other = other

77−

78−-- | Returns a sorted list of ranges with extended selections including preceding or trailing commas

79−--

80−-- @

81−-- a, |b|, c ===> a|, b|, c

82−-- a, b, |c| ===> a, b|, c|

83−-- a, |b|, |c| ===> a|, b||, c|

84−-- @

85−extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]

86−extendAllToIncludeCommaIfPossible indexedString =

87− mergeRanges . go indexedString . sortOn _start

88− where

89− go _ [] = []

90− go input (r : rr)

91− | r' : _ <- extendToIncludeCommaIfPossible input r

92− , Just input' <- stripRange r' input

93− = r' : go input' rr

94− | otherwise

95− = go input rr

96−

97−extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]

98−extendToIncludeCommaIfPossible indexedString range

99− | Just (before, _, after) <- unconsRange range indexedString

100− , after' <- dropWhile (isSpace . snd) after

101− , before' <- dropWhile (isSpace . snd) (reverse before)

102− =

103− -- a, |b|, c ===> a|, b|, c

104− [ range { _start = start' } | (start', ',') : _ <- [before'] ]

105− ++

106− -- a, |b|, c ===> a, |b, |c

107− [ range { _end = end' }

108− | (_, ',') : rest <- [after']

109− , let (end', _) : _ = dropWhile (isSpace . snd) rest

110− ]

111− | otherwise

112− = [range]

src/Development/IDE/Plugin/CodeAction/RuleTypes.hsdeleted−61

@@ -1,61 +0,0 @@

1−{-# LANGUAGE TypeFamilies #-}

2−module Development.IDE.Plugin.CodeAction.RuleTypes

3− (PackageExports(..), PackageExportsMap

4− ,IdentInfo(..)

5− ,mkIdentInfos

6− ) where

7−

8−import Avail (AvailInfo(..))

9−import Data.Hashable (Hashable)

10−import Control.DeepSeq (NFData)

11−import Data.Binary (Binary)

12−import Data.Text (pack, Text)

13−import Development.IDE.GHC.Util

14−import Development.Shake (RuleResult)

15−import Data.HashMap.Strict (HashMap)

16−import Data.Typeable (Typeable)

17−import GHC.Generics (Generic)

18−import Name

19−import FieldLabel (flSelector)

20−

21−type Identifier = Text

22−type ModuleName = Text

23−

24−data IdentInfo = IdentInfo

25− { name :: !Identifier

26− , rendered :: Text

27− , parent :: !(Maybe Text)

28− , isDatacon :: !Bool

29− }

30− deriving (Eq, Generic, Show)

31−

32−instance NFData IdentInfo

33−

34−mkIdentInfos :: AvailInfo -> [IdentInfo]

35−mkIdentInfos (Avail n) =

36− [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)]

37−mkIdentInfos (AvailTC parent (n:nn) flds)

38− -- Following the GHC convention that parent == n if parent is exported

39− | n == parent

40− = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) True

41− | n <- nn ++ map flSelector flds

42− ] ++

43− [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing False]

44− where

45− parentP = pack $ prettyPrint parent

46−

47−mkIdentInfos (AvailTC _ nn flds)

48− = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing True

49− | n <- nn ++ map flSelector flds

50− ]

51−

52−-- Rule type for caching Package Exports

53−type instance RuleResult PackageExports = PackageExportsMap

54−type PackageExportsMap = HashMap Identifier [(IdentInfo,ModuleName)]

55−

56−newtype PackageExports = PackageExports HscEnvEq

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

58−

59−instance Hashable PackageExports

60−instance NFData PackageExports

61−instance Binary PackageExports

src/Development/IDE/Plugin/CodeAction/Rules.hsdeleted−61

@@ -1,61 +0,0 @@

1−module Development.IDE.Plugin.CodeAction.Rules

2− ( rulePackageExports

3− )

4−where

5−

6−import Data.HashMap.Strict ( fromListWith )

7−import Data.Text ( Text

8− , pack

9− )

10−import Data.Traversable ( forM )

11−import Development.IDE.Core.Rules

12−import Development.IDE.GHC.Util

13−import Development.IDE.Plugin.CodeAction.RuleTypes

14−import Development.Shake

15−import GHC ( DynFlags(pkgState) )

16−import HscTypes ( IfaceExport

17− , hsc_dflags

18− , mi_exports

19− )

20−import LoadIface

21−import Maybes

22−import Module ( Module(..)

23− , ModuleName

24− , moduleNameString

25− )

26−import Packages ( explicitPackages

27− , exposedModules

28− , packageConfigId

29− )

30−import TcRnMonad ( WhereFrom(ImportByUser)

31− , initIfaceLoad

32− )

33−

34−rulePackageExports :: Rules ()

35−rulePackageExports = defineNoFile $ \(PackageExports session) -> do

36− let env = hscEnv session

37− pkgst = pkgState (hsc_dflags env)

38− depends = explicitPackages pkgst

39− targets =

40− [ (pkg, mn)

41− | d <- depends

42− , Just pkg <- [lookupPackageConfig d env]

43− , (mn, _) <- exposedModules pkg

44− ]

45−

46− results <- forM targets $ \(pkg, mn) -> do

47− modIface <- liftIO $ initIfaceLoad env $ loadInterface

48− ""

49− (Module (packageConfigId pkg) mn)

50− (ImportByUser False)

51− case modIface of

52− Failed _err -> return mempty

53− Succeeded mi -> do

54− let avails = mi_exports mi

55− return $ concatMap (unpackAvail mn) avails

56− return $ fromListWith (++) $ concat results

57−

58−unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])]

59−unpackAvail mod =

60− map (\id@IdentInfo {..} -> (name, [(id, pack $ moduleNameString mod)]))

61− . mkIdentInfos

src/Development/IDE/Plugin/Completions.hsdeleted−103

@@ -1,103 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE TypeFamilies #-}

3−#include "ghc-api-version.h"

4−

5−module Development.IDE.Plugin.Completions(plugin) where

6−

7−import Control.Applicative

8−import Language.Haskell.LSP.Messages

9−import Language.Haskell.LSP.Types

10−import qualified Language.Haskell.LSP.Core as LSP

11−import qualified Language.Haskell.LSP.VFS as VFS

12−import Language.Haskell.LSP.Types.Capabilities

13−import Development.Shake.Classes

14−import Development.Shake

15−import GHC.Generics

16−

17−import Development.IDE.Plugin

18−import Development.IDE.Core.Service

19−import Development.IDE.Plugin.Completions.Logic

20−import Development.IDE.Types.Location

21−import Development.IDE.Core.PositionMapping

22−import Development.IDE.Core.RuleTypes

23−import Development.IDE.Core.Shake

24−import Development.IDE.GHC.Util

25−import Development.IDE.LSP.Server

26−

27−#if !MIN_GHC_API_VERSION(8,6,0) || defined(GHC_LIB)

28−import Data.Maybe

29−import Development.IDE.Import.DependencyInformation

30−#endif

31−

32−plugin :: Plugin c

33−plugin = Plugin produceCompletions setHandlersCompletion

34−

35−produceCompletions :: Rules ()

36−produceCompletions =

37− define $ \ProduceCompletions file -> do

38−

39−-- When possible, rely on the haddocks embedded in our interface files

40−-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'

41−#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)

42− let parsedDeps = []

43−#else

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

45− parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)

46−#endif

47− tm <- fmap fst <$> useWithStale TypeCheck file

48− packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file

49− case (tm, packageState) of

50− (Just tm', Just packageState') -> do

51− cdata <- liftIO $ cacheDataProducer packageState'

52− (tmrModule tm') parsedDeps

53− return ([], Just cdata)

54− _ -> return ([], Nothing)

55−

56−

57−-- | Produce completions info for a file

58−type instance RuleResult ProduceCompletions = CachedCompletions

59−

60−data ProduceCompletions = ProduceCompletions

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

62−instance Hashable ProduceCompletions

63−instance NFData ProduceCompletions

64−instance Binary ProduceCompletions

65−

66−

67−-- | Generate code actions.

68−getCompletionsLSP

69− :: LSP.LspFuncs c

70− -> IdeState

71− -> CompletionParams

72− -> IO (Either ResponseError CompletionResponseResult)

73−getCompletionsLSP lsp ide

74− CompletionParams{_textDocument=TextDocumentIdentifier uri

75− ,_position=position

76− ,_context=completionContext} = do

77− contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri

78− fmap Right $ case (contents, uriToFilePath' uri) of

79− (Just cnts, Just path) -> do

80− let npath = toNormalizedFilePath' path

81− (ideOpts, compls) <- runAction ide $ do

82− opts <- getIdeOptions

83− compls <- useWithStale ProduceCompletions npath

84− pm <- useWithStale GetParsedModule npath

85− pure (opts, liftA2 (,) compls pm)

86− case compls of

87− Just ((cci', _), (pm, mapping)) -> do

88− let !position' = fromCurrentPosition mapping position

89− pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'

90− case (pfix, completionContext) of

91− (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})

92− -> return (Completions $ List [])

93− (Just pfix', _) -> do

94− let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing

95− Completions . List <$> getCompletions ideOpts cci' pm pfix' fakeClientCapabilities (WithSnippets True)

96− _ -> return (Completions $ List [])

97− _ -> return (Completions $ List [])

98− _ -> return (Completions $ List [])

99−

100−setHandlersCompletion :: PartialHandlers c

101−setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{

102− LSP.completionHandler = withResponse RspCompletion getCompletionsLSP

103− }

src/Development/IDE/Spans/AtPoint.hs+43−60

@@ -8,24 +8,25 @@ module Development.IDE.Spans.AtPoint (

8 , gotoDefinition

9 ) where

11+import Development.IDE.Spans.Documentation

11import Development.IDE.GHC.Error

12import Development.IDE.GHC.Error

12import Development.IDE.GHC.Orphans()

13import Development.IDE.GHC.Orphans()

13import Development.IDE.Types.Location

14import Development.IDE.Types.Location

15-- DAML compiler and infrastructure

16-- DAML compiler and infrastructure

17+import Development.Shake

18+import Development.IDE.GHC.Util

16import Development.IDE.GHC.Compat

19import Development.IDE.GHC.Compat

17import Development.IDE.Types.Options

20import Development.IDE.Types.Options

18−import Development.IDE.Spans.Type as SpanInfo

21+import Development.IDE.Spans.Type as SpanInfo

19−import Development.IDE.Spans.Common (spanDocToMarkdown)

21-- GHC API imports

23-- GHC API imports

24+import Avail

22import DynFlags

25import DynFlags

23import FastString

26import FastString

24import Name

27import Name

25import Outputable hiding ((<>))

28import Outputable hiding ((<>))

26import SrcLoc

29import SrcLoc

27−import Type

28−import VarSet

30import Control.Monad.Extra

31import Control.Monad.Extra

31import Control.Monad.Trans.Maybe

32import Control.Monad.Trans.Maybe

@@ -37,62 +38,52 @@ import qualified Data.Text as T

37-- | Locate the definition of the name at a given position.

38-- | Locate the definition of the name at a given position.

38gotoDefinition

39gotoDefinition

39 :: MonadIO m

40 :: MonadIO m

40− => (Module -> m (Maybe (HieFile, FilePath)))

41+ => (FilePath -> m (Maybe HieFile))

41 -> IdeOptions

42 -> IdeOptions

43+ -> HscEnv

42 -> [SpanInfo]

44 -> [SpanInfo]

43 -> Position

45 -> Position

44 -> m (Maybe Location)

46 -> m (Maybe Location)

45−gotoDefinition getHieFile ideOpts srcSpans pos =

47+gotoDefinition getHieFile ideOpts pkgState srcSpans pos =

46− listToMaybe <$> locationsAtPoint getHieFile ideOpts pos srcSpans

48+ listToMaybe <$> locationsAtPoint getHieFile ideOpts pkgState pos srcSpans

48-- | Synopsis for the name at a given position.

50-- | Synopsis for the name at a given position.

49atPoint

51atPoint

50 :: IdeOptions

52 :: IdeOptions

51− -> SpansInfo

53+ -> [TypecheckedModule]

54+ -> [SpanInfo]

52 -> Position

55 -> Position

53 -> Maybe (Maybe Range, [T.Text])

56 -> Maybe (Maybe Range, [T.Text])

54−atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do

57+atPoint IdeOptions{..} tcs srcSpans pos = do

55 firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans

58 firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans

56− let constraintsAtPoint = mapMaybe spaninfoType (spansAtPoint pos cntsSpans)

57− return (Just (range firstSpan), hoverInfo firstSpan constraintsAtPoint)

59+ return (Just (range firstSpan), hoverInfo firstSpan)

58 where

60 where

59 -- Hover info for types, classes, type variables

61 -- Hover info for types, classes, type variables

60− hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs , ..} _ =

62+ hoverInfo SpanInfo{spaninfoType = Nothing , ..} =

61− (wrapLanguageSyntax <$> name) <> location <> spanDocToMarkdown docs

63+ documentation <> (wrapLanguageSyntax <$> name <> kind) <> location

62 where

64 where

65+ documentation = findDocumentation mbName

63 name = [maybe shouldNotHappen showName mbName]

66 name = [maybe shouldNotHappen showName mbName]

64 location = [maybe shouldNotHappen definedAt mbName]

67 location = [maybe shouldNotHappen definedAt mbName]

68+ kind = [] -- TODO

65 shouldNotHappen = "ghcide: did not expect a type level component without a name"

69 shouldNotHappen = "ghcide: did not expect a type level component without a name"

66 mbName = getNameM spaninfoSource

70 mbName = getNameM spaninfoSource

68 -- Hover info for values/data

72 -- Hover info for values/data

69− hoverInfo SpanInfo{spaninfoType = (Just typ), spaninfoDocs = docs , ..} cnts =

73+ hoverInfo SpanInfo{spaninfoType = (Just typ), ..} =

70− (wrapLanguageSyntax <$> nameOrSource) <> location <> spanDocToMarkdown docs

74+ documentation <> (wrapLanguageSyntax <$> nameOrSource <> typeAnnotation) <> location

71 where

75 where

72 mbName = getNameM spaninfoSource

76 mbName = getNameM spaninfoSource

73− expr = case spaninfoSource of

77+ documentation = findDocumentation mbName

74− Named n -> qualifyNameIfPossible n

75− Lit l -> crop $ T.pack l

76− _ -> ""

77− nameOrSource = [expr <> "\n" <> typeAnnotation]

78+ typeAnnotation = [colon <> showName typ]

79+ nameOrSource = [maybe literalSource qualifyNameIfPossible mbName]

80+ literalSource = "" -- TODO: literals: display (length-limited) source

78 qualifyNameIfPossible name' = modulePrefix <> showName name'

81 qualifyNameIfPossible name' = modulePrefix <> showName name'

79 where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')

82 where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')

80 location = [maybe "" definedAt mbName]

83 location = [maybe "" definedAt mbName]

82− thisFVs = tyCoVarsOfType typ

85+ findDocumentation = maybe [] (getDocumentation tcs)

83− constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts

84− constraintsT = T.intercalate ", " (map showName constraintsOverFVs)

85−

86− typeAnnotation = case constraintsOverFVs of

87− [] -> colon <> showName typ

88− [_] -> colon <> constraintsT <> "\n=> " <> showName typ

89− _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ

90−

91− definedAt name = "*Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "*\n"

86+ definedAt name = "**Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "**\n"

92−

93− crop txt

94− | T.length txt > 50 = T.take 46 txt <> " ..."

95− | otherwise = txt

97 range SpanInfo{..} = Range

88 range SpanInfo{..} = Range

98 (Position spaninfoStartLine spaninfoStartCol)

89 (Position spaninfoStartLine spaninfoStartCol)

@@ -115,38 +106,34 @@ atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do

115 Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]

106 Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]

116 Nothing -> False

107 Nothing -> False

117

108

118−locationsAtPoint

109+locationsAtPoint :: forall m . MonadIO m => (FilePath -> m (Maybe HieFile)) -> IdeOptions -> HscEnv -> Position -> [SpanInfo] -> m [Location]

119− :: forall m

120− . MonadIO m

121− => (Module -> m (Maybe (HieFile, FilePath)))

122− -> IdeOptions

123− -> Position

124− -> [SpanInfo]

125− -> m [Location]

126−locationsAtPoint getHieFile _ideOptions pos =

110+locationsAtPoint getHieFile IdeOptions{..} pkgState pos =

127 fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos

111 fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos

128 where getSpan :: SpanSource -> m (Maybe SrcSpan)

112 where getSpan :: SpanSource -> m (Maybe SrcSpan)

129 getSpan NoSource = pure Nothing

113 getSpan NoSource = pure Nothing

130 getSpan (SpanS sp) = pure $ Just sp

114 getSpan (SpanS sp) = pure $ Just sp

131− getSpan (Lit _) = pure Nothing

132 getSpan (Named name) = case nameSrcSpan name of

115 getSpan (Named name) = case nameSrcSpan name of

133 sp@(RealSrcSpan _) -> pure $ Just sp

116 sp@(RealSrcSpan _) -> pure $ Just sp

134 sp@(UnhelpfulSpan _) -> runMaybeT $ do

117 sp@(UnhelpfulSpan _) -> runMaybeT $ do

135 guard (sp /= wiredInSrcSpan)

118 guard (sp /= wiredInSrcSpan)

136− -- This case usually arises when the definition is in an external package (DAML only).

119+ -- This case usually arises when the definition is in an external package.

137 -- In this case the interface files contain garbage source spans

120 -- In this case the interface files contain garbage source spans

138 -- so we instead read the .hie files to get useful source spans.

121 -- so we instead read the .hie files to get useful source spans.

139− mod <- MaybeT $ return $ nameModule_maybe name

122+ let mod = nameModule name

123+ let unitId = moduleUnitId mod

124+ pkgConfig <- MaybeT $ pure $ lookupPackageConfig unitId pkgState

125+ hiePath <- MaybeT $ liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod

140− (hieFile, srcPath) <- MaybeT $ getHieFile mod

126+ hieFile <- MaybeT $ getHieFile hiePath

141− avail <- MaybeT $ pure $ find (eqName name . snd) $ hieExportNames hieFile

127+ avail <- MaybeT $ pure $ listToMaybe (filterAvails (eqName name) $ hie_exports hieFile)

128+ srcPath <- MaybeT $ liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod

142 -- The location will point to the source file used during compilation.

129 -- The location will point to the source file used during compilation.

143 -- This file might no longer exists and even if it does the path will be relative

130 -- This file might no longer exists and even if it does the path will be relative

144 -- to the compilation directory which we don’t know.

131 -- to the compilation directory which we don’t know.

145− let span = setFileName srcPath $ fst avail

132+ let span = setFileName srcPath $ nameSrcSpan $ availName avail

146 pure span

133 pure span

147 -- We ignore uniques and source spans and only compare the name and the module.

134 -- We ignore uniques and source spans and only compare the name and the module.

148 eqName :: Name -> Name -> Bool

135 eqName :: Name -> Name -> Bool

149− eqName n n' = nameOccName n == nameOccName n' && nameModule_maybe n == nameModule_maybe n'

136+ eqName n n' = nameOccName n == nameOccName n' && nameModule n == nameModule n'

150 setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })

137 setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })

151 setFileName _ span@(UnhelpfulSpan _) = span

138 setFileName _ span@(UnhelpfulSpan _) = span

152

139

@@ -155,16 +142,12 @@ spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo]

155spansAtPoint pos = filter atp where

142spansAtPoint pos = filter atp where

156 line = _line pos

143 line = _line pos

157 cha = _character pos

144 cha = _character pos

158− atp SpanInfo{..} =

159− startsBeforePosition && endsAfterPosition

160− where

161− startLineCmp = compare spaninfoStartLine line

145+ atp SpanInfo{..} = spaninfoStartLine <= line

162− endLineCmp = compare spaninfoEndLine line

146+ && spaninfoEndLine >= line

163−

164− startsBeforePosition = startLineCmp == LT || (startLineCmp == EQ && spaninfoStartCol <= cha)

147+ && spaninfoStartCol <= cha

165− -- The end col points to the column after the

148+ -- The end col points to the column after the

166− -- last character so we use > instead of >=

149+ -- last character so we use > instead of >=

167− endsAfterPosition = endLineCmp == GT || (endLineCmp == EQ && spaninfoEndCol > cha)

150+ && spaninfoEndCol > cha

168

151

169showName :: Outputable a => a -> T.Text

152showName :: Outputable a => a -> T.Text

170showName = T.pack . prettyprint

153showName = T.pack . prettyprint

src/Development/IDE/Spans/Calculate.hs+65−149

@@ -9,35 +9,29 @@

10-- | Get information on modules, identifiers, etc.

12−module Development.IDE.Spans.Calculate(getSrcSpanInfos) where

12+module Development.IDE.Spans.Calculate(getSrcSpanInfos,listifyAllSpans) where

14import ConLike

15import Control.Monad

16import qualified CoreUtils

17+import Data.Data

18+import qualified Data.Generics

17import Data.List

19import Data.List

18import Data.Maybe

20import Data.Maybe

19import DataCon

21import DataCon

20import Desugar

22import Desugar

21import GHC

23import GHC

22import GhcMonad

24import GhcMonad

23−import HscTypes

24import FastString (mkFastString)

25import FastString (mkFastString)

25−import OccName

26import Development.IDE.Types.Location

27import Development.IDE.Spans.Type

28−#ifdef GHC_LIB

29import Development.IDE.GHC.Error (zeroSpan)

28import Development.IDE.GHC.Error (zeroSpan)

30−#else

31−import Development.IDE.GHC.Error (zeroSpan, catchSrcErrors)

32−#endif

33import Prelude hiding (mod)

29import Prelude hiding (mod)

34import TcHsSyn

30import TcHsSyn

35import Var

31import Var

36import Development.IDE.Core.Compile

32import Development.IDE.Core.Compile

37−import qualified Development.IDE.GHC.Compat as Compat

38import Development.IDE.GHC.Util

33import Development.IDE.GHC.Util

39−import Development.IDE.Spans.Common

34+

40−import Development.IDE.Spans.Documentation

42-- A lot of things gained an extra X argument in GHC 8.6, which we mostly ignore

36-- A lot of things gained an extra X argument in GHC 8.6, which we mostly ignore

43-- this U ignores that arg in 8.6, but is hidden in 8.4

37-- this U ignores that arg in 8.6, but is hidden in 8.4

@@ -50,67 +44,42 @@ import Development.IDE.Spans.Documentation

50-- | Get source span info, used for e.g. AtPoint and Goto Definition.

44-- | Get source span info, used for e.g. AtPoint and Goto Definition.

51getSrcSpanInfos

45getSrcSpanInfos

52 :: HscEnv

46 :: HscEnv

53− -> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order

47+ -> [(Located ModuleName, Maybe NormalizedFilePath)]

54 -> TcModuleResult

48 -> TcModuleResult

55− -> [ParsedModule] -- ^ Dependencies parsed, optional

49+ -> IO [SpanInfo]

56− -> [ModIface] -- ^ Dependencies module interfaces, required

57− -> IO SpansInfo

58−getSrcSpanInfos env imports tc parsedDeps deps =

50+getSrcSpanInfos env imports tc =

59− evalGhcEnv env $

51+ runGhcEnv env

60− getSpanInfo imports (tmrModule tc) parsedDeps deps

52+ . getSpanInfo imports

53+ $ tmrModule tc

62-- | Get ALL source spans in the module.

55-- | Get ALL source spans in the module.

63getSpanInfo :: GhcMonad m

56getSpanInfo :: GhcMonad m

64 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports

57 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports

65 -> TypecheckedModule

58 -> TypecheckedModule

66− -> [ParsedModule]

59+ -> m [SpanInfo]

67− -> [ModIface]

68− -> m SpansInfo

69−getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps deps =

60+getSpanInfo mods tcm =

70− do let tcs = tm_typechecked_source

61+ do let tcs = tm_typechecked_source tcm

71 bs = listifyAllSpans tcs :: [LHsBind GhcTc]

62 bs = listifyAllSpans tcs :: [LHsBind GhcTc]

72 es = listifyAllSpans tcs :: [LHsExpr GhcTc]

63 es = listifyAllSpans tcs :: [LHsExpr GhcTc]

73 ps = listifyAllSpans' tcs :: [Pat GhcTc]

64 ps = listifyAllSpans' tcs :: [Pat GhcTc]

74− ts = listifyAllSpans tm_renamed_source :: [LHsType GhcRn]

65+ ts = listifyAllSpans $ tm_renamed_source tcm :: [LHsType GhcRn]

75− allModules = tm_parsed_module : parsedDeps

76− funBinds = funBindMap tm_parsed_module

77−

78− -- Load all modules in HPT to make their interface documentation available

79− mapM_ (`loadDepModule` Nothing) (reverse deps)

80− forM_ (modInfoIface tm_checked_module_info) $ \modIface ->

81− modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing)

82−

83− bts <- mapM (getTypeLHsBind allModules funBinds) bs -- binds

66+ bts <- mapM (getTypeLHsBind tcm) bs -- binds

84− ets <- mapM (getTypeLHsExpr allModules) es -- expressions

67+ ets <- mapM (getTypeLHsExpr tcm) es -- expressions

85− pts <- mapM (getTypeLPat allModules) ps -- patterns

68+ pts <- mapM (getTypeLPat tcm) ps -- patterns

86− tts <- mapM (getLHsType allModules) ts -- types

69+ tts <- mapM (getLHsType tcm) ts -- types

87 let imports = importInfo mods

70 let imports = importInfo mods

88 let exports = getExports tcm

71 let exports = getExports tcm

89− let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)

72+ let exprs = exports ++ imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)

90− let constraints = map constraintToInfo (concatMap getConstraintsLHsBind bs)

91− return $ SpansInfo (mapMaybe toSpanInfo (sortBy cmp exprs))

73+ return (mapMaybe toSpanInfo (sortBy cmp exprs))

92− (mapMaybe toSpanInfo (sortBy cmp constraints))

93− where cmp (_,a,_,_) (_,b,_,_)

74+ where cmp (_,a,_) (_,b,_)

94 | a `isSubspanOf` b = LT

75 | a `isSubspanOf` b = LT

95 | b `isSubspanOf` a = GT

76 | b `isSubspanOf` a = GT

96 | otherwise = compare (srcSpanStart a) (srcSpanStart b)

77 | otherwise = compare (srcSpanStart a) (srcSpanStart b)

98− addEmptyInfo = map (\(a,b) -> (a,b,Nothing,emptySpanDoc))

99− constraintToInfo (sp, ty) = (SpanS sp, sp, Just ty, emptySpanDoc)

100−

101−-- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always

102−-- points to the first match) whereas the parsed module has the correct locations.

103−-- Therefore we build up a map from OccName to the corresponding definition in the parsed module

104−-- to lookup precise locations for things like multi-clause function definitions.

105−--

106−-- For now this only contains FunBinds.

107−funBindMap :: ParsedModule -> OccEnv (HsBind GhcPs)

108−funBindMap pm = mkOccEnv $ [ (occName $ unLoc f, bnd) | L _ (Compat.ValD bnd@FunBind{fun_id = f}) <- hsmodDecls $ unLoc $ pm_parsed_source pm ]

109−

110−getExports :: TypecheckedModule -> [(SpanSource, SrcSpan)]

79+getExports :: TypecheckedModule -> [(SpanSource, SrcSpan, Maybe Type)]

111getExports m

80getExports m

112 | Just (_, _, Just exports, _) <- renamedSource m =

81 | Just (_, _, Just exports, _) <- renamedSource m =

113− [ (Named $ unLoc n, getLoc n)

82+ [ (Named $ unLoc n, getLoc n, Nothing)

114 | (e, _) <- exports

83 | (e, _) <- exports

115 , n <- ieLNames $ unLoc e

84 , n <- ieLNames $ unLoc e

116 ]

85 ]

@@ -126,96 +95,44 @@ ieLNames _ = []

126

127-- | Get the name and type of a binding.

96-- | Get the name and type of a binding.

128getTypeLHsBind :: (GhcMonad m)

97getTypeLHsBind :: (GhcMonad m)

129− => [ParsedModule]

98+ => TypecheckedModule

130− -> OccEnv (HsBind GhcPs)

131 -> LHsBind GhcTc

99 -> LHsBind GhcTc

132− -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]

100+ -> m [(SpanSource, SrcSpan, Maybe Type)]

133−getTypeLHsBind deps funBinds (L _spn FunBind{fun_id = pid})

101+getTypeLHsBind _ (L _spn FunBind{ fun_id = pid

134− | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) = do

102+ , fun_matches = MG{mg_alts=(L _ matches)}}) =

135− let name = getName (unLoc pid)

136− docs <- getDocumentationTryGhc deps name

137− return [(Named name, getLoc mc_fun, Just (varType (unLoc pid)), docs) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]

103+ return [(Named (getName (unLoc pid)), getLoc match, Just (varType (unLoc pid))) | match <- matches ]

138−-- In theory this shouldn’t ever fail but if it does, we can at least show the first clause.

139−getTypeLHsBind deps _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do

140− let name = getName (unLoc pid)

141− docs <- getDocumentationTryGhc deps name

142− return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)]

143−getTypeLHsBind _ _ _ = return []

104+getTypeLHsBind _ _ = return []

144−

145−-- | Get information about constraints

146−getConstraintsLHsBind :: LHsBind GhcTc

147− -> [(SrcSpan, Type)]

148−getConstraintsLHsBind (L spn AbsBinds { abs_ev_vars = vars })

149− = map (\v -> (spn, varType v)) vars

150−getConstraintsLHsBind _ = []

151

105

152-- | Get the name and type of an expression.

106-- | Get the name and type of an expression.

153getTypeLHsExpr :: (GhcMonad m)

107getTypeLHsExpr :: (GhcMonad m)

154− => [ParsedModule]

108+ => TypecheckedModule

155 -> LHsExpr GhcTc

109 -> LHsExpr GhcTc

156− -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))

110+ -> m (Maybe (SpanSource, SrcSpan, Maybe Type))

157−getTypeLHsExpr deps e = do

111+getTypeLHsExpr _ e = do

158 hs_env <- getSession

112 hs_env <- getSession

159 (_, mbe) <- liftIO (deSugarExpr hs_env e)

113 (_, mbe) <- liftIO (deSugarExpr hs_env e)

114+ return $

160− case mbe of

115+ case mbe of

161− Just expr -> do

116+ Just expr ->

162− let ss = getSpanSource (unLoc e)

163− docs <- case ss of

164− Named n -> getDocumentationTryGhc deps n

165− _ -> return emptySpanDoc

166− return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr), docs)

117+ Just (getSpanSource (unLoc e), getLoc e, Just (CoreUtils.exprType expr))

167− Nothing -> return Nothing

118+ Nothing -> Nothing

168 where

119 where

169 getSpanSource :: HsExpr GhcTc -> SpanSource

120 getSpanSource :: HsExpr GhcTc -> SpanSource

170− getSpanSource xpr | isLit xpr = Lit (showGhc xpr)

171 getSpanSource (HsVar U (L _ i)) = Named (getName i)

121 getSpanSource (HsVar U (L _ i)) = Named (getName i)

172 getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)

122 getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)

173 getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name)

123 getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name)

174 getSpanSource (HsWrap U _ xpr) = getSpanSource xpr

124 getSpanSource (HsWrap U _ xpr) = getSpanSource xpr

175 getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr)

125 getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr)

176− getSpanSource _ = NoSource

126+ getSpanSource _ = NoSource

177−

178− isLit :: HsExpr GhcTc -> Bool

179− isLit (HsLit U _) = True

180− isLit (HsOverLit U _) = True

181− isLit (ExplicitTuple U args _) = all (isTupLit . unLoc) args

182−#if MIN_GHC_API_VERSION(8,6,0)

183− isLit (ExplicitSum U _ _ xpr) = isLitChild (unLoc xpr)

184− isLit (ExplicitList U _ xprs) = all (isLitChild . unLoc) xprs

185−#else

186− isLit (ExplicitSum _ _ xpr _) = isLitChild (unLoc xpr)

187− isLit (ExplicitList _ _ xprs) = all (isLitChild . unLoc) xprs

188−#endif

189− isLit _ = False

190−

191− isTupLit (Present U xpr) = isLitChild (unLoc xpr)

192− isTupLit _ = False

193−

194− -- We need special treatment for children so things like [(1)] are still treated

195− -- as a list literal while not treating (1) as a literal.

196− isLitChild (HsWrap U _ xpr) = isLitChild xpr

197− isLitChild (HsPar U xpr) = isLitChild (unLoc xpr)

198−#if MIN_GHC_API_VERSION(8,8,0)

199− isLitChild (ExprWithTySig U xpr _) = isLitChild (unLoc xpr)

200−#elif MIN_GHC_API_VERSION(8,6,0)

201− isLitChild (ExprWithTySig U xpr) = isLitChild (unLoc xpr)

202−#else

203− isLitChild (ExprWithTySigOut xpr _) = isLitChild (unLoc xpr)

204− isLitChild (ExprWithTySig xpr _) = isLitChild (unLoc xpr)

205−#endif

206− isLitChild e = isLit e

207

127

208-- | Get the name and type of a pattern.

128-- | Get the name and type of a pattern.

209getTypeLPat :: (GhcMonad m)

129getTypeLPat :: (GhcMonad m)

210− => [ParsedModule]

130+ => TypecheckedModule

211 -> Pat GhcTc

131 -> Pat GhcTc

212− -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))

132+ -> m (Maybe (SpanSource, SrcSpan, Maybe Type))

213−getTypeLPat deps pat = do

133+getTypeLPat _ pat =

214− let (src, spn) = getSpanSource pat

134+ let (src, spn) = getSpanSource pat in

215− docs <- case src of

216− Named n -> getDocumentationTryGhc deps n

217− _ -> return emptySpanDoc

218− return $ Just (src, spn, Just (hsPatType pat), docs)

135+ return $ Just (src, spn, Just (hsPatType pat))

219 where

136 where

220 getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan)

137 getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan)

221 getSpanSource (VarPat U (L spn vid)) = (Named (getName vid), spn)

138 getSpanSource (VarPat U (L spn vid)) = (Named (getName vid), spn)

@@ -225,40 +142,40 @@ getTypeLPat deps pat = do

225

142

226getLHsType

143getLHsType

227 :: GhcMonad m

144 :: GhcMonad m

228− => [ParsedModule]

145+ => TypecheckedModule

229 -> LHsType GhcRn

146 -> LHsType GhcRn

230− -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]

147+ -> m [(SpanSource, SrcSpan, Maybe Type)]

231−getLHsType deps (L spn (HsTyVar U _ v)) = do

148+getLHsType _ (L spn (HsTyVar U _ v)) = pure [(Named $ unLoc v, spn, Nothing)]

232− let n = unLoc v

233− docs <- getDocumentationTryGhc deps n

234−#ifdef GHC_LIB

235− let ty = Right Nothing

236−#else

237− ty <- catchSrcErrors "completion" $ do

238− name' <- lookupName n

239− return $ name' >>= safeTyThingType

240−#endif

241− let ty' = case ty of

242− Right (Just x) -> Just x

243− _ -> Nothing

244− pure [(Named n, spn, ty', docs)]

245getLHsType _ _ = pure []

149getLHsType _ _ = pure []

246

150

247importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]

151importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]

248− -> [(SpanSource, SrcSpan)]

152+ -> [(SpanSource, SrcSpan, Maybe Type)]

249importInfo = mapMaybe (uncurry wrk) where

153importInfo = mapMaybe (uncurry wrk) where

250− wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan)

154+ wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan, Maybe Type)

251 wrk modName = \case

155 wrk modName = \case

252 Nothing -> Nothing

156 Nothing -> Nothing

253− Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName)

157+ Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName, Nothing)

254

158

255 -- TODO make this point to the module name

159 -- TODO make this point to the module name

256 fpToSpanSource :: FilePath -> SpanSource

160 fpToSpanSource :: FilePath -> SpanSource

257 fpToSpanSource fp = SpanS $ RealSrcSpan $ zeroSpan $ mkFastString fp

161 fpToSpanSource fp = SpanS $ RealSrcSpan $ zeroSpan $ mkFastString fp

258

162

163+-- | Get ALL source spans in the source.

164+listifyAllSpans :: (Typeable a, Data m) => m -> [Located a]

165+listifyAllSpans tcs =

166+ Data.Generics.listify p tcs

167+ where p (L spn _) = isGoodSrcSpan spn

168+-- This is a version of `listifyAllSpans` specialized on picking out

169+-- patterns. It comes about since GHC now defines `type LPat p = Pat

170+-- p` (no top-level locations).

171+listifyAllSpans' :: Typeable a

172+ => TypecheckedSource -> [Pat a]

173+listifyAllSpans' tcs = Data.Generics.listify (const True) tcs

174+

175+

259-- | Pretty print the types into a 'SpanInfo'.

176-- | Pretty print the types into a 'SpanInfo'.

260−toSpanInfo :: (SpanSource, SrcSpan, Maybe Type, SpanDoc) -> Maybe SpanInfo

177+toSpanInfo :: (SpanSource, SrcSpan, Maybe Type) -> Maybe SpanInfo

261−toSpanInfo (name,mspan,typ,docs) =

178+toSpanInfo (name,mspan,typ) =

262 case mspan of

179 case mspan of

263 RealSrcSpan spn ->

180 RealSrcSpan spn ->

264 -- GHC’s line and column numbers are 1-based while LSP’s line and column

181 -- GHC’s line and column numbers are 1-based while LSP’s line and column

@@ -268,6 +185,5 @@ toSpanInfo (name,mspan,typ,docs) =

268 (srcSpanEndLine spn - 1)

185 (srcSpanEndLine spn - 1)

269 (srcSpanEndCol spn - 1)

186 (srcSpanEndCol spn - 1)

270 typ

187 typ

271− name

188+ name)

272− docs)

273 _ -> Nothing

189 _ -> Nothing

src/Development/IDE/Spans/Common.hsdeleted−162

@@ -1,162 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−#include "ghc-api-version.h"

3−

4−module Development.IDE.Spans.Common (

5− showGhc

6−, listifyAllSpans

7−, listifyAllSpans'

8−, safeTyThingId

9−#ifndef GHC_LIB

10−, safeTyThingType

11−#endif

12−, SpanDoc(..)

13−, emptySpanDoc

14−, spanDocToMarkdown

15−, spanDocToMarkdownForTest

16−) where

17−

18−import Data.Data

19−import qualified Data.Generics

20−import qualified Data.Text as T

21−import Data.List.Extra

22−

23−import GHC

24−import Outputable

25−import DynFlags

26−import ConLike

27−import DataCon

28−#ifndef GHC_LIB

29−import Var

30−#endif

31−

32−import qualified Documentation.Haddock.Parser as H

33−import qualified Documentation.Haddock.Types as H

34−

35−showGhc :: Outputable a => a -> String

36−showGhc = showPpr unsafeGlobalDynFlags

37−

38−-- | Get ALL source spans in the source.

39−listifyAllSpans :: (Typeable a, Data m) => m -> [Located a]

40−listifyAllSpans tcs =

41− Data.Generics.listify p tcs

42− where p (L spn _) = isGoodSrcSpan spn

43−-- This is a version of `listifyAllSpans` specialized on picking out

44−-- patterns. It comes about since GHC now defines `type LPat p = Pat

45−-- p` (no top-level locations).

46−listifyAllSpans' :: Typeable a

47− => TypecheckedSource -> [Pat a]

48−listifyAllSpans' tcs = Data.Generics.listify (const True) tcs

49−

50−#ifndef GHC_LIB

51−-- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs

52−safeTyThingType :: TyThing -> Maybe Type

53−safeTyThingType thing

54− | Just i <- safeTyThingId thing = Just (varType i)

55−safeTyThingType (ATyCon tycon) = Just (tyConKind tycon)

56−safeTyThingType _ = Nothing

57−#endif

58−

59−safeTyThingId :: TyThing -> Maybe Id

60−safeTyThingId (AnId i) = Just i

61−safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc

62−safeTyThingId _ = Nothing

63−

64−-- Possible documentation for an element in the code

65−data SpanDoc

66− = SpanDocString HsDocString

67− | SpanDocText [T.Text]

68− deriving Show

69−

70−emptySpanDoc :: SpanDoc

71−emptySpanDoc = SpanDocText []

72−

73−spanDocToMarkdown :: SpanDoc -> [T.Text]

74−#if MIN_GHC_API_VERSION(8,6,0)

75−spanDocToMarkdown (SpanDocString docs)

76− = [T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs]

77−#else

78−spanDocToMarkdown (SpanDocString _)

79− = []

80−#endif

81−spanDocToMarkdown (SpanDocText txt) = txt

82−

83−spanDocToMarkdownForTest :: String -> String

84−spanDocToMarkdownForTest

85− = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing

86−

87−-- Simple (and a bit hacky) conversion from Haddock markup to Markdown

88−haddockToMarkdown

89− :: H.DocH String String -> String

90−

91−haddockToMarkdown H.DocEmpty

92− = ""

93−haddockToMarkdown (H.DocAppend d1 d2)

94− = haddockToMarkdown d1 ++ " " ++ haddockToMarkdown d2

95−haddockToMarkdown (H.DocString s)

96− = s

97−haddockToMarkdown (H.DocParagraph p)

98− = "\n\n" ++ haddockToMarkdown p

99−haddockToMarkdown (H.DocIdentifier i)

100− = "`" ++ i ++ "`"

101−haddockToMarkdown (H.DocIdentifierUnchecked i)

102− = "`" ++ i ++ "`"

103−haddockToMarkdown (H.DocModule i)

104− = "`" ++ i ++ "`"

105−haddockToMarkdown (H.DocWarning w)

106− = haddockToMarkdown w

107−haddockToMarkdown (H.DocEmphasis d)

108− = "*" ++ haddockToMarkdown d ++ "*"

109−haddockToMarkdown (H.DocBold d)

110− = "**" ++ haddockToMarkdown d ++ "**"

111−haddockToMarkdown (H.DocMonospaced d)

112− = "`" ++ escapeBackticks (haddockToMarkdown d) ++ "`"

113− where

114− escapeBackticks "" = ""

115− escapeBackticks ('`':ss) = '\\':'`':escapeBackticks ss

116− escapeBackticks (s :ss) = s:escapeBackticks ss

117−haddockToMarkdown (H.DocCodeBlock d)

118− = "\n```haskell\n" ++ haddockToMarkdown d ++ "\n```\n"

119−haddockToMarkdown (H.DocExamples es)

120− = "\n```haskell\n" ++ unlines (map exampleToMarkdown es) ++ "\n```\n"

121− where

122− exampleToMarkdown (H.Example expr result)

123− = ">>> " ++ expr ++ "\n" ++ unlines result

124−haddockToMarkdown (H.DocHyperlink (H.Hyperlink url Nothing))

125− = "<" ++ url ++ ">"

126−haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))

127− = "[" ++ haddockToMarkdown label ++ "](" ++ url ++ ")"

128−haddockToMarkdown (H.DocPic (H.Picture url Nothing))

129− = "![](" ++ url ++ ")"

130−haddockToMarkdown (H.DocPic (H.Picture url (Just label)))

131− = "![" ++ label ++ "](" ++ url ++ ")"

132−haddockToMarkdown (H.DocAName aname)

133− = "[" ++ aname ++ "]:"

134−haddockToMarkdown (H.DocHeader (H.Header level title))

135− = replicate level '#' ++ " " ++ haddockToMarkdown title

136−

137−haddockToMarkdown (H.DocUnorderedList things)

138− = '\n' : (unlines $ map (("+ " ++) . trimStart . splitForList . haddockToMarkdown) things)

139−haddockToMarkdown (H.DocOrderedList things)

140− = '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things)

141−haddockToMarkdown (H.DocDefList things)

142− = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things)

143−

144−-- we cannot render math by default

145−haddockToMarkdown (H.DocMathInline _)

146− = "*cannot render inline math formula*"

147−haddockToMarkdown (H.DocMathDisplay _)

148− = "\n\n*cannot render display math formula*\n\n"

149−

150−-- TODO: render tables

151−haddockToMarkdown (H.DocTable _t)

152− = "\n\n*tables are not yet supported*\n\n"

153−

154−-- things I don't really know how to handle

155−haddockToMarkdown (H.DocProperty _)

156− = "" -- don't really know what to do

157−

158−splitForList :: String -> String

159−splitForList s

160− = case lines s of

161− [] -> ""

162− (first:rest) -> unlines $ first : map ((" " ++) . trimStart) rest

src/Development/IDE/Spans/Documentation.hs+17−40

@@ -1,12 +1,8 @@

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

4−{-# LANGUAGE CPP #-}

5−#include "ghc-api-version.h"

6−

7module Development.IDE.Spans.Documentation (

4module Development.IDE.Spans.Documentation (

8 getDocumentation

5 getDocumentation

9− , getDocumentationTryGhc

10 ) where

6 ) where

12import Control.Monad

8import Control.Monad

@@ -14,33 +10,15 @@ import Data.List.Extra

14import qualified Data.Map as M

10import qualified Data.Map as M

15import Data.Maybe

11import Data.Maybe

16import qualified Data.Text as T

12import qualified Data.Text as T

17−import Development.IDE.GHC.Compat

18import Development.IDE.GHC.Error

13import Development.IDE.GHC.Error

19−import Development.IDE.Spans.Common

14+import Development.IDE.Spans.Calculate

20import FastString

15import FastString

16+import GHC

21import SrcLoc

17import SrcLoc

24−getDocumentationTryGhc

25− :: GhcMonad m

26− => [ParsedModule]

27− -> Name

28− -> m SpanDoc

29−-- getDocs goes through the GHCi codepaths which cause problems on ghc-lib.

30−-- See https://github.com/digital-asset/daml/issues/4152 for more details.

31−#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)

32−getDocumentationTryGhc sources name = do

33− res <- catchSrcErrors "docs" $ getDocs name

34− case res of

35− Right (Right (Just docs, _)) -> return $ SpanDocString docs

36− _ -> return $ SpanDocText $ getDocumentation sources name

37−#else

38−getDocumentationTryGhc sources name = do

39− return $ SpanDocText $ getDocumentation sources name

40−#endif

41−

42getDocumentation

20getDocumentation

43− :: [ParsedModule] -- ^ All of the possible modules it could be defined in.

21+ :: [TypecheckedModule] -- ^ All of the possible modules it could be defined in.

44 -> Name -- ^ The name you want documentation for.

22 -> Name -- ^ The name you want documentation for.

45 -> [T.Text]

23 -> [T.Text]

46-- This finds any documentation between the name you want

24-- This finds any documentation between the name you want

@@ -50,18 +28,17 @@ getDocumentation

50-- may be edge cases where it is very wrong).

28-- may be edge cases where it is very wrong).

51-- TODO : Build a version of GHC exactprint to extract this information

29-- TODO : Build a version of GHC exactprint to extract this information

52-- more accurately.

30-- more accurately.

53−getDocumentation sources targetName = fromMaybe [] $ do

31+getDocumentation tcs targetName = fromMaybe [] $ do

54 -- Find the module the target is defined in.

32 -- Find the module the target is defined in.

55 targetNameSpan <- realSpan $ nameSrcSpan targetName

33 targetNameSpan <- realSpan $ nameSrcSpan targetName

56 tc <-

34 tc <-

35+ listToMaybe

57− find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)

36+ $ filter ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)

58− $ reverse sources -- TODO : Is reversing the list here really neccessary?

37+ $ reverse tcs -- TODO : Is reversing the list here really neccessary?

59−

60− -- Top level names bound by the module

38+ -- Names bound by the module (we want to exclude non-"top-level"

61− let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc

39+ -- bindings but unfortunately we get all here).

62− , L _ (ValD hsbind) <- hsmodDecls

63− , Just n <- [name_of_bind hsbind]

40+ let bs = mapMaybe name_of_bind

64− ]

41+ (listifyAllSpans (tm_typechecked_source tc) :: [LHsBind GhcTc])

65 -- Sort the names' source spans.

42 -- Sort the names' source spans.

66 let sortedSpans = sortedNameSpans bs

43 let sortedSpans = sortedNameSpans bs

67 -- Now go ahead and extract the docs.

44 -- Now go ahead and extract the docs.

@@ -83,16 +60,16 @@ getDocumentation sources targetName = fromMaybe [] $ do

83 where

60 where

84 -- Get the name bound by a binding. We only concern ourselves with

61 -- Get the name bound by a binding. We only concern ourselves with

85 -- @FunBind@ (which covers functions and variables).

62 -- @FunBind@ (which covers functions and variables).

86− name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)

63+ name_of_bind :: LHsBind GhcTc -> Maybe Name

87− name_of_bind FunBind {fun_id} = Just fun_id

64+ name_of_bind (L _ FunBind {fun_id}) = Just (getName (unLoc fun_id))

88 name_of_bind _ = Nothing

65 name_of_bind _ = Nothing

89 -- Get source spans from names, discard unhelpful spans, remove

66 -- Get source spans from names, discard unhelpful spans, remove

90 -- duplicates and sort.

67 -- duplicates and sort.

91− sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]

68+ sortedNameSpans :: [Name] -> [RealSrcSpan]

92− sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)

69+ sortedNameSpans ls = nubSort (mapMaybe (realSpan . nameSrcSpan) ls)

93 isBetween target before after = before <= target && target <= after

70 isBetween target before after = before <= target && target <= after

94− ann = snd . pm_annotations

71+ ann = snd . pm_annotations . tm_parsed_module

95− annotationFileName :: ParsedModule -> Maybe FastString

72+ annotationFileName :: TypecheckedModule -> Maybe FastString

96 annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann

73 annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann

97 realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]

74 realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]

98 realSpans =

75 realSpans =

src/Development/IDE/Spans/Type.hs+4−19

@@ -6,8 +6,7 @@

6-- | Types used separate to GHCi vanilla.

8module Development.IDE.Spans.Type(

9− SpansInfo(..)

10− , SpanInfo(..)

9+ SpanInfo(..)

11 , SpanSource(..)

10 , SpanSource(..)

12 , getNameM

11 , getNameM

13 ) where

12 ) where

@@ -16,15 +15,6 @@ import GHC

16import Control.DeepSeq

15import Control.DeepSeq

17import OccName

16import OccName

18import Development.IDE.GHC.Util

17import Development.IDE.GHC.Util

19−import Development.IDE.Spans.Common

20−

21−data SpansInfo =

22− SpansInfo { spansExprs :: [SpanInfo]

23− , spansConstraints :: [SpanInfo] }

24− deriving Show

25−

26−instance NFData SpansInfo where

27− rnf (SpansInfo e c) = liftRnf rnf e `seq` liftRnf rnf c

29-- | Type of some span of source code. Most of these fields are

19-- | Type of some span of source code. Most of these fields are

30-- unboxed but Haddock doesn't show that.

20-- unboxed but Haddock doesn't show that.

@@ -44,14 +34,11 @@ data SpanInfo =

44 -- any. This can be useful for accessing a variety of

34 -- any. This can be useful for accessing a variety of

45 -- information about the identifier such as module,

35 -- information about the identifier such as module,

46 -- locality, definition location, etc.

36 -- locality, definition location, etc.

47− ,spaninfoDocs :: !SpanDoc

48− -- ^ Documentation for the element

49 }

37 }

50instance Show SpanInfo where

38instance Show SpanInfo where

51− show (SpanInfo sl sc el ec t n docs) =

39+ show (SpanInfo sl sc el ec t n) =

52 unwords ["(SpanInfo", show sl, show sc, show el, show ec

40 unwords ["(SpanInfo", show sl, show sc, show el, show ec

53− , show $ maybe "NoType" prettyPrint t, "(" <> show n <> "))"

41+ , show $ maybe "NoType" prettyPrint t, "(" <> show n <> "))"]

54− , "docs(" <> show docs <> ")"]

56instance NFData SpanInfo where

43instance NFData SpanInfo where

57 rnf = rwhnf

44 rnf = rwhnf

@@ -60,7 +47,6 @@ instance NFData SpanInfo where

60-- we don't always get a name out so sometimes manually annotating source is more appropriate

47-- we don't always get a name out so sometimes manually annotating source is more appropriate

61data SpanSource = Named Name

48data SpanSource = Named Name

62 | SpanS SrcSpan

49 | SpanS SrcSpan

63− | Lit String

64 | NoSource

50 | NoSource

65 deriving (Eq)

51 deriving (Eq)

@@ -68,10 +54,9 @@ instance Show SpanSource where

68 show = \case

54 show = \case

69 Named n -> "Named " ++ occNameString (occName n)

55 Named n -> "Named " ++ occNameString (occName n)

70 SpanS sp -> "Span " ++ show sp

56 SpanS sp -> "Span " ++ show sp

71− Lit lit -> "Lit " ++ lit

72 NoSource -> "NoSource"

57 NoSource -> "NoSource"

74getNameM :: SpanSource -> Maybe Name

59getNameM :: SpanSource -> Maybe Name

75getNameM = \case

60getNameM = \case

76 Named name -> Just name

61 Named name -> Just name

77− _ -> Nothing

62+ _ -> Nothing

src/Development/IDE/Types/Diagnostics.hs+5−19

@@ -6,12 +6,10 @@ module Development.IDE.Types.Diagnostics (

6 LSP.Diagnostic(..),

7 ShowDiagnostic(..),

8 FileDiagnostic,

9− IdeResult,

10 LSP.DiagnosticSeverity(..),

9 LSP.DiagnosticSeverity(..),

11 DiagnosticStore,

10 DiagnosticStore,

12 List(..),

11 List(..),

13 ideErrorText,

12 ideErrorText,

14− ideErrorWithSource,

15 showDiagnostics,

13 showDiagnostics,

16 showDiagnosticsColored,

14 showDiagnosticsColored,

17 ) where

15 ) where

@@ -20,7 +18,7 @@ import Control.DeepSeq

20import Data.Maybe as Maybe

18import Data.Maybe as Maybe

21import qualified Data.Text as T

19import qualified Data.Text as T

22import Data.Text.Prettyprint.Doc

20import Data.Text.Prettyprint.Doc

23−import Language.Haskell.LSP.Types as LSP (DiagnosticSource,

21+import Language.Haskell.LSP.Types as LSP (

24 DiagnosticSeverity(..)

22 DiagnosticSeverity(..)

25 , Diagnostic(..)

23 , Diagnostic(..)

26 , List(..)

24 , List(..)

@@ -32,27 +30,15 @@ import Data.Text.Prettyprint.Doc.Render.Terminal (Color(..), color)

33import Development.IDE.Types.Location

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

39ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic

34ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic

40−ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError)

41−

42−ideErrorWithSource

43− :: Maybe DiagnosticSource

44− -> Maybe DiagnosticSeverity

45− -> a

46− -> T.Text

47− -> (a, ShowDiagnostic, Diagnostic)

48−ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic {

35+ideErrorText fp msg = (fp, ShowDiag, LSP.Diagnostic {

49 _range = noRange,

36 _range = noRange,

50− _severity = sev,

37+ _severity = Just LSP.DsError,

51 _code = Nothing,

38 _code = Nothing,

52− _source = source,

39+ _source = Just "compiler",

53 _message = msg,

40 _message = msg,

54− _relatedInformation = Nothing,

41+ _relatedInformation = Nothing

55− _tags = Nothing

56 })

42 })

58-- | Defines whether a particular diagnostic should be reported

44-- | Defines whether a particular diagnostic should be reported

src/Development/IDE/Types/Location.hs+80−67

@@ -10,59 +10,108 @@ module Development.IDE.Types.Location

10 , Position(..)

11 , showPosition

12 , Range(..)

13− , LSP.Uri(..)

13+ , Uri(..)

14− , LSP.NormalizedUri

14+ , NormalizedUri

15 , LSP.toNormalizedUri

16 , LSP.fromNormalizedUri

17− , LSP.NormalizedFilePath

17+ , NormalizedFilePath

18 , fromUri

19− , emptyFilePath

20− , emptyPathUri

21− , toNormalizedFilePath'

19+ , toNormalizedFilePath

22− , LSP.fromNormalizedFilePath

20+ , fromNormalizedFilePath

21+ , filePathToUri

23 , filePathToUri'

22 , filePathToUri'

24 , uriToFilePath'

23 , uriToFilePath'

25− , readSrcSpan

26 ) where

24 ) where

28−import Control.Applicative

29import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..))

26import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..))

30−import Control.Monad

27+import Control.DeepSeq

31−import Data.Hashable (Hashable(hash))

28+import Data.Binary

29+import Data.Maybe as Maybe

30+import Data.Hashable

32import Data.String

31import Data.String

33−import FastString

32+import qualified Data.Text as T

33+import Network.URI

34+import System.FilePath

35+import qualified System.FilePath.Posix as FPP

36+import qualified System.FilePath.Windows as FPW

37+import System.Info.Extra

34import qualified Language.Haskell.LSP.Types as LSP

38import qualified Language.Haskell.LSP.Types as LSP

35−import SrcLoc as GHC

39+import Language.Haskell.LSP.Types as LSP (

36−import Text.ParserCombinators.ReadP as ReadP

40+ filePathToUri

37−import Data.Maybe (fromMaybe)

41+ , NormalizedUri(..)

42+ , Uri(..)

43+ , toNormalizedUri

44+ , fromNormalizedUri

45+ )

47+

48+-- | Newtype wrapper around FilePath that always has normalized slashes.

49+newtype NormalizedFilePath = NormalizedFilePath FilePath

50+ deriving (Eq, Ord, Show, Hashable, NFData, Binary)

51+

52+instance IsString NormalizedFilePath where

53+ fromString = toNormalizedFilePath

54+

39−toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath

55+toNormalizedFilePath :: FilePath -> NormalizedFilePath

40-- We want to keep empty paths instead of normalising them to "."

56-- We want to keep empty paths instead of normalising them to "."

41−toNormalizedFilePath' "" = emptyFilePath

57+toNormalizedFilePath "" = NormalizedFilePath ""

42−toNormalizedFilePath' fp = LSP.toNormalizedFilePath fp

58+toNormalizedFilePath fp = NormalizedFilePath $ normalise fp

44−emptyFilePath :: LSP.NormalizedFilePath

60+fromNormalizedFilePath :: NormalizedFilePath -> FilePath

45−emptyFilePath = LSP.NormalizedFilePath emptyPathUri ""

61+fromNormalizedFilePath (NormalizedFilePath fp) = fp

47-- | We use an empty string as a filepath when we don’t have a file.

63-- | We use an empty string as a filepath when we don’t have a file.

48-- However, haskell-lsp doesn’t support that in uriToFilePath and given

64-- However, haskell-lsp doesn’t support that in uriToFilePath and given

49-- that it is not a valid filepath it does not make sense to upstream a fix.

65-- that it is not a valid filepath it does not make sense to upstream a fix.

50-- So we have our own wrapper here that supports empty filepaths.

66-- So we have our own wrapper here that supports empty filepaths.

51−uriToFilePath' :: LSP.Uri -> Maybe FilePath

67+uriToFilePath' :: Uri -> Maybe FilePath

52uriToFilePath' uri

68uriToFilePath' uri

53− | uri == LSP.fromNormalizedUri emptyPathUri = Just ""

69+ | uri == fromNormalizedUri emptyPathUri = Just ""

54 | otherwise = LSP.uriToFilePath uri

70 | otherwise = LSP.uriToFilePath uri

56−emptyPathUri :: LSP.NormalizedUri

72+emptyPathUri :: NormalizedUri

57−emptyPathUri =

73+emptyPathUri = filePathToUri' ""

58− let s = "file://"

59− in LSP.NormalizedUri (hash s) s

61−filePathToUri' :: LSP.NormalizedFilePath -> LSP.NormalizedUri

75+filePathToUri' :: NormalizedFilePath -> NormalizedUri

62−filePathToUri' = LSP.normalizedFilePathToUri

76+filePathToUri' (NormalizedFilePath fp) = toNormalizedUri $ Uri $ T.pack $ LSP.fileScheme <> "//" <> platformAdjustToUriPath fp

77+ where

78+ -- The definitions below are variants of the corresponding functions in Language.Haskell.LSP.Types.Uri that assume that

79+ -- the filepath has already been normalised. This is necessary since normalising the filepath has a nontrivial cost.

80+

81+ toNormalizedUri :: Uri -> NormalizedUri

82+ toNormalizedUri (Uri t) =

83+ NormalizedUri $ T.pack $ escapeURIString isUnescapedInURI $ unEscapeString $ T.unpack t

84+

85+ platformAdjustToUriPath :: FilePath -> String

86+ platformAdjustToUriPath srcPath

87+ | isWindows = '/' : escapedPath

88+ | otherwise = escapedPath

89+ where

90+ (splitDirectories, splitDrive)

91+ | isWindows =

92+ (FPW.splitDirectories, FPW.splitDrive)

93+ | otherwise =

94+ (FPP.splitDirectories, FPP.splitDrive)

95+ escapedPath =

96+ case splitDrive srcPath of

97+ (drv, rest) ->

98+ convertDrive drv `FPP.joinDrive`

99+ FPP.joinPath (map (escapeURIString unescaped) $ splitDirectories rest)

100+ -- splitDirectories does not remove the path separator after the drive so

101+ -- we do a final replacement of \ to /

102+ convertDrive drv

103+ | isWindows && FPW.hasTrailingPathSeparator drv =

104+ FPP.addTrailingPathSeparator (init drv)

105+ | otherwise = drv

106+ unescaped c

107+ | isWindows = isUnreserved c || c `elem` [':', '\\', '/']

108+ | otherwise = isUnreserved c || c == '/'

109+

110+

111+

112+fromUri :: LSP.NormalizedUri -> NormalizedFilePath

113+fromUri = toNormalizedFilePath . fromMaybe noFilePath . uriToFilePath' . fromNormalizedUri

114

64−fromUri :: LSP.NormalizedUri -> LSP.NormalizedFilePath

65−fromUri = fromMaybe (toNormalizedFilePath' noFilePath) . LSP.uriToNormalizedFilePath

115

67noFilePath :: FilePath

116noFilePath :: FilePath

68noFilePath = "<unknown>"

117noFilePath = "<unknown>"

@@ -71,42 +120,6 @@ noFilePath = "<unknown>"

71noRange :: Range

120noRange :: Range

72noRange = Range (Position 0 0) (Position 100000 0)

121noRange = Range (Position 0 0) (Position 100000 0)

122

123+

74showPosition :: Position -> String

124showPosition :: Position -> String

75showPosition Position{..} = show (_line + 1) ++ ":" ++ show (_character + 1)

125showPosition Position{..} = show (_line + 1) ++ ":" ++ show (_character + 1)

76−

77−-- | Parser for the GHC output format

78−readSrcSpan :: ReadS SrcSpan

79−readSrcSpan = readP_to_S (singleLineSrcSpanP <|> multiLineSrcSpanP)

80− where

81− singleLineSrcSpanP, multiLineSrcSpanP :: ReadP SrcSpan

82− singleLineSrcSpanP = do

83− fp <- filePathP

84− l <- readS_to_P reads <* char ':'

85− c0 <- readS_to_P reads

86− c1 <- (char '-' *> readS_to_P reads) <|> pure c0

87− let from = mkSrcLoc fp l c0

88− to = mkSrcLoc fp l c1

89− return $ mkSrcSpan from to

90−

91− multiLineSrcSpanP = do

92− fp <- filePathP

93− s <- parensP (srcLocP fp)

94− void $ char '-'

95− e <- parensP (srcLocP fp)

96− return $ mkSrcSpan s e

97−

98− parensP :: ReadP a -> ReadP a

99− parensP = between (char '(') (char ')')

100−

101− filePathP :: ReadP FastString

102− filePathP = fromString <$> (readFilePath <* char ':') <|> pure ""

103−

104− srcLocP :: FastString -> ReadP SrcLoc

105− srcLocP fp = do

106− l <- readS_to_P reads

107− void $ char ','

108− c <- readS_to_P reads

109− return $ mkSrcLoc fp l c

110−

111− readFilePath :: ReadP FilePath

112− readFilePath = some ReadP.get

src/Development/IDE/Types/Options.hs+8−35

@@ -12,25 +12,25 @@ module Development.IDE.Types.Options

12 , clientSupportsProgress

13 , IdePkgLocationOptions(..)

14 , defaultIdeOptions

15− , IdeResult

16 ) where

15 ) where

17+import Data.Maybe

18import Development.Shake

19import Development.IDE.GHC.Util

20import GHC hiding (parseModule, typecheckModule)

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

22import qualified Language.Haskell.LSP.Types.Capabilities as LSP

23−import qualified Data.Text as T

24−import Development.IDE.Types.Diagnostics

26data IdeOptions = IdeOptions

24data IdeOptions = IdeOptions

27 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource

25 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource

28 -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings

26 -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings

29 -- and a list of errors, along with a new parse tree.

27 -- and a list of errors, along with a new parse tree.

30− , optGhcSession :: Action (FilePath -> Action (IdeResult HscEnvEq))

28+ , optGhcSession :: IO (FilePath -> Action HscEnvEq)

31 -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.

29 -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.

32− -- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.

30+ -- The 'IO' will be called once, then the resulting function will be applied once per file.

33 -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.

31 -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.

32+ -- You should not use 'newCacheIO' to get that caching, because of

33+ -- https://github.com/ndmitchell/shake/issues/725.

34 , optPkgLocationOpts :: IdePkgLocationOptions

35 -- ^ How to locate source and @.hie@ files given a module name.

36 , optExtensions :: [String]

@@ -43,17 +43,12 @@ data IdeOptions = IdeOptions

43 -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds.

44 , optShakeProfiling :: Maybe FilePath

45 -- ^ Set to 'Just' to create a directory of profiling reports.

46− , optTesting :: Bool

47− -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants

48 , optReportProgress :: IdeReportProgress

46 , optReportProgress :: IdeReportProgress

49 -- ^ Whether to report progress during long operations.

47 -- ^ Whether to report progress during long operations.

50 , optLanguageSyntax :: String

48 , optLanguageSyntax :: String

51 -- ^ the ```language to use

49 -- ^ the ```language to use

52 , optNewColonConvention :: Bool

50 , optNewColonConvention :: Bool

53 -- ^ whether to use new colon convention

51 -- ^ whether to use new colon convention

54− , optKeywords :: [T.Text]

55− -- ^ keywords used for completions. These are customizable

56− -- since DAML has a different set of keywords than Haskell.

57 , optDefer :: IdeDefer

52 , optDefer :: IdeDefer

58 -- ^ Whether to defer type errors, typed holes and out of scope

53 -- ^ Whether to defer type errors, typed holes and out of scope

59 -- variables. Deferral allows the IDE to continue to provide

54 -- variables. Deferral allows the IDE to continue to provide

@@ -75,10 +70,10 @@ newtype IdeReportProgress = IdeReportProgress Bool

75newtype IdeDefer = IdeDefer Bool

70newtype IdeDefer = IdeDefer Bool

77clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress

72clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress

78−clientSupportsProgress caps = IdeReportProgress $ Just True ==

73+clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $

79− (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))

74+ LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)

81−defaultIdeOptions :: Action (FilePath -> Action (IdeResult HscEnvEq)) -> IdeOptions

76+defaultIdeOptions :: IO (FilePath -> Action HscEnvEq) -> IdeOptions

82defaultIdeOptions session = IdeOptions

77defaultIdeOptions session = IdeOptions

83 {optPreprocessor = IdePreprocessedSource [] []

78 {optPreprocessor = IdePreprocessedSource [] []

84 ,optGhcSession = session

79 ,optGhcSession = session

@@ -90,9 +85,7 @@ defaultIdeOptions session = IdeOptions

90 ,optReportProgress = IdeReportProgress False

85 ,optReportProgress = IdeReportProgress False

91 ,optLanguageSyntax = "haskell"

86 ,optLanguageSyntax = "haskell"

92 ,optNewColonConvention = False

87 ,optNewColonConvention = False

93− ,optKeywords = haskellKeywords

94 ,optDefer = IdeDefer True

88 ,optDefer = IdeDefer True

95− ,optTesting = False

96 }

89 }

@@ -110,23 +103,3 @@ data IdePkgLocationOptions = IdePkgLocationOptions

110defaultIdePkgLocationOptions :: IdePkgLocationOptions

103defaultIdePkgLocationOptions :: IdePkgLocationOptions

111defaultIdePkgLocationOptions = IdePkgLocationOptions f f

104defaultIdePkgLocationOptions = IdePkgLocationOptions f f

112 where f _ _ = return Nothing

105 where f _ _ = return Nothing

113−

114−-- | From https://wiki.haskell.org/Keywords

115−haskellKeywords :: [T.Text]

116−haskellKeywords =

117− [ "as"

118− , "case", "of"

119− , "class", "instance", "type"

120− , "data", "family", "newtype"

121− , "default"

122− , "deriving"

123− , "do", "mdo", "proc", "rec"

124− , "forall"

125− , "foreign"

126− , "hiding"

127− , "if", "then", "else"

128− , "import", "qualified", "hiding"

129− , "infix", "infixl", "infixr"

130− , "let", "in", "where"

131− , "module"

132− ]

stack-ghc-lib.yaml+4−7

@@ -2,18 +2,15 @@ resolver: nightly-2019-09-16

2packages:

3- .

4extra-deps:

5−- haskell-lsp-0.22.0.0

5+- haskell-lsp-0.19.0.0

6−- haskell-lsp-types-0.22.0.0

6+- haskell-lsp-types-0.19.0.0

7−- lsp-test-0.10.3.0

7+- lsp-test-0.10.0.0

8−- hie-bios-0.5.0

8+- hie-bios-0.3.2

9- ghc-lib-parser-8.8.1

10- ghc-lib-8.8.1

11- fuzzy-0.1.0.0

12−- shake-0.18.5

13- regex-base-0.94.0.0

12- regex-base-0.94.0.0

14- regex-tdfa-1.3.1.0

13- regex-tdfa-1.3.1.0

15−- haddock-library-1.8.0

16−- ghc-check-0.3.0.1

17nix:

14nix:

18 packages: [zlib]

15 packages: [zlib]

19flags:

16flags:

stack.yaml+4−9

@@ -2,18 +2,13 @@ resolver: nightly-2019-09-21

2packages:

3- .

4extra-deps:

5−- haskell-lsp-0.22.0.0

5+- haskell-lsp-0.19.0.0

6−- haskell-lsp-types-0.22.0.0

6+- haskell-lsp-types-0.19.0.0

7−- lsp-test-0.11.0.1

7+- lsp-test-0.10.0.0

8−- hie-bios-0.5.0

8+- hie-bios-0.3.2

9- fuzzy-0.1.0.0

10−- regex-pcre-builtin-0.95.1.1.8.43

11- regex-base-0.94.0.0

10- regex-base-0.94.0.0

12- regex-tdfa-1.3.1.0

11- regex-tdfa-1.3.1.0

13−- shake-0.18.5

14- parser-combinators-1.2.1

12- parser-combinators-1.2.1

15−- haddock-library-1.8.0

16−- tasty-rerun-1.1.17

17−- ghc-check-0.3.0.1

18nix:

13nix:

19 packages: [zlib]

14 packages: [zlib]

stack810.yamldeleted−18

@@ -1,18 +0,0 @@

1−resolver: nightly-2020-02-13

2−compiler: ghc-8.10.1

3−allow-newer: true

4−packages:

5−- .

6−extra-deps:

7−- haskell-lsp-0.22.0.0

8−- haskell-lsp-types-0.22.0.0

9−- lsp-test-0.11.0.1

10−- ghc-check-0.3.0.1

11−- hie-bios-0.5.0

12−

13−# for ghc-8.10

14−- Cabal-3.2.0.0

15−- lens-4.19.1

16−

17−nix:

18− packages: [zlib]

stack84.yaml+6−19

@@ -3,31 +3,18 @@ packages:

3- .

5extra-deps:

6−- aeson-1.4.6.0

7−- base-orphans-0.8.2

8−- haskell-lsp-0.22.0.0

6+- haskell-lsp-0.19.0.0

9−- haskell-lsp-types-0.22.0.0

7+- haskell-lsp-types-0.19.0.0

10−- lsp-test-0.11.0.1

8+- lsp-test-0.10.0.0

11- rope-utf16-splay-0.3.1.0

9- rope-utf16-splay-0.3.1.0

10+- shake-0.18.3

12- filepattern-0.1.1

11- filepattern-0.1.1

13- js-dgtable-0.5.2

12- js-dgtable-0.5.2

14−- hie-bios-0.5.0

13+- hie-bios-0.3.2

15- fuzzy-0.1.0.0

14- fuzzy-0.1.0.0

16−- shake-0.18.5

17−- time-compat-1.9.2.2

18- regex-base-0.94.0.0

15- regex-base-0.94.0.0

19- regex-tdfa-1.3.1.0

16- regex-tdfa-1.3.1.0

20- parser-combinators-1.2.1

17- parser-combinators-1.2.1

21−- haddock-library-1.8.0

22−- unordered-containers-0.2.10.0

23−- file-embed-0.0.11.2

24−- heaps-0.3.6.1

25−- ghc-check-0.3.0.1

26−# For tasty-retun

27−- ansi-terminal-0.10.3

28−- ansi-wl-pprint-0.6.9

29−- tasty-1.2.3

30−- tasty-rerun-1.1.17

31−

32nix:

18nix:

33 packages: [zlib]

19 packages: [zlib]

20+allow-newer: true

stack88.yaml+4−6

@@ -1,11 +1,9 @@

1−resolver: nightly-2020-02-13

1+resolver: nightly-2020-01-03

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

5+- hie-bios-0.3.2

6+- fuzzy-0.1.0.0

7+allow-newer: true

10nix:

8nix:

11 packages: [zlib]

9 packages: [zlib]

test/data/hover/GotoHover.hs → test/data/GotoHover.hsrenamed+1−14

@@ -1,10 +1,6 @@

1−{-# LANGUAGE OverloadedStrings #-}

2{- HLINT ignore -}

1{- HLINT ignore -}

3module Testing ( module Testing ) where

2module Testing ( module Testing ) where

4import Data.Text (Text, pack)

3import Data.Text (Text, pack)

5−import Foo (Bar, foo)

6−

7−

8data TypeConstructor = DataConstructor

4data TypeConstructor = DataConstructor

9 { fff :: Text

5 { fff :: Text

10 , ggg :: Int }

6 , ggg :: Int }

@@ -38,7 +34,7 @@ listCompBind :: [Char]

38listCompBind = [ succ c | c <- "ptfx" ]

34listCompBind = [ succ c | c <- "ptfx" ]

40multipleClause :: Bool -> Char

36multipleClause :: Bool -> Char

41−multipleClause True = 't'

37+multipleClause True = 't'

42multipleClause False = 'f'

38multipleClause False = 'f'

44-- | Recognizable docs: kpqz

40-- | Recognizable docs: kpqz

@@ -46,12 +42,3 @@ documented :: Monad m => Either Int (m a)

46documented = Left 7518

42documented = Left 7518

48listOfInt = [ 8391 :: Int, 6268 ]

44listOfInt = [ 8391 :: Int, 6268 ]

49−

50−outer :: Bool

51−outer = undefined where

52−

53− inner :: Char

54− inner = undefined

55−

56−imported :: Bar

57−imported = foo

test/data/hover/Bar.hsdeleted−3

@@ -1,3 +0,0 @@

1−module Bar (Bar(..)) where

2−

3−data Bar = Bar

test/data/hover/Foo.hsdeleted−5

@@ -1,5 +0,0 @@

1−module Foo (Bar, foo) where

2−

3−import Bar

4−

5−foo = Bar

test/data/multi/a/A.hsdeleted−3

@@ -1,3 +0,0 @@

1−module A(foo) where

2−

3−foo = ()

test/data/multi/a/a.cabaldeleted−9

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

1−name: a

2−version: 1.0.0

3−build-type: Simple

4−cabal-version: >= 1.2

5−

6−library

7− build-depends: base

8− exposed-modules: A

9− hs-source-dirs: .

test/data/multi/b/B.hsdeleted−3

@@ -1,3 +0,0 @@

1−module B(module B) where

2−import A

3−qux = foo

test/data/multi/b/b.cabaldeleted−9

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

1−name: b

2−version: 1.0.0

3−build-type: Simple

4−cabal-version: >= 1.2

5−

6−library

7− build-depends: base, a

8− exposed-modules: B

9− hs-source-dirs: .

test/data/multi/cabal.projectdeleted−1

@@ -1 +0,0 @@

1−packages: a b

test/data/multi/hie.yamldeleted−6

@@ -1,6 +0,0 @@

1−cradle:

2− cabal:

3− - path: "./a"

4− component: "lib:a"

5− - path: "./b"

6− component: "lib:b"

test/exe/Main.hs+261−1440

@@ -1,7 +1,6 @@

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

4−{-# LANGUAGE AllowAmbiguousTypes #-}

5{-# LANGUAGE DuplicateRecordFields #-}

4{-# LANGUAGE DuplicateRecordFields #-}

6{-# LANGUAGE PatternSynonyms #-}

5{-# LANGUAGE PatternSynonyms #-}

7{-# LANGUAGE CPP #-}

6{-# LANGUAGE CPP #-}

@@ -10,74 +9,48 @@

10module Main (main) where

9module Main (main) where

12import Control.Applicative.Combinators

11import Control.Applicative.Combinators

13−import Control.Exception (bracket, catch)

14−import qualified Control.Lens as Lens

15import Control.Monad

12import Control.Monad

16import Control.Monad.IO.Class (liftIO)

13import Control.Monad.IO.Class (liftIO)

17−import Data.Aeson (FromJSON, Value)

14+import qualified Data.Aeson as Aeson

15+import Data.Char (toLower)

18import Data.Foldable

16import Data.Foldable

19−import Data.List.Extra

20−import Data.Rope.UTF16 (Rope)

21−import qualified Data.Rope.UTF16 as Rope

22−import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)

23import Development.IDE.GHC.Util

17import Development.IDE.GHC.Util

24import qualified Data.Text as T

18import qualified Data.Text as T

25−import Data.Typeable

26−import Development.IDE.Spans.Common

27import Development.IDE.Test

19import Development.IDE.Test

28import Development.IDE.Test.Runfiles

20import Development.IDE.Test.Runfiles

29import Development.IDE.Types.Location

21import Development.IDE.Types.Location

30−import Development.Shake (getDirectoryFilesIO)

31import Language.Haskell.LSP.Test

22import Language.Haskell.LSP.Test

32−import Language.Haskell.LSP.Messages

33import Language.Haskell.LSP.Types

23import Language.Haskell.LSP.Types

34import Language.Haskell.LSP.Types.Capabilities

24import Language.Haskell.LSP.Types.Capabilities

35−import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)

36−import Language.Haskell.LSP.VFS (applyChange)

37−import Network.URI

38−import System.Environment.Blank (getEnv, setEnv, unsetEnv)

25+import System.Environment.Blank (setEnv)

39import System.FilePath

26import System.FilePath

40import System.IO.Extra

27import System.IO.Extra

41import System.Directory

28import System.Directory

42−import Test.QuickCheck

43−import Test.QuickCheck.Instances ()

44import Test.Tasty

29import Test.Tasty

45−import Test.Tasty.ExpectedFailure

46−import Test.Tasty.Ingredients.Rerun

47import Test.Tasty.HUnit

30import Test.Tasty.HUnit

48−import Test.Tasty.QuickCheck

31+import Test.Tasty.ExpectedFailure

49import Data.Maybe

32import Data.Maybe

51main :: IO ()

34main :: IO ()

52−main = do

53− -- We mess with env vars so run single-threaded.

54− setEnv "TASTY_NUM_THREADS" "1" True

55− defaultMainWithRerun $ testGroup "HIE"

35+main = defaultMain $ testGroup "HIE"

56− [ testSession "open close" $ do

36+ [ testSession "open close" $ do

57− doc <- createDoc "Testing.hs" "haskell" ""

37+ doc <- openDoc' "Testing.hs" "haskell" ""

58− void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)

38+ void (message :: Session WorkDoneProgressCreateRequest)

59− void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)

39+ void (message :: Session WorkDoneProgressBeginNotification)

60− closeDoc doc

40+ closeDoc doc

61− void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)

41+ void (message :: Session WorkDoneProgressEndNotification)

62− , initializeResponseTests

42+ , initializeResponseTests

63− , completionTests

43+ , completionTests

64− , cppTests

65− , diagnosticTests

44+ , diagnosticTests

66− , codeActionTests

45+ , codeActionTests

67− , codeLensesTests

46+ , codeLensesTests

68− , outlineTests

47+ , outlineTests

69− , findDefinitionAndHoverTests

48+ , findDefinitionAndHoverTests

70− , pluginTests

49+ , pluginTests

71− , preprocessorTests

50+ , preprocessorTests

72− , thTests

51+ , thTests

73− , safeTests

74− , unitTests

52+ , unitTests

75− , haddockTests

76− , positionMappingTests

77− , watchedFilesTests

78− , cradleTests

79− , dependentFileTest

80− ]

53+ ]

82initializeResponseTests :: TestTree

55initializeResponseTests :: TestTree

83initializeResponseTests = withResource acquire release tests where

56initializeResponseTests = withResource acquire release tests where

@@ -92,7 +65,7 @@ initializeResponseTests = withResource acquire release tests where

92 testGroup "initialize response capabilities"

65 testGroup "initialize response capabilities"

93 [ chk " text doc sync" _textDocumentSync tds

66 [ chk " text doc sync" _textDocumentSync tds

94 , chk " hover" _hoverProvider (Just True)

67 , chk " hover" _hoverProvider (Just True)

95− , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing)

68+ , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) Nothing Nothing)

96 , chk "NO signature help" _signatureHelpProvider Nothing

69 , chk "NO signature help" _signatureHelpProvider Nothing

97 , chk " goto definition" _definitionProvider (Just True)

70 , chk " goto definition" _definitionProvider (Just True)

98 , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)

71 , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)

@@ -112,8 +85,8 @@ initializeResponseTests = withResource acquire release tests where

112 , chk "NO doc link" _documentLinkProvider Nothing

85 , chk "NO doc link" _documentLinkProvider Nothing

113 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)

86 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)

114 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)

87 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)

115− , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

88+ , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

116− , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))

89+ , chk "NO workspace" _workspace nothingWorkspace

117 , chk "NO experimental" _experimental Nothing

90 , chk "NO experimental" _experimental Nothing

118 ] where

91 ] where

119

@@ -124,21 +97,14 @@ initializeResponseTests = withResource acquire release tests where

124 , _willSaveWaitUntil = Nothing

97 , _willSaveWaitUntil = Nothing

125 , _save = Just (SaveOptions {_includeText = Nothing})}))

98 , _save = Just (SaveOptions {_includeText = Nothing})}))

126

100+ nothingWorkspace = Just (WorkspaceOptions {_workspaceFolders = Nothing})

101+

127 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree

102 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree

128 chk title getActual expected =

103 chk title getActual expected =

129 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir

104 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir

130

105

131− che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> Maybe ExecuteCommandOptions -> TestTree

132− che title getActual _expected = testCase title doTest

133− where

134− doTest = do

135− ir <- getInitializeResponse

136− let Just ExecuteCommandOptions {_commands = List [command]} = getActual $ innerCaps ir

137− True @=? T.isSuffixOf "typesignature.add" command

138−

139−

140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner

106 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner

141− innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c

107+ innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c

142 innerCaps _ = error "this test only expects inner capabilities"

108 innerCaps _ = error "this test only expects inner capabilities"

143

109

144 acquire :: IO InitializeResponse

110 acquire :: IO InitializeResponse

@@ -152,7 +118,7 @@ diagnosticTests :: TestTree

152diagnosticTests = testGroup "diagnostics"

118diagnosticTests = testGroup "diagnostics"

153 [ testSessionWait "fix syntax error" $ do

119 [ testSessionWait "fix syntax error" $ do

154 let content = T.unlines [ "module Testing wher" ]

120 let content = T.unlines [ "module Testing wher" ]

155− doc <- createDoc "Testing.hs" "haskell" content

121+ doc <- openDoc' "Testing.hs" "haskell" content

156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]

122 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]

157 let change = TextDocumentContentChangeEvent

123 let change = TextDocumentContentChangeEvent

158 { _range = Just (Range (Position 0 15) (Position 0 19))

124 { _range = Just (Range (Position 0 15) (Position 0 19))

@@ -163,9 +129,9 @@ diagnosticTests = testGroup "diagnostics"

163 expectDiagnostics [("Testing.hs", [])]

129 expectDiagnostics [("Testing.hs", [])]

164 , testSessionWait "introduce syntax error" $ do

130 , testSessionWait "introduce syntax error" $ do

165 let content = T.unlines [ "module Testing where" ]

131 let content = T.unlines [ "module Testing where" ]

166− doc <- createDoc "Testing.hs" "haskell" content

132+ doc <- openDoc' "Testing.hs" "haskell" content

167− void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)

133+ void (message :: Session WorkDoneProgressCreateRequest)

168− void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)

134+ void (message :: Session WorkDoneProgressBeginNotification)

169 let change = TextDocumentContentChangeEvent

135 let change = TextDocumentContentChangeEvent

170 { _range = Just (Range (Position 0 15) (Position 0 18))

136 { _range = Just (Range (Position 0 15) (Position 0 18))

171 , _rangeLength = Nothing

137 , _rangeLength = Nothing

@@ -181,7 +147,7 @@ diagnosticTests = testGroup "diagnostics"

181 , "bar :: Int -> Int -> Int"

147 , "bar :: Int -> Int -> Int"

182 , "bar a b = cd + b"

148 , "bar a b = cd + b"

183 ]

149 ]

184− _ <- createDoc "Testing.hs" "haskell" content

150+ _ <- openDoc' "Testing.hs" "haskell" content

185 expectDiagnostics

151 expectDiagnostics

186 [ ( "Testing.hs"

152 [ ( "Testing.hs"

187 , [ (DsError, (2, 14), "Variable not in scope: ab")

153 , [ (DsError, (2, 14), "Variable not in scope: ab")

@@ -195,7 +161,7 @@ diagnosticTests = testGroup "diagnostics"

195 , "foo :: Int -> String -> Int"

161 , "foo :: Int -> String -> Int"

196 , "foo a b = a + b"

162 , "foo a b = a + b"

197 ]

163 ]

198− _ <- createDoc "Testing.hs" "haskell" content

164+ _ <- openDoc' "Testing.hs" "haskell" content

199 expectDiagnostics

165 expectDiagnostics

200 [ ( "Testing.hs"

166 [ ( "Testing.hs"

201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]

167 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]

@@ -207,7 +173,7 @@ diagnosticTests = testGroup "diagnostics"

207 , "foo :: Int -> String"

173 , "foo :: Int -> String"

208 , "foo a = _ a"

174 , "foo a = _ a"

209 ]

175 ]

210− _ <- createDoc "Testing.hs" "haskell" content

176+ _ <- openDoc' "Testing.hs" "haskell" content

211 expectDiagnostics

177 expectDiagnostics

212 [ ( "Testing.hs"

178 [ ( "Testing.hs"

213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]

179 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]

@@ -229,23 +195,24 @@ diagnosticTests = testGroup "diagnostics"

229 [ ("A.hs", [(DsError, (2,4), aMessage)])

195 [ ("A.hs", [(DsError, (2,4), aMessage)])

230 , ("B.hs", [(DsError, (3,4), bMessage)])]

196 , ("B.hs", [(DsError, (3,4), bMessage)])]

231 deferralTest title binding msg = testSessionWait title $ do

197 deferralTest title binding msg = testSessionWait title $ do

232− _ <- createDoc "A.hs" "haskell" $ sourceA binding

198+ _ <- openDoc' "A.hs" "haskell" $ sourceA binding

233− _ <- createDoc "B.hs" "haskell" sourceB

199+ _ <- openDoc' "B.hs" "haskell" sourceB

234 expectDiagnostics $ expectedDs msg

200 expectDiagnostics $ expectedDs msg

235 in

201 in

236 [ deferralTest "type error" "True" "Couldn't match expected type"

202 [ deferralTest "type error" "True" "Couldn't match expected type"

237 , deferralTest "typed hole" "_" "Found hole"

203 , deferralTest "typed hole" "_" "Found hole"

238 , deferralTest "out of scope var" "unbound" "Variable not in scope"

204 , deferralTest "out of scope var" "unbound" "Variable not in scope"

205+ , deferralTest "message shows error" "True" "A.hs:3:5: error:"

239 ]

206 ]

240

207

241 , testSessionWait "remove required module" $ do

208 , testSessionWait "remove required module" $ do

242 let contentA = T.unlines [ "module ModuleA where" ]

209 let contentA = T.unlines [ "module ModuleA where" ]

243− docA <- createDoc "ModuleA.hs" "haskell" contentA

210+ docA <- openDoc' "ModuleA.hs" "haskell" contentA

244 let contentB = T.unlines

211 let contentB = T.unlines

245 [ "module ModuleB where"

212 [ "module ModuleB where"

246 , "import ModuleA"

213 , "import ModuleA"

247 ]

214 ]

248− _ <- createDoc "ModuleB.hs" "haskell" contentB

215+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

249 let change = TextDocumentContentChangeEvent

216 let change = TextDocumentContentChangeEvent

250 { _range = Just (Range (Position 0 0) (Position 0 20))

217 { _range = Just (Range (Position 0 0) (Position 0 20))

251 , _rangeLength = Nothing

218 , _rangeLength = Nothing

@@ -258,21 +225,11 @@ diagnosticTests = testGroup "diagnostics"

258 [ "module ModuleB where"

225 [ "module ModuleB where"

259 , "import ModuleA"

226 , "import ModuleA"

260 ]

227 ]

261− _ <- createDoc "ModuleB.hs" "haskell" contentB

228+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

229 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

263 let contentA = T.unlines [ "module ModuleA where" ]

230 let contentA = T.unlines [ "module ModuleA where" ]

264− _ <- createDoc "ModuleA.hs" "haskell" contentA

231+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

265 expectDiagnostics [("ModuleB.hs", [])]

232 expectDiagnostics [("ModuleB.hs", [])]

266− , testSessionWait "add missing module (non workspace)" $ do

267− let contentB = T.unlines

268− [ "module ModuleB where"

269− , "import ModuleA"

270− ]

271− _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB

272− expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

273− let contentA = T.unlines [ "module ModuleA where" ]

274− _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA

275− expectDiagnostics [("/tmp/ModuleB.hs", [])]

276 , testSessionWait "cyclic module dependency" $ do

233 , testSessionWait "cyclic module dependency" $ do

277 let contentA = T.unlines

234 let contentA = T.unlines

278 [ "module ModuleA where"

235 [ "module ModuleA where"

@@ -282,8 +239,8 @@ diagnosticTests = testGroup "diagnostics"

282 [ "module ModuleB where"

239 [ "module ModuleB where"

283 , "import ModuleA"

240 , "import ModuleA"

284 ]

241 ]

285− _ <- createDoc "ModuleA.hs" "haskell" contentA

242+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

286− _ <- createDoc "ModuleB.hs" "haskell" contentB

243+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

287 expectDiagnostics

244 expectDiagnostics

288 [ ( "ModuleA.hs"

245 [ ( "ModuleA.hs"

289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]

246 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]

@@ -304,9 +261,9 @@ diagnosticTests = testGroup "diagnostics"

304 let contentBboot = T.unlines

261 let contentBboot = T.unlines

305 [ "module ModuleB where"

262 [ "module ModuleB where"

306 ]

263 ]

307− _ <- createDoc "ModuleA.hs" "haskell" contentA

264+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

308− _ <- createDoc "ModuleB.hs" "haskell" contentB

265+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

309− _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot

266+ _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot

310 expectDiagnostics []

267 expectDiagnostics []

311 , testSessionWait "correct reference used with hs-boot" $ do

268 , testSessionWait "correct reference used with hs-boot" $ do

312 let contentB = T.unlines

269 let contentB = T.unlines

@@ -328,10 +285,10 @@ diagnosticTests = testGroup "diagnostics"

328 -- resolved to the hs-boot file

285 -- resolved to the hs-boot file

329 , "y = x"

286 , "y = x"

330 ]

287 ]

331− _ <- createDoc "ModuleB.hs" "haskell" contentB

288+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

332− _ <- createDoc "ModuleA.hs" "haskell" contentA

289+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

333− _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot

290+ _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot

334− _ <- createDoc "ModuleC.hs" "haskell" contentC

291+ _ <- openDoc' "ModuleC.hs" "haskell" contentC

335 expectDiagnostics []

292 expectDiagnostics []

336 , testSessionWait "redundant import" $ do

293 , testSessionWait "redundant import" $ do

337 let contentA = T.unlines ["module ModuleA where"]

294 let contentA = T.unlines ["module ModuleA where"]

@@ -340,8 +297,8 @@ diagnosticTests = testGroup "diagnostics"

340 , "module ModuleB where"

297 , "module ModuleB where"

341 , "import ModuleA"

298 , "import ModuleA"

342 ]

299 ]

343− _ <- createDoc "ModuleA.hs" "haskell" contentA

300+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

344− _ <- createDoc "ModuleB.hs" "haskell" contentB

301+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

345 expectDiagnostics

302 expectDiagnostics

346 [ ( "ModuleB.hs"

303 [ ( "ModuleB.hs"

347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]

304 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]

@@ -363,8 +320,8 @@ diagnosticTests = testGroup "diagnostics"

363 , "wrong1 = ThisList.map"

320 , "wrong1 = ThisList.map"

364 , "wrong2 = BaseList.x"

321 , "wrong2 = BaseList.x"

365 ]

322 ]

366− _ <- createDoc "Data/List.hs" "haskell" thisDataListContent

323+ _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent

367− _ <- createDoc "Main.hs" "haskell" mainContent

324+ _ <- openDoc' "Main.hs" "haskell" mainContent

368 expectDiagnostics

325 expectDiagnostics

369 [ ( "Main.hs"

326 [ ( "Main.hs"

370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")

327 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")

@@ -379,7 +336,7 @@ diagnosticTests = testGroup "diagnostics"

379 , "foo :: Ord a => a -> Int"

336 , "foo :: Ord a => a -> Int"

380 , "foo a = 1"

337 , "foo a = 1"

381 ]

338 ]

382− _ <- createDoc "Foo.hs" "haskell" fooContent

339+ _ <- openDoc' "Foo.hs" "haskell" fooContent

383 expectDiagnostics

340 expectDiagnostics

384 [ ( "Foo.hs"

341 [ ( "Foo.hs"

385 -- The test is to make sure that warnings contain unqualified names

342 -- The test is to make sure that warnings contain unqualified names

@@ -404,18 +361,18 @@ diagnosticTests = testGroup "diagnostics"

404 Just pathB <- pure $ uriToFilePath uriB

361 Just pathB <- pure $ uriToFilePath uriB

405 uriB <- pure $

362 uriB <- pure $

406 let (drive, suffix) = splitDrive pathB

363 let (drive, suffix) = splitDrive pathB

407− in filePathToUri (joinDrive (lower drive) suffix)

364+ in filePathToUri (joinDrive (map toLower drive ) suffix)

408 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)

365 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)

409 liftIO $ writeFileUTF8 pathB $ T.unpack bContent

366 liftIO $ writeFileUTF8 pathB $ T.unpack bContent

410 uriA <- getDocUri "A/A.hs"

367 uriA <- getDocUri "A/A.hs"

411 Just pathA <- pure $ uriToFilePath uriA

368 Just pathA <- pure $ uriToFilePath uriA

412 uriA <- pure $

369 uriA <- pure $

413 let (drive, suffix) = splitDrive pathA

370 let (drive, suffix) = splitDrive pathA

414− in filePathToUri (joinDrive (lower drive) suffix)

371+ in filePathToUri (joinDrive (map toLower drive ) suffix)

415 let itemA = TextDocumentItem uriA "haskell" 0 aContent

372 let itemA = TextDocumentItem uriA "haskell" 0 aContent

416 let a = TextDocumentIdentifier uriA

373 let a = TextDocumentIdentifier uriA

417 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)

374 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)

418− diagsNot <- skipManyTill anyMessage diagnostic

375+ diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification

419 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)

376 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)

420 -- Check that if we put a lower-case drive in for A.A

377 -- Check that if we put a lower-case drive in for A.A

421 -- the diagnostics for A.B will also be lower-case.

378 -- the diagnostics for A.B will also be lower-case.

@@ -424,38 +381,6 @@ diagnosticTests = testGroup "diagnostics"

424 liftIO $ unless ("redundant" `T.isInfixOf` msg) $

381 liftIO $ unless ("redundant" `T.isInfixOf` msg) $

425 assertFailure ("Expected redundant import but got " <> T.unpack msg)

382 assertFailure ("Expected redundant import but got " <> T.unpack msg)

426 closeDoc a

383 closeDoc a

427− , testSessionWait "haddock parse error" $ do

428− let fooContent = T.unlines

429− [ "module Foo where"

430− , "foo :: Int"

431− , "foo = 1 {-|-}"

432− ]

433− _ <- createDoc "Foo.hs" "haskell" fooContent

434− expectDiagnostics

435− [ ( "Foo.hs"

436− , [(DsError, (2, 8), "Parse error on input")

437− ]

438− )

439− ]

440− , testSessionWait "strip file path" $ do

441− let

442− name = "Testing"

443− content = T.unlines

444− [ "module " <> name <> " where"

445− , "value :: Maybe ()"

446− , "value = [()]"

447− ]

448− _ <- createDoc (T.unpack name <> ".hs") "haskell" content

449− notification <- skipManyTill anyMessage diagnostic

450− let

451− offenders =

452− Lsp.params .

453− Lsp.diagnostics .

454− Lens.folded .

455− Lsp.message .

456− Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:"))

457− failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg

458− Lens.mapMOf_ offenders failure notification

459 ]

384 ]

460

385

461codeActionTests :: TestTree

386codeActionTests :: TestTree

@@ -463,14 +388,9 @@ codeActionTests = testGroup "code actions"

463 [ renameActionTests

388 [ renameActionTests

464 , typeWildCardActionTests

389 , typeWildCardActionTests

465 , removeImportTests

390 , removeImportTests

466− , extendImportTests

467− , suggestImportTests

468− , addExtensionTests

469− , fixConstructorImportTests

470 , importRenameActionTests

391 , importRenameActionTests

471 , fillTypedHoleTests

392 , fillTypedHoleTests

472 , addSigActionTests

393 , addSigActionTests

473− , insertNewDefinitionTests

474 ]

394 ]

475

395

476codeLensesTests :: TestTree

396codeLensesTests :: TestTree

@@ -478,33 +398,6 @@ codeLensesTests = testGroup "code lenses"

478 [ addSigLensesTests

398 [ addSigLensesTests

479 ]

399 ]

480

400

481−watchedFilesTests :: TestTree

482−watchedFilesTests = testGroup "watched files"

483− [ testSession' "workspace files" $ \sessionDir -> do

484− liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"

485− _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"

486− watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

487−

488− -- Expect 4 subscriptions (A does not get any because it's VFS):

489− -- - /path-to-workspace/WatchedFilesMissingModule.hs

490− -- - /path-to-workspace/WatchedFilesMissingModule.lhs

491− -- - /path-to-workspace/src/WatchedFilesMissingModule.hs

492− -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs

493− liftIO $ length watchedFileRegs @?= 4

494−

495− , testSession' "non workspace file" $ \sessionDir -> do

496− liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"

497− _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"

498− watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

499−

500− -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):

501− -- - /path-to-workspace/WatchedFilesMissingModule.hs

502− -- - /path-to-workspace/WatchedFilesMissingModule.lhs

503− liftIO $ length watchedFileRegs @?= 2

504−

505− -- TODO add a test for didChangeWorkspaceFolder

506− ]

507−

508renameActionTests :: TestTree

401renameActionTests :: TestTree

509renameActionTests = testGroup "rename actions"

402renameActionTests = testGroup "rename actions"

510 [ testSession "change to local variable name" $ do

403 [ testSession "change to local variable name" $ do

@@ -513,9 +406,11 @@ renameActionTests = testGroup "rename actions"

513 , "foo :: Int -> Int"

406 , "foo :: Int -> Int"

514 , "foo argName = argNme"

407 , "foo argName = argNme"

515 ]

408 ]

516− doc <- createDoc "Testing.hs" "haskell" content

409+ doc <- openDoc' "Testing.hs" "haskell" content

517 _ <- waitForDiagnostics

410 _ <- waitForDiagnostics

411+ [CACodeAction action@CodeAction { _title = actionTitle }]

518− action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"

412+ <- getCodeActions doc (Range (Position 2 14) (Position 2 20))

413+ liftIO $ "Replace with ‘argName’" @=? actionTitle

519 executeCodeAction action

414 executeCodeAction action

520 contentAfterAction <- documentContents doc

415 contentAfterAction <- documentContents doc

521 let expectedContentAfterAction = T.unlines

416 let expectedContentAfterAction = T.unlines

@@ -531,9 +426,11 @@ renameActionTests = testGroup "rename actions"

531 , "foo :: Maybe a -> [a]"

426 , "foo :: Maybe a -> [a]"

532 , "foo = maybToList"

427 , "foo = maybToList"

533 ]

428 ]

534− doc <- createDoc "Testing.hs" "haskell" content

429+ doc <- openDoc' "Testing.hs" "haskell" content

535 _ <- waitForDiagnostics

430 _ <- waitForDiagnostics

431+ [CACodeAction action@CodeAction { _title = actionTitle }]

536− action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"

432+ <- getCodeActions doc (Range (Position 3 6) (Position 3 16))

433+ liftIO $ "Replace with ‘maybeToList’" @=? actionTitle

537 executeCodeAction action

434 executeCodeAction action

538 contentAfterAction <- documentContents doc

435 contentAfterAction <- documentContents doc

539 let expectedContentAfterAction = T.unlines

436 let expectedContentAfterAction = T.unlines

@@ -549,11 +446,12 @@ renameActionTests = testGroup "rename actions"

549 , "foo :: Char -> Char -> Char -> Char"

446 , "foo :: Char -> Char -> Char -> Char"

550 , "foo argument1 argument2 argument3 = argumentX"

447 , "foo argument1 argument2 argument3 = argumentX"

551 ]

448 ]

552− doc <- createDoc "Testing.hs" "haskell" content

449+ doc <- openDoc' "Testing.hs" "haskell" content

553 _ <- waitForDiagnostics

450 _ <- waitForDiagnostics

554− _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))

451+ actionsOrCommands <- getCodeActions doc (Range (Position 2 36) (Position 2 45))

452+ let actionTitles = [ actionTitle | CACodeAction CodeAction{ _title = actionTitle } <- actionsOrCommands ]

555− ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]

453+ expectedActionTitles = ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]

556− return()

454+ liftIO $ expectedActionTitles @=? actionTitles

557 , testSession "change infix function" $ do

455 , testSession "change infix function" $ do

558 let content = T.unlines

456 let content = T.unlines

559 [ "module Testing where"

457 [ "module Testing where"

@@ -561,7 +459,7 @@ renameActionTests = testGroup "rename actions"

561 , "monus x y = max 0 (x - y)"

459 , "monus x y = max 0 (x - y)"

562 , "foo x y = x `monnus` y"

460 , "foo x y = x `monnus` y"

563 ]

461 ]

564− doc <- createDoc "Testing.hs" "haskell" content

462+ doc <- openDoc' "Testing.hs" "haskell" content

565 _ <- waitForDiagnostics

463 _ <- waitForDiagnostics

566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))

464 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))

567 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]

465 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]

@@ -584,7 +482,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

584 , "func :: _"

482 , "func :: _"

585 , "func x = x"

483 , "func x = x"

586 ]

484 ]

587− doc <- createDoc "Testing.hs" "haskell" content

485+ doc <- openDoc' "Testing.hs" "haskell" content

588 _ <- waitForDiagnostics

486 _ <- waitForDiagnostics

589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

487 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

488 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -604,7 +502,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

604 , "func :: _"

502 , "func :: _"

605 , "func x y = x + y"

503 , "func x y = x + y"

606 ]

504 ]

607− doc <- createDoc "Testing.hs" "haskell" content

505+ doc <- openDoc' "Testing.hs" "haskell" content

608 _ <- waitForDiagnostics

506 _ <- waitForDiagnostics

609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

507 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

508 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -627,7 +525,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

627 , " y = x * 2"

525 , " y = x * 2"

628 , " in y"

526 , " in y"

629 ]

527 ]

630− doc <- createDoc "Testing.hs" "haskell" content

528+ doc <- openDoc' "Testing.hs" "haskell" content

631 _ <- waitForDiagnostics

529 _ <- waitForDiagnostics

632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))

530 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))

633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

531 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -652,7 +550,7 @@ removeImportTests = testGroup "remove import actions"

652 let contentA = T.unlines

550 let contentA = T.unlines

653 [ "module ModuleA where"

551 [ "module ModuleA where"

654 ]

552 ]

655− _docA <- createDoc "ModuleA.hs" "haskell" contentA

553+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

656 let contentB = T.unlines

554 let contentB = T.unlines

657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

555 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

658 , "module ModuleB where"

556 , "module ModuleB where"

@@ -660,7 +558,7 @@ removeImportTests = testGroup "remove import actions"

660 , "stuffB :: Integer"

558 , "stuffB :: Integer"

661 , "stuffB = 123"

559 , "stuffB = 123"

662 ]

560 ]

663− docB <- createDoc "ModuleB.hs" "haskell" contentB

561+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

664 _ <- waitForDiagnostics

562 _ <- waitForDiagnostics

665 [CACodeAction action@CodeAction { _title = actionTitle }]

563 [CACodeAction action@CodeAction { _title = actionTitle }]

666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

564 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -678,7 +576,7 @@ removeImportTests = testGroup "remove import actions"

678 let contentA = T.unlines

576 let contentA = T.unlines

679 [ "module ModuleA where"

577 [ "module ModuleA where"

680 ]

578 ]

681− _docA <- createDoc "ModuleA.hs" "haskell" contentA

579+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

682 let contentB = T.unlines

580 let contentB = T.unlines

683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

581 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

684 , "module ModuleB where"

582 , "module ModuleB where"

@@ -686,7 +584,7 @@ removeImportTests = testGroup "remove import actions"

686 , "stuffB :: Integer"

584 , "stuffB :: Integer"

687 , "stuffB = 123"

585 , "stuffB = 123"

688 ]

586 ]

689− docB <- createDoc "ModuleB.hs" "haskell" contentB

587+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

690 _ <- waitForDiagnostics

588 _ <- waitForDiagnostics

691 [CACodeAction action@CodeAction { _title = actionTitle }]

589 [CACodeAction action@CodeAction { _title = actionTitle }]

692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

590 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -706,20 +604,19 @@ removeImportTests = testGroup "remove import actions"

706 , "stuffA = False"

604 , "stuffA = False"

707 , "stuffB :: Integer"

605 , "stuffB :: Integer"

708 , "stuffB = 123"

606 , "stuffB = 123"

709− , "stuffC = ()"

710 ]

607 ]

711− _docA <- createDoc "ModuleA.hs" "haskell" contentA

608+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

712 let contentB = T.unlines

609 let contentB = T.unlines

713 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

610 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

714 , "module ModuleB where"

611 , "module ModuleB where"

715− , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"

612+ , "import ModuleA (stuffA, stuffB)"

716 , "main = print stuffB"

613 , "main = print stuffB"

717 ]

614 ]

718− docB <- createDoc "ModuleB.hs" "haskell" contentB

615+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

719 _ <- waitForDiagnostics

616 _ <- waitForDiagnostics

720 [CACodeAction action@CodeAction { _title = actionTitle }]

617 [CACodeAction action@CodeAction { _title = actionTitle }]

721 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

618 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

722− liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle

619+ liftIO $ "Remove stuffA from import" @=? actionTitle

723 executeCodeAction action

620 executeCodeAction action

724 contentAfterAction <- documentContents docB

621 contentAfterAction <- documentContents docB

725 let expectedContentAfterAction = T.unlines

622 let expectedContentAfterAction = T.unlines

@@ -729,26 +626,29 @@ removeImportTests = testGroup "remove import actions"

729 , "main = print stuffB"

626 , "main = print stuffB"

730 ]

627 ]

731 liftIO $ expectedContentAfterAction @=? contentAfterAction

628 liftIO $ expectedContentAfterAction @=? contentAfterAction

732− , testSession "redundant operator" $ do

629+ , testSession "redundant symbol binding" $ do

733 let contentA = T.unlines

630 let contentA = T.unlines

734 [ "module ModuleA where"

631 [ "module ModuleA where"

735 , "a !! b = a"

632 , "a !! b = a"

736− , "a <?> b = a"

737 , "stuffB :: Integer"

633 , "stuffB :: Integer"

738 , "stuffB = 123"

634 , "stuffB = 123"

739 ]

635 ]

740− _docA <- createDoc "ModuleA.hs" "haskell" contentA

636+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

741 let contentB = T.unlines

637 let contentB = T.unlines

742 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

638 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

743 , "module ModuleB where"

639 , "module ModuleB where"

744− , "import qualified ModuleA as A ((<?>), stuffB, (!!))"

640+ , "import qualified ModuleA as A ((!!), stuffB, (!!))"

745 , "main = print A.stuffB"

641 , "main = print A.stuffB"

746 ]

642 ]

747− docB <- createDoc "ModuleB.hs" "haskell" contentB

643+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

748 _ <- waitForDiagnostics

644 _ <- waitForDiagnostics

749 [CACodeAction action@CodeAction { _title = actionTitle }]

645 [CACodeAction action@CodeAction { _title = actionTitle }]

750 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

646 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

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

648+ liftIO $ "Remove !! from import" @=? actionTitle

649+#else

751− liftIO $ "Remove !!, <?> from import" @=? actionTitle

650+ liftIO $ "Remove A.!! from import" @=? actionTitle

651+#endif

752 executeCodeAction action

652 executeCodeAction action

753 contentAfterAction <- documentContents docB

653 contentAfterAction <- documentContents docB

754 let expectedContentAfterAction = T.unlines

654 let expectedContentAfterAction = T.unlines

@@ -758,21 +658,21 @@ removeImportTests = testGroup "remove import actions"

758 , "main = print A.stuffB"

658 , "main = print A.stuffB"

759 ]

659 ]

760 liftIO $ expectedContentAfterAction @=? contentAfterAction

660 liftIO $ expectedContentAfterAction @=? contentAfterAction

761− , testSession "redundant all import" $ do

661+ , (`xfail` "known broken (#299)") $ testSession "redundant hierarchical import" $ do

762 let contentA = T.unlines

662 let contentA = T.unlines

763 [ "module ModuleA where"

663 [ "module ModuleA where"

764 , "data A = A"

664 , "data A = A"

765 , "stuffB :: Integer"

665 , "stuffB :: Integer"

766 , "stuffB = 123"

666 , "stuffB = 123"

767 ]

667 ]

768− _docA <- createDoc "ModuleA.hs" "haskell" contentA

668+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

769 let contentB = T.unlines

669 let contentB = T.unlines

770 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

670 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

771 , "module ModuleB where"

671 , "module ModuleB where"

772 , "import ModuleA (A(..), stuffB)"

672 , "import ModuleA (A(..), stuffB)"

773 , "main = print stuffB"

673 , "main = print stuffB"

774 ]

674 ]

775− docB <- createDoc "ModuleB.hs" "haskell" contentB

675+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

776 _ <- waitForDiagnostics

676 _ <- waitForDiagnostics

777 [CACodeAction action@CodeAction { _title = actionTitle }]

677 [CACodeAction action@CodeAction { _title = actionTitle }]

778 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

678 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -786,368 +686,8 @@ removeImportTests = testGroup "remove import actions"

786 , "main = print stuffB"

686 , "main = print stuffB"

787 ]

687 ]

788 liftIO $ expectedContentAfterAction @=? contentAfterAction

688 liftIO $ expectedContentAfterAction @=? contentAfterAction

789− , testSession "redundant constructor import" $ do

790− let contentA = T.unlines

791− [ "module ModuleA where"

792− , "data D = A | B"

793− , "data E = F"

794− ]

795− _docA <- createDoc "ModuleA.hs" "haskell" contentA

796− let contentB = T.unlines

797− [ "{-# OPTIONS_GHC -Wunused-imports #-}"

798− , "module ModuleB where"

799− , "import ModuleA (D(A,B), E(F))"

800− , "main = B"

801− ]

802− docB <- createDoc "ModuleB.hs" "haskell" contentB

803− _ <- waitForDiagnostics

804− [CACodeAction action@CodeAction { _title = actionTitle }]

805− <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

806− liftIO $ "Remove A, E, F from import" @=? actionTitle

807− executeCodeAction action

808− contentAfterAction <- documentContents docB

809− let expectedContentAfterAction = T.unlines

810− [ "{-# OPTIONS_GHC -Wunused-imports #-}"

811− , "module ModuleB where"

812− , "import ModuleA (D(B))"

813− , "main = B"

814− ]

815− liftIO $ expectedContentAfterAction @=? contentAfterAction

816− ]

817−

818−extendImportTests :: TestTree

819−extendImportTests = testGroup "extend import actions"

820− [ testSession "extend single line import with value" $ template

821− (T.unlines

822− [ "module ModuleA where"

823− , "stuffA :: Double"

824− , "stuffA = 0.00750"

825− , "stuffB :: Integer"

826− , "stuffB = 123"

827− ])

828− (T.unlines

829− [ "module ModuleB where"

830− , "import ModuleA as A (stuffB)"

831− , "main = print (stuffA, stuffB)"

832− ])

833− (Range (Position 3 17) (Position 3 18))

834− "Add stuffA to the import list of ModuleA"

835− (T.unlines

836− [ "module ModuleB where"

837− , "import ModuleA as A (stuffA, stuffB)"

838− , "main = print (stuffA, stuffB)"

839− ])

840− , testSession "extend single line import with operator" $ template

841− (T.unlines

842− [ "module ModuleA where"

843− , "(.*) :: Integer -> Integer -> Integer"

844− , "x .* y = x * y"

845− , "stuffB :: Integer"

846− , "stuffB = 123"

847− ])

848− (T.unlines

849− [ "module ModuleB where"

850− , "import ModuleA as A (stuffB)"

851− , "main = print (stuffB .* stuffB)"

852− ])

853− (Range (Position 3 17) (Position 3 18))

854− "Add .* to the import list of ModuleA"

855− (T.unlines

856− [ "module ModuleB where"

857− , "import ModuleA as A ((.*), stuffB)"

858− , "main = print (stuffB .* stuffB)"

859− ])

860− , testSession "extend single line import with type" $ template

861− (T.unlines

862− [ "module ModuleA where"

863− , "type A = Double"

864− ])

865− (T.unlines

866− [ "module ModuleB where"

867− , "import ModuleA ()"

868− , "b :: A"

869− , "b = 0"

870− ])

871− (Range (Position 2 5) (Position 2 5))

872− "Add A to the import list of ModuleA"

873− (T.unlines

874− [ "module ModuleB where"

875− , "import ModuleA (A)"

876− , "b :: A"

877− , "b = 0"

878− ])

879− , (`xfail` "known broken") $ testSession "extend single line import with constructor" $ template

880− (T.unlines

881− [ "module ModuleA where"

882− , "data A = Constructor"

883− ])

884− (T.unlines

885− [ "module ModuleB where"

886− , "import ModuleA (A)"

887− , "b :: A"

888− , "b = Constructor"

889− ])

890− (Range (Position 2 5) (Position 2 5))

891− "Add Constructor to the import list of ModuleA"

892− (T.unlines

893− [ "module ModuleB where"

894− , "import ModuleA (A(Constructor))"

895− , "b :: A"

896− , "b = Constructor"

897− ])

898− , testSession "extend single line qualified import with value" $ template

899− (T.unlines

900− [ "module ModuleA where"

901− , "stuffA :: Double"

902− , "stuffA = 0.00750"

903− , "stuffB :: Integer"

904− , "stuffB = 123"

905− ])

906− (T.unlines

907− [ "module ModuleB where"

908− , "import qualified ModuleA as A (stuffB)"

909− , "main = print (A.stuffA, A.stuffB)"

910− ])

911− (Range (Position 3 17) (Position 3 18))

912− "Add stuffA to the import list of ModuleA"

913− (T.unlines

914− [ "module ModuleB where"

915− , "import qualified ModuleA as A (stuffA, stuffB)"

916− , "main = print (A.stuffA, A.stuffB)"

917− ])

918− , testSession "extend multi line import with value" $ template

919− (T.unlines

920− [ "module ModuleA where"

921− , "stuffA :: Double"

922− , "stuffA = 0.00750"

923− , "stuffB :: Integer"

924− , "stuffB = 123"

925− ])

926− (T.unlines

927− [ "module ModuleB where"

928− , "import ModuleA (stuffB"

929− , " )"

930− , "main = print (stuffA, stuffB)"

931− ])

932− (Range (Position 3 17) (Position 3 18))

933− "Add stuffA to the import list of ModuleA"

934− (T.unlines

935− [ "module ModuleB where"

936− , "import ModuleA (stuffA, stuffB"

937− , " )"

938− , "main = print (stuffA, stuffB)"

939− ])

940− ]

941− where

942− template contentA contentB range expectedAction expectedContentB = do

943− _docA <- createDoc "ModuleA.hs" "haskell" contentA

944− docB <- createDoc "ModuleB.hs" "haskell" contentB

945− _ <- waitForDiagnostics

946− CACodeAction action@CodeAction { _title = actionTitle } : _

947− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

948− getCodeActions docB range

949− liftIO $ expectedAction @=? actionTitle

950− executeCodeAction action

951− contentAfterAction <- documentContents docB

952− liftIO $ expectedContentB @=? contentAfterAction

953−

954−suggestImportTests :: TestTree

955−suggestImportTests = testGroup "suggest import actions"

956− [ testGroup "Dont want suggestion"

957− [ -- extend import

958− test False ["Data.List.NonEmpty ()"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"

959− -- data constructor

960− , test False [] "f = First" [] "import Data.Monoid (First)"

961− -- internal module

962− , test False [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable.Internal (Typeable)"

963− -- package not in scope

964− , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)"

965− ]

966− , testGroup "want suggestion"

967− [ test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"

968− , test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))"

969− , test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)"

970− , test True [] "f :: NonEmpty ()" ["f = () :| []"] "import Data.List.NonEmpty (NonEmpty)"

971− , test True [] "f = First" [] "import Data.Monoid (First(First))"

972− , test True [] "f = Endo" [] "import Data.Monoid (Endo(Endo))"

973− , test True [] "f = Version" [] "import Data.Version (Version(Version))"

974− , test True [] "f ExitSuccess = ()" [] "import System.Exit (ExitCode(ExitSuccess))"

975− , test True [] "f = AssertionFailed" [] "import Control.Exception (AssertionFailed(AssertionFailed))"

976− , test True ["Prelude"] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"

977− , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)"

978− , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))"

979− , test True [] "f = (&)" [] "import Data.Function ((&))"

980− , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE"

981− , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)"

982− , test True [] "f = pack" [] "import Data.Text (pack)"

983− , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)"

984− , test True [] "f = [] & id" [] "import Data.Function ((&))"

985− , test True [] "f = (&) [] id" [] "import Data.Function ((&))"

986− ]

987− ]

988− where

989− test wanted imps def other newImp = testSession' (T.unpack def) $ \dir -> do

990− let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other

991− after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other

992− cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -]}}"

993− liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle

994− doc <- createDoc "Test.hs" "haskell" before

995− _diags <- waitForDiagnostics

996− let defLine = length imps + 1

997− range = Range (Position defLine 0) (Position defLine maxBound)

998− actions <- getCodeActions doc range

999− if wanted

1000− then do

1001− action <- liftIO $ pickActionWithTitle newImp actions

1002− executeCodeAction action

1003− contentAfterAction <- documentContents doc

1004− liftIO $ after @=? contentAfterAction

1005− else

1006− liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []

1007−

1008−

1009−addExtensionTests :: TestTree

1010−addExtensionTests = testGroup "add language extension actions"

1011− [ testSession "add NamedFieldPuns language extension" $ template

1012− (T.unlines

1013− [ "module Module where"

1014− , ""

1015− , "data A = A { getA :: Bool }"

1016− , ""

1017− , "f :: A -> Bool"

1018− , "f A { getA } = getA"

1019− ])

1020− (Range (Position 0 0) (Position 0 0))

1021− "Add NamedFieldPuns extension"

1022− (T.unlines

1023− [ "{-# LANGUAGE NamedFieldPuns #-}"

1024− , "module Module where"

1025− , ""

1026− , "data A = A { getA :: Bool }"

1027− , ""

1028− , "f :: A -> Bool"

1029− , "f A { getA } = getA"

1030− ])

1031− , testSession "add RecordWildCards language extension" $ template

1032− (T.unlines

1033− [ "module Module where"

1034− , ""

1035− , "data A = A { getA :: Bool }"

1036− , ""

1037− , "f :: A -> Bool"

1038− , "f A { .. } = getA"

1039− ])

1040− (Range (Position 0 0) (Position 0 0))

1041− "Add RecordWildCards extension"

1042− (T.unlines

1043− [ "{-# LANGUAGE RecordWildCards #-}"

1044− , "module Module where"

1045− , ""

1046− , "data A = A { getA :: Bool }"

1047− , ""

1048− , "f :: A -> Bool"

1049− , "f A { .. } = getA"

1050− ])

1051− ]

1052− where

1053− template initialContent range expectedAction expectedContents = do

1054− doc <- createDoc "Module.hs" "haskell" initialContent

1055− _ <- waitForDiagnostics

1056− CACodeAction action@CodeAction { _title = actionTitle } : _

1057− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1058− getCodeActions doc range

1059− liftIO $ expectedAction @=? actionTitle

1060− executeCodeAction action

1061− contentAfterAction <- documentContents doc

1062− liftIO $ expectedContents @=? contentAfterAction

1063−

1064−

1065−insertNewDefinitionTests :: TestTree

1066−insertNewDefinitionTests = testGroup "insert new definition actions"

1067− [ testSession "insert new function definition" $ do

1068− let txtB =

1069− ["foo True = select [True]"

1070− , ""

1071− ,"foo False = False"

1072− ]

1073− txtB' =

1074− [""

1075− ,"someOtherCode = ()"

1076− ]

1077− docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1078− _ <- waitForDiagnostics

1079− CACodeAction action@CodeAction { _title = actionTitle } : _

1080− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1081− getCodeActions docB (R 1 0 1 50)

1082− liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"

1083− executeCodeAction action

1084− contentAfterAction <- documentContents docB

1085− liftIO $ contentAfterAction @?= T.unlines (txtB ++

1086− [ ""

1087− , "select :: [Bool] -> Bool"

1088− , "select = error \"not implemented\""

1089− ]

1090− ++ txtB')

1091− , testSession "define a hole" $ do

1092− let txtB =

1093− ["foo True = _select [True]"

1094− , ""

1095− ,"foo False = False"

1096− ]

1097− txtB' =

1098− [""

1099− ,"someOtherCode = ()"

1100− ]

1101− docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1102− _ <- waitForDiagnostics

1103− CACodeAction action@CodeAction { _title = actionTitle } : _

1104− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1105− getCodeActions docB (R 1 0 1 50)

1106− liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"

1107− executeCodeAction action

1108− contentAfterAction <- documentContents docB

1109− liftIO $ contentAfterAction @?= T.unlines (

1110− ["foo True = select [True]"

1111− , ""

1112− ,"foo False = False"

1113− , ""

1114− , "select :: [Bool] -> Bool"

1115− , "select = error \"not implemented\""

1116− ]

1117− ++ txtB')

1118 ]

689 ]

1119

690

1120−fixConstructorImportTests :: TestTree

1121−fixConstructorImportTests = testGroup "fix import actions"

1122− [ testSession "fix constructor import" $ template

1123− (T.unlines

1124− [ "module ModuleA where"

1125− , "data A = Constructor"

1126− ])

1127− (T.unlines

1128− [ "module ModuleB where"

1129− , "import ModuleA(Constructor)"

1130− ])

1131− (Range (Position 1 10) (Position 1 11))

1132− "Fix import of A(Constructor)"

1133− (T.unlines

1134− [ "module ModuleB where"

1135− , "import ModuleA(A(Constructor))"

1136− ])

1137− ]

1138− where

1139− template contentA contentB range expectedAction expectedContentB = do

1140− _docA <- createDoc "ModuleA.hs" "haskell" contentA

1141− docB <- createDoc "ModuleB.hs" "haskell" contentB

1142− _diags <- waitForDiagnostics

1143− CACodeAction action@CodeAction { _title = actionTitle } : _

1144− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1145− getCodeActions docB range

1146− liftIO $ expectedAction @=? actionTitle

1147− executeCodeAction action

1148− contentAfterAction <- documentContents docB

1149− liftIO $ expectedContentB @=? contentAfterAction

1150−

1151importRenameActionTests :: TestTree

691importRenameActionTests :: TestTree

1152importRenameActionTests = testGroup "import rename actions"

692importRenameActionTests = testGroup "import rename actions"

1153 [ testSession "Data.Mape -> Data.Map" $ check "Map"

693 [ testSession "Data.Mape -> Data.Map" $ check "Map"

@@ -1157,7 +697,7 @@ importRenameActionTests = testGroup "import rename actions"

1157 [ "module Testing where"

697 [ "module Testing where"

1158 , "import Data.Mape"

698 , "import Data.Mape"

1159 ]

699 ]

1160− doc <- createDoc "Testing.hs" "haskell" content

700+ doc <- openDoc' "Testing.hs" "haskell" content

1161 _ <- waitForDiagnostics

701 _ <- waitForDiagnostics

1162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))

702 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))

1163 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]

703 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]

@@ -1194,10 +734,10 @@ fillTypedHoleTests = let

1194 newA newB newC = testSession (T.unpack actionTitle) $ do

734 newA newB newC = testSession (T.unpack actionTitle) $ do

1195 let originalCode = sourceCode oldA oldB oldC

735 let originalCode = sourceCode oldA oldB oldC

1196 let expectedCode = sourceCode newA newB newC

736 let expectedCode = sourceCode newA newB newC

1197− doc <- createDoc "Testing.hs" "haskell" originalCode

737+ doc <- openDoc' "Testing.hs" "haskell" originalCode

1198 _ <- waitForDiagnostics

738 _ <- waitForDiagnostics

1199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))

739 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))

1200− chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands

740+ let chosenAction = pickActionWithTitle actionTitle actionsOrCommands

1201 executeCodeAction chosenAction

741 executeCodeAction chosenAction

1202 modifiedCode <- documentContents doc

742 modifiedCode <- documentContents doc

1203 liftIO $ expectedCode @=? modifiedCode

743 liftIO $ expectedCode @=? modifiedCode

@@ -1234,37 +774,36 @@ fillTypedHoleTests = let

1234

774

1235addSigActionTests :: TestTree

775addSigActionTests :: TestTree

1236addSigActionTests = let

776addSigActionTests = let

1237− header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"

777+ header = "{-# OPTIONS_GHC -Wmissing-signatures #-}"

1238− moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"

778+ moduleH = "module Sigs where"

1239 before def = T.unlines [header, moduleH, def]

779 before def = T.unlines [header, moduleH, def]

1240 after' def sig = T.unlines [header, moduleH, sig, def]

780 after' def sig = T.unlines [header, moduleH, sig, def]

1241

781

1242 def >:: sig = testSession (T.unpack def) $ do

782 def >:: sig = testSession (T.unpack def) $ do

1243 let originalCode = before def

783 let originalCode = before def

1244 let expectedCode = after' def sig

784 let expectedCode = after' def sig

1245− doc <- createDoc "Sigs.hs" "haskell" originalCode

785+ doc <- openDoc' "Sigs.hs" "haskell" originalCode

1246 _ <- waitForDiagnostics

786 _ <- waitForDiagnostics

1247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))

787 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))

1248− chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

788+ let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

1249 executeCodeAction chosenAction

789 executeCodeAction chosenAction

1250 modifiedCode <- documentContents doc

790 modifiedCode <- documentContents doc

1251 liftIO $ expectedCode @=? modifiedCode

791 liftIO $ expectedCode @=? modifiedCode

1252 in

792 in

1253 testGroup "add signature"

793 testGroup "add signature"

1254− [ "abc = True" >:: "abc :: Bool"

794+ [ "abc = True" >:: "abc :: Bool"

1255− , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"

795+ , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"

1256− , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"

796+ , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"

1257− , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"

797+ , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"

1258− , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"

798+ , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"

1259− , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"

799+ , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"

1260− , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"

1261 ]

800 ]

1262

801

1263addSigLensesTests :: TestTree

802addSigLensesTests :: TestTree

1264addSigLensesTests = let

803addSigLensesTests = let

1265− missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"

804+ missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wunused-matches #-}"

1266 notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"

805 notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"

1267− moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"

806+ moduleH = "module Sigs where"

1268 other = T.unlines ["f :: Integer -> Integer", "f x = 3"]

807 other = T.unlines ["f :: Integer -> Integer", "f x = 3"]

1269 before withMissing def

808 before withMissing def

1270 = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]

809 = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]

@@ -1274,77 +813,71 @@ addSigLensesTests = let

1274 sigSession withMissing def sig = testSession (T.unpack def) $ do

813 sigSession withMissing def sig = testSession (T.unpack def) $ do

1275 let originalCode = before withMissing def

814 let originalCode = before withMissing def

1276 let expectedCode = after' withMissing def sig

815 let expectedCode = after' withMissing def sig

1277− doc <- createDoc "Sigs.hs" "haskell" originalCode

816+ doc <- openDoc' "Sigs.hs" "haskell" originalCode

1278 [CodeLens {_command = Just c}] <- getCodeLenses doc

817 [CodeLens {_command = Just c}] <- getCodeLenses doc

1279 executeCommand c

818 executeCommand c

1280 modifiedCode <- getDocumentEdit doc

819 modifiedCode <- getDocumentEdit doc

1281 liftIO $ expectedCode @=? modifiedCode

820 liftIO $ expectedCode @=? modifiedCode

1282 in

821 in

1283 testGroup "add signature"

822 testGroup "add signature"

1284− [ testGroup title

823+ [ testGroup "with warnings enabled"

1285− [ sigSession enableWarnings "abc = True" "abc :: Bool"

824+ [ sigSession True "abc = True" "abc :: Bool"

1286− , sigSession enableWarnings "foo a b = a + b" "foo :: Num a => a -> a -> a"

825+ , sigSession True "foo a b = a + b" "foo :: Num a => a -> a -> a"

1287− , sigSession enableWarnings "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"

826+ , sigSession True "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"

1288− , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"

827+ , sigSession True "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"

1289− , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"

828+ , sigSession True "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"

1290− , sigSession enableWarnings "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"

829+ , sigSession True "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"

1291− , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a"

830+ ]

831+ , testGroup "with warnings disabled"

832+ [ sigSession False "abc = True" "abc :: Bool"

833+ , sigSession False "foo a b = a + b" "foo :: Num a => a -> a -> a"

834+ , sigSession False "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"

835+ , sigSession False "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"

836+ , sigSession False "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"

837+ , sigSession False "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"

1292 ]

838 ]

1293− | (title, enableWarnings) <-

1294− [("with warnings enabled", True)

1295− ,("with warnings disabled", False)

1296− ]

1297 ]

839 ]

1298

840

1299−checkDefs :: [Location] -> Session [Expect] -> Session ()

1300−checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where

1301−

1302− check (ExpectRange expectedRange) = do

1303− assertNDefinitionsFound 1 defs

1304− assertRangeCorrect (head defs) expectedRange

1305− check (ExpectLocation expectedLocation) = do

1306− assertNDefinitionsFound 1 defs

1307− liftIO $ head defs @?= expectedLocation

1308− check ExpectNoDefinitions = do

1309− assertNDefinitionsFound 0 defs

1310− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"

1311− check _ = pure () -- all other expectations not relevant to getDefinition

1312−

1313− assertNDefinitionsFound :: Int -> [a] -> Session ()

1314− assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)

1315−

1316− assertRangeCorrect Location{_range = foundRange} expectedRange =

1317− liftIO $ expectedRange @=? foundRange

1318−

1319−

1320findDefinitionAndHoverTests :: TestTree

841findDefinitionAndHoverTests :: TestTree

1321findDefinitionAndHoverTests = let

842findDefinitionAndHoverTests = let

1322

843

1323− tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do

844+ tst (get, check) pos targetRange title = testSession title $ do

1324− doc <- openTestDataDoc (dir </> sourceFilePath)

845+ doc <- openTestDataDoc sourceFilePath

1325 found <- get doc pos

846 found <- get doc pos

1326 check found targetRange

847 check found targetRange

1327

848

849+ checkDefs :: [Location] -> [Expect] -> Session ()

850+ checkDefs defs expectations = traverse_ check expectations where

851+

852+ check (ExpectRange expectedRange) = do

853+ assertNDefinitionsFound 1 defs

854+ assertRangeCorrect (head defs) expectedRange

855+ check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"

856+ check _ = pure () -- all other expectations not relevant to getDefinition

857+

858+ assertNDefinitionsFound :: Int -> [a] -> Session ()

859+ assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)

1328

860

861+ assertRangeCorrect Location{_range = foundRange} expectedRange =

862+ liftIO $ expectedRange @=? foundRange

1329

863

1330− checkHover :: Maybe Hover -> Session [Expect] -> Session ()

864+ checkHover :: Maybe Hover -> [Expect] -> Session ()

1331− checkHover hover expectations = traverse_ check =<< expectations where

865+ checkHover hover expectations = traverse_ check expectations where

1332

866

1333 check expected =

867 check expected =

1334 case hover of

868 case hover of

1335− Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"

869+ Nothing -> liftIO $ assertFailure "no hover found"

1336 Just Hover{_contents = (HoverContents MarkupContent{_value = msg})

870 Just Hover{_contents = (HoverContents MarkupContent{_value = msg})

1337 ,_range = rangeInHover } ->

871 ,_range = rangeInHover } ->

1338 case expected of

872 case expected of

1339 ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg

873 ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg

1340 ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg

874 ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg

1341 ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets

875 ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets

1342− ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover

1343 _ -> pure () -- all other expectations not relevant to hover

876 _ -> pure () -- all other expectations not relevant to hover

1344 _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover

877 _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover

1345

878

1346 extractLineColFromHoverMsg :: T.Text -> [T.Text]

879 extractLineColFromHoverMsg :: T.Text -> [T.Text]

1347− extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")

880+ extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "**" . last . T.splitOn (sourceFileName <> ":")

1348

881

1349 checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()

882 checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()

1350 checkHoverRange expectedRange rangeInHover msg =

883 checkHoverRange expectedRange rangeInHover msg =

@@ -1371,12 +904,9 @@ findDefinitionAndHoverTests = let

1371

904

1372 mkFindTests tests = testGroup "get"

905 mkFindTests tests = testGroup "get"

1373 [ testGroup "definition" $ mapMaybe fst tests

906 [ testGroup "definition" $ mapMaybe fst tests

1374− , testGroup "hover" $ mapMaybe snd tests

907+ , testGroup "hover" $ mapMaybe snd tests ]

1375− , checkFileCompiles sourceFilePath ]

1376−

1377− test runDef runHover look expect = testM runDef runHover look (return expect)

1378

908

1379− testM runDef runHover look expect title =

909+ test runDef runHover look expect title =

1380 ( runDef $ tst def look expect title

910 ( runDef $ tst def look expect title

1381 , runHover $ tst hover look expect title ) where

911 , runHover $ tst hover look expect title ) where

1382 def = (getDefinitions, checkDefs)

912 def = (getDefinitions, checkDefs)

@@ -1384,100 +914,81 @@ findDefinitionAndHoverTests = let

1384 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out

914 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out

1385

915

1386 -- search locations expectations on results

916 -- search locations expectations on results

1387− fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR]

917+ fffL4 = _start fffR ; fffR = mkRange 4 4 4 7 ; fff = [ExpectRange fffR]

1388− fffL8 = Position 12 4 ;

918+ fffL8 = Position 8 4 ;

1389− fffL14 = Position 18 7 ;

919+ fffL14 = Position 14 7 ;

1390− aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]

920+ aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]

1391− dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]

921+ dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]

1392− dcL12 = Position 16 11 ;

922+ dcL12 = Position 12 11 ;

1393− xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]

923+ xtcL5 = Position 5 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]

1394− tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]]

924+ tcL6 = Position 6 11 ; tcData = [mkR 3 0 5 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:4:1"]]

1395− vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6]

925+ vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]

1396− opL16 = Position 20 15 ; op = [mkR 21 2 21 4]

926+ opL16 = Position 16 15 ; op = [mkR 17 2 17 4]

1397− opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]

927+ opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]

1398− aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]

928+ aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]

1399− b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]

929+ b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]

1400− xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]

930+ xvL20 = Position 20 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]

1401− clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]]

931+ clL23 = Position 23 11 ; cls = [mkR 21 0 22 20, ExpectHoverText ["MyClass", "GotoHover.hs:22:1"]]

1402− clL25 = Position 29 9

932+ clL25 = Position 25 9

1403− eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]

933+ eclL15 = Position 15 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]

1404− dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21]

934+ dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]

1405− dnbL30 = Position 34 23

935+ dnbL30 = Position 30 23

1406− lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27]

936+ lcbL33 = Position 33 26 ; lcb = [ExpectHoverText [":: Char"], mkR 33 26 33 27]

1407− lclL33 = Position 37 22

937+ lclL33 = Position 33 22

1408− mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14]

938+ mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14]

1409− mclL37 = Position 41 1

939+ mclL37 = Position 37 1

1410− spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]

1411− docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]

940+ docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]

1412− ; constr = [ExpectHoverText ["Monad m"]]

941+ ; constr = [ExpectHoverText ["Monad m =>"]]

1413− eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]

942+ eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]

1414− intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]]

943+ intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]]

1415− tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]

944+ tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]

1416− intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]]

945+ intL41 = Position 41 20 ; litI = [ExpectHoverText ["7518"]]

1417− chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]]

946+ chrL36 = Position 36 25 ; litC = [ExpectHoverText ["'t'"]]

1418− txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]]

947+ txtL8 = Position 8 14 ; litT = [ExpectHoverText ["\"dfgv\""]]

1419− lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]

948+ lstL43 = Position 43 12 ; litL = [ExpectHoverText ["[ 8391 :: Int, 6268 ]"]]

1420− outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]

1421− innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]

1422− imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo"], mkL foo 4 0 4 3]

1423− reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar"], mkL bar 2 0 2 14]

1424 in

949 in

1425 mkFindTests

950 mkFindTests

1426− -- def hover look expect

951+ -- def hover look expect

1427− [ test yes yes fffL4 fff "field in record definition"

952+ [ test yes yes fffL4 fff "field in record definition"

1428− , test broken broken fffL8 fff "field in record construction #71"

953+ , test broken broken fffL8 fff "field in record construction #71"

1429− , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs

954+ , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs

1430− , test yes yes aaaL14 aaa "top-level name" -- 120

955+ , test yes yes aaaL14 aaa "top-level name" -- 120

1431− , test yes yes dcL7 tcDC "data constructor record #247"

956+ , test broken broken dcL7 tcDC "data constructor record #247"

1432− , test yes yes dcL12 tcDC "data constructor plain" -- 121

957+ , test yes yes dcL12 tcDC "data constructor plain" -- 121

1433− , test yes yes tcL6 tcData "type constructor #248" -- 147

958+ , test yes yes tcL6 tcData "type constructor #248" -- 147

1434− , test broken yes xtcL5 xtc "type constructor external #248,249"

959+ , test broken yes xtcL5 xtc "type constructor external #248,249"

1435− , test broken yes xvL20 xvMsg "value external package #249" -- 120

960+ , test broken yes xvL20 xvMsg "value external package #249" -- 120

1436− , test yes yes vvL16 vv "plain parameter" -- 120

961+ , test yes yes vvL16 vv "plain parameter" -- 120

1437− , test yes yes aL18 apmp "pattern match name" -- 120

962+ , test yes yes aL18 apmp "pattern match name" -- 120

1438− , test yes yes opL16 op "top-level operator" -- 120, 123

963+ , test yes yes opL16 op "top-level operator" -- 120, 123

1439− , test yes yes opL18 opp "parameter operator" -- 120

964+ , test yes yes opL18 opp "parameter operator" -- 120

1440− , test yes yes b'L19 bp "name in backticks" -- 120

965+ , test yes yes b'L19 bp "name in backticks" -- 120

1441− , test yes yes clL23 cls "class in instance declaration #250"

966+ , test yes yes clL23 cls "class in instance declaration #250"

1442− , test yes yes clL25 cls "class in signature #250" -- 147

967+ , test yes yes clL25 cls "class in signature #250" -- 147

1443− , test broken yes eclL15 ecls "external class in signature #249,250"

968+ , test broken yes eclL15 ecls "external class in signature #249,250"

1444− , test yes yes dnbL29 dnb "do-notation bind" -- 137

969+ , test yes yes dnbL29 dnb "do-notation bind" -- 137

1445− , test yes yes dnbL30 dnb "do-notation lookup"

970+ , test yes yes dnbL30 dnb "do-notation lookup"

1446− , test yes yes lcbL33 lcb "listcomp bind" -- 137

971+ , test yes yes lcbL33 lcb "listcomp bind" -- 137

1447− , test yes yes lclL33 lcb "listcomp lookup"

972+ , test yes yes lclL33 lcb "listcomp lookup"

1448− , test yes yes mclL36 mcl "top-level fn 1st clause"

973+ , test yes yes mclL36 mcl "top-level fn 1st clause"

1449− , test yes yes mclL37 mcl "top-level fn 2nd clause #246"

974+ , test yes yes mclL37 mcl "top-level fn 2nd clause #246"

1450− , test yes yes spaceL37 space "top-level fn on space #315"

1451− , test no broken docL41 doc "documentation #7"

975+ , test no broken docL41 doc "documentation #7"

1452− , test no yes eitL40 kindE "kind of Either #273"

976+ , test no broken eitL40 kindE "kind of Either #273"

1453− , test no yes intL40 kindI "kind of Int #273"

977+ , test no broken intL40 kindI "kind of Int #273"

1454− , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"

978+ , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"

1455− , test no yes intL41 litI "literal Int in hover info #274"

979+ , test no broken intL41 litI "literal Int in hover info #274"

1456− , test no yes chrL36 litC "literal Char in hover info #274"

980+ , test no broken chrL36 litC "literal Char in hover info #274"

1457− , test no yes txtL8 litT "literal Text in hover info #274"

981+ , test no broken txtL8 litT "literal Text in hover info #274"

1458− , test no yes lstL43 litL "literal List in hover info #274"

982+ , test no broken lstL43 litL "literal List in hover info #274"

1459− , test no yes docL41 constr "type constraint in hover info #283"

983+ , test no broken docL41 constr "type constraint in hover info #283"

1460− , test broken broken outL45 outSig "top-level signature #310"

1461− , test broken broken innL48 innSig "inner signature #310"

1462− , testM yes yes imported importedSig "Imported symbol"

1463− , testM yes yes reexported reexportedSig "Imported symbol (reexported)"

1464 ]

984 ]

1465 where yes, broken :: (TestTree -> Maybe TestTree)

985 where yes, broken :: (TestTree -> Maybe TestTree)

1466 yes = Just -- test should run and pass

986 yes = Just -- test should run and pass

1467 broken = Just . (`xfail` "known broken")

987 broken = Just . (`xfail` "known broken")

1468 no = const Nothing -- don't run this test at all

988 no = const Nothing -- don't run this test at all

1469

989

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−

1478pluginTests :: TestTree

990pluginTests :: TestTree

1479−pluginTests = (`xfail8101` "known broken (#556)")

1480− $ testSessionWait "plugins" $ do

991+pluginTests = testSessionWait "plugins" $ do

1481 let content =

992 let content =

1482 T.unlines

993 T.unlines

1483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"

994 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"

@@ -1491,55 +1002,13 @@ pluginTests = (`xfail8101` "known broken (#556)")

1491 , "foo :: Int -> Int -> Int"

1002 , "foo :: Int -> Int -> Int"

1492 , "foo a b = a + c"

1003 , "foo a b = a + c"

1493 ]

1004 ]

1494− _ <- createDoc "Testing.hs" "haskell" content

1005+ _ <- openDoc' "Testing.hs" "haskell" content

1495 expectDiagnostics

1006 expectDiagnostics

1496 [ ( "Testing.hs",

1007 [ ( "Testing.hs",

1497 [(DsError, (8, 14), "Variable not in scope: c")]

1008 [(DsError, (8, 14), "Variable not in scope: c")]

1498 )

1009 )

1499 ]

1010 ]

1500

1011

1501−cppTests :: TestTree

1502−cppTests =

1503− testGroup "cpp"

1504− [ testCase "cpp-error" $ do

1505− let content =

1506− T.unlines

1507− [ "{-# LANGUAGE CPP #-}",

1508− "module Testing where",

1509− "#ifdef FOO",

1510− "foo = 42"

1511− ]

1512− -- The error locations differ depending on which C-preprocessor is used.

1513− -- Some give the column number and others don't (hence -1). Assert either

1514− -- of them.

1515− (run $ expectError content (2, -1))

1516− `catch` ( \e -> do

1517− let _ = e :: HUnitFailure

1518− run $ expectError content (2, 1)

1519− )

1520− , testSessionWait "cpp-ghcide" $ do

1521− _ <- createDoc "A.hs" "haskell" $ T.unlines

1522− ["{-# LANGUAGE CPP #-}"

1523− ,"main ="

1524− ,"#ifdef __GHCIDE__"

1525− ," worked"

1526− ,"#else"

1527− ," failed"

1528− ,"#endif"

1529− ]

1530− expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])]

1531− ]

1532− where

1533− expectError :: T.Text -> Cursor -> Session ()

1534− expectError content cursor = do

1535− _ <- createDoc "Testing.hs" "haskell" content

1536− expectDiagnostics

1537− [ ( "Testing.hs",

1538− [(DsError, cursor, "error: unterminated")]

1539− )

1540− ]

1541− expectNoMoreDiagnostics 0.5

1542−

1543preprocessorTests :: TestTree

1012preprocessorTests :: TestTree

1544preprocessorTests = testSessionWait "preprocessor" $ do

1013preprocessorTests = testSessionWait "preprocessor" $ do

1545 let content =

1014 let content =

@@ -1548,43 +1017,13 @@ preprocessorTests = testSessionWait "preprocessor" $ do

1548 , "module Testing where"

1017 , "module Testing where"

1549 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic

1018 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic

1550 ]

1019 ]

1551− _ <- createDoc "Testing.hs" "haskell" content

1020+ _ <- openDoc' "Testing.hs" "haskell" content

1552 expectDiagnostics

1021 expectDiagnostics

1553 [ ( "Testing.hs",

1022 [ ( "Testing.hs",

1554 [(DsError, (2, 8), "Variable not in scope: z")]

1023 [(DsError, (2, 8), "Variable not in scope: z")]

1555 )

1024 )

1556 ]

1025 ]

1557

1026

1558−

1559−safeTests :: TestTree

1560−safeTests =

1561− testGroup

1562− "SafeHaskell"

1563− [ -- Test for https://github.com/digital-asset/ghcide/issues/424

1564− testSessionWait "load" $ do

1565− let sourceA =

1566− T.unlines

1567− ["{-# LANGUAGE Trustworthy #-}"

1568− ,"module A where"

1569− ,"import System.IO.Unsafe"

1570− ,"import System.IO"

1571− ,"trustWorthyId :: a -> a"

1572− ,"trustWorthyId i = unsafePerformIO $ do"

1573− ," putStrLn \"I'm safe\""

1574− ," return i"]

1575− sourceB =

1576− T.unlines

1577− ["{-# LANGUAGE Safe #-}"

1578− ,"module B where"

1579− ,"import A"

1580− ,"safeId :: a -> a"

1581− ,"safeId = trustWorthyId"

1582− ]

1583−

1584− _ <- createDoc "A.hs" "haskell" sourceA

1585− _ <- createDoc "B.hs" "haskell" sourceB

1586− expectNoMoreDiagnostics 1 ]

1587−

1588thTests :: TestTree

1027thTests :: TestTree

1589thTests =

1028thTests =

1590 testGroup

1029 testGroup

@@ -1610,30 +1049,9 @@ thTests =

1610 "b :: Integer",

1049 "b :: Integer",

1611 "b = $(litE $ IntegerL $ a) + n"

1050 "b = $(litE $ IntegerL $ a) + n"

1612 ]

1051 ]

1613− _ <- createDoc "A.hs" "haskell" sourceA

1052+ _ <- openDoc' "A.hs" "haskell" sourceA

1614− _ <- createDoc "B.hs" "haskell" sourceB

1053+ _ <- openDoc' "B.hs" "haskell" sourceB

1615 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]

1054 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]

1616− , testSessionWait "newtype-closure" $ do

1617− let sourceA =

1618− T.unlines

1619− [ "{-# LANGUAGE DeriveDataTypeable #-}"

1620− ,"{-# LANGUAGE TemplateHaskell #-}"

1621− ,"module A (a) where"

1622− ,"import Data.Data"

1623− ,"import Language.Haskell.TH"

1624− ,"newtype A = A () deriving (Data)"

1625− ,"a :: ExpQ"

1626− ,"a = [| 0 |]"]

1627− let sourceB =

1628− T.unlines

1629− [ "{-# LANGUAGE TemplateHaskell #-}"

1630− ,"module B where"

1631− ,"import A"

1632− ,"b :: Int"

1633− ,"b = $( a )" ]

1634− _ <- createDoc "A.hs" "haskell" sourceA

1635− _ <- createDoc "B.hs" "haskell" sourceB

1636− return ()

1637 ]

1055 ]

1638

1056

1639completionTests :: TestTree

1057completionTests :: TestTree

@@ -1641,95 +1059,33 @@ completionTests

1641 = testGroup "completion"

1059 = testGroup "completion"

1642 [ testSessionWait "variable" $ do

1060 [ testSessionWait "variable" $ do

1643 let source = T.unlines ["module A where", "f = hea"]

1061 let source = T.unlines ["module A where", "f = hea"]

1644− docId <- createDoc "A.hs" "haskell" source

1062+ docId <- openDoc' "A.hs" "haskell" source

1645 compls <- getCompletions docId (Position 1 7)

1063 compls <- getCompletions docId (Position 1 7)

1646− liftIO $ map dropDocs compls @?=

1064+ liftIO $ compls @?= [complItem "head" ["GHC.List", "base", "v", "head"] (Just CiFunction)]

1647− [complItem "head" (Just CiFunction) (Just "[a] -> a")]

1648− let [CompletionItem { _documentation = headDocs}] = compls

1649− checkDocText "head" headDocs [ "Defined in 'Prelude'"

1650−#if MIN_GHC_API_VERSION(8,6,5)

1651− , "Extract the first element of a list"

1652−#endif

1653− ]

1654− , testSessionWait "constructor" $ do

1655− let source = T.unlines ["module A where", "f = Tru"]

1656− docId <- createDoc "A.hs" "haskell" source

1657− compls <- getCompletions docId (Position 1 7)

1658− liftIO $ map dropDocs compls @?=

1659− [ complItem "True" (Just CiConstructor) (Just "Bool")

1660−#if MIN_GHC_API_VERSION(8,6,0)

1661− , complItem "truncate" (Just CiFunction) (Just "(RealFrac a, Integral b) => a -> b")

1662−#else

1663− , complItem "truncate" (Just CiFunction) (Just "RealFrac a => forall b. Integral b => a -> b")

1664−#endif

1665− ]

1666 , testSessionWait "type" $ do

1065 , testSessionWait "type" $ do

1667 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]

1066 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]

1668− docId <- createDoc "A.hs" "haskell" source

1067+ docId <- openDoc' "A.hs" "haskell" source

1669 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]

1068 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]

1670 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]

1069 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]

1671 compls <- getCompletions docId (Position 2 7)

1070 compls <- getCompletions docId (Position 2 7)

1672− liftIO $ map dropDocs compls @?=

1071+ liftIO $ compls @?=

1673− [ complItem "Bounded" (Just CiClass) (Just "* -> Constraint")

1072+ [ complItem "Bounded" ["GHC.Enum", "base", "t", "Bounded"] (Just CiClass)

1674− , complItem "Bool" (Just CiStruct) (Just "*") ]

1073+ , complItem "Bool" ["GHC.Types", "ghc-prim", "t", "Bool"] (Just CiClass)

1675− let [ CompletionItem { _documentation = boundedDocs},

1074+ ]

1676− CompletionItem { _documentation = boolDocs } ] = compls

1677− checkDocText "Bounded" boundedDocs [ "Defined in 'Prelude'"

1678−#if MIN_GHC_API_VERSION(8,6,5)

1679− , "name the upper and lower limits"

1680−#endif

1681− ]

1682− checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]

1683 , testSessionWait "qualified" $ do

1075 , testSessionWait "qualified" $ do

1684 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]

1076 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]

1685− docId <- createDoc "A.hs" "haskell" source

1077+ docId <- openDoc' "A.hs" "haskell" source

1686 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]

1078 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]

1687 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]

1079 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]

1688 compls <- getCompletions docId (Position 2 15)

1080 compls <- getCompletions docId (Position 2 15)

1689− liftIO $ map dropDocs compls @?=

1690− [complItem "head" (Just CiFunction) (Just "[a] -> a")]

1081+ liftIO $ compls @?= [complItem "head" ["GHC.List", "base", "v", "head"] (Just CiFunction)]

1691− let [CompletionItem { _documentation = headDocs}] = compls

1692− checkDocText "head" headDocs [ "Defined in 'Prelude'"

1693−#if MIN_GHC_API_VERSION(8,6,5)

1694− , "Extract the first element of a list"

1695−#endif

1696− ]

1697− , testSessionWait "keyword" $ do

1698− let source = T.unlines ["module A where", "f = newty"]

1699− docId <- createDoc "A.hs" "haskell" source

1700− compls <- getCompletions docId (Position 1 9)

1701− liftIO $ compls @?= [keywordItem "newtype"]

1702− , testSessionWait "type context" $ do

1703− let source = T.unlines

1704− [ "{-# OPTIONS_GHC -Wunused-binds #-}"

1705− , "module A () where"

1706− , "f = f"

1707− ]

1708− docId <- createDoc "A.hs" "haskell" source

1709− expectDiagnostics [("A.hs", [(DsWarning, (2, 0), "not used")])]

1710− changeDoc docId

1711− [ TextDocumentContentChangeEvent Nothing Nothing $ T.unlines

1712− [ "{-# OPTIONS_GHC -Wunused-binds #-}"

1713− , "module A () where"

1714− , "f = f"

1715− , "g :: Intege"

1716− ]

1717− ]

1718− -- At this point the module parses but does not typecheck.

1719− -- This should be sufficient to detect that we are in a

1720− -- type context and only show the completion to the type.

1721− compls <- getCompletions docId (Position 3 11)

1722− liftIO $ map dropDocs compls @?= [complItem "Integer"(Just CiStruct) (Just "*")]

1723 ]

1082 ]

1724 where

1083 where

1725− dropDocs :: CompletionItem -> CompletionItem

1726− dropDocs ci = ci { _documentation = Nothing }

1727− complItem label kind ty = CompletionItem

1084+ complItem label xdata kind = CompletionItem

1728 { _label = label

1085 { _label = label

1729 , _kind = kind

1086 , _kind = kind

1730− , _tags = List []

1731− , _detail = (":: " <>) <$> ty

1087+ , _detail = Just "Prelude"

1732− , _documentation = Nothing

1088+ , _documentation = Just (CompletionDocMarkup (MarkupContent {_kind = MkMarkdown, _value = ""}))

1733 , _deprecated = Nothing

1089 , _deprecated = Nothing

1734 , _preselect = Nothing

1090 , _preselect = Nothing

1735 , _sortText = Nothing

1091 , _sortText = Nothing

@@ -1740,40 +1096,15 @@ completionTests

1740 , _additionalTextEdits = Nothing

1096 , _additionalTextEdits = Nothing

1741 , _commitCharacters = Nothing

1097 , _commitCharacters = Nothing

1742 , _command = Nothing

1098 , _command = Nothing

1743− , _xdata = Nothing

1099+ , _xdata = Just (Aeson.toJSON (xdata :: [T.Text]))

1744 }

1100 }

1745− keywordItem label = CompletionItem

1746− { _label = label

1747− , _kind = Just CiKeyword

1748− , _tags = List []

1749− , _detail = Nothing

1750− , _documentation = Nothing

1751− , _deprecated = Nothing

1752− , _preselect = Nothing

1753− , _sortText = Nothing

1754− , _filterText = Nothing

1755− , _insertText = Nothing

1756− , _insertTextFormat = Nothing

1757− , _textEdit = Nothing

1758− , _additionalTextEdits = Nothing

1759− , _commitCharacters = Nothing

1760− , _command = Nothing

1761− , _xdata = Nothing

1762− }

1763− getDocText (CompletionDocString s) = s

1764− getDocText (CompletionDocMarkup (MarkupContent _ s)) = s

1765− checkDocText thing Nothing _

1766− = liftIO $ assertFailure $ "docs for " ++ thing ++ " not found"

1767− checkDocText thing (Just doc) items

1768− = liftIO $ assertBool ("docs for " ++ thing ++ " contain the strings") $

1769− all (`T.isInfixOf` getDocText doc) items

1770

1101

1771outlineTests :: TestTree

1102outlineTests :: TestTree

1772outlineTests = testGroup

1103outlineTests = testGroup

1773 "outline"

1104 "outline"

1774 [ testSessionWait "type class" $ do

1105 [ testSessionWait "type class" $ do

1775 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]

1106 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]

1776− docId <- createDoc "A.hs" "haskell" source

1107+ docId <- openDoc' "A.hs" "haskell" source

1777 symbols <- getDocumentSymbols docId

1108 symbols <- getDocumentSymbols docId

1778 liftIO $ symbols @?= Left

1109 liftIO $ symbols @?= Left

1779 [ moduleSymbol

1110 [ moduleSymbol

@@ -1786,7 +1117,7 @@ outlineTests = testGroup

1786 ]

1117 ]

1787 , testSessionWait "type class instance " $ do

1118 , testSessionWait "type class instance " $ do

1788 let source = T.unlines ["class A a where", "instance A () where"]

1119 let source = T.unlines ["class A a where", "instance A () where"]

1789− docId <- createDoc "A.hs" "haskell" source

1120+ docId <- openDoc' "A.hs" "haskell" source

1790 symbols <- getDocumentSymbols docId

1121 symbols <- getDocumentSymbols docId

1791 liftIO $ symbols @?= Left

1122 liftIO $ symbols @?= Left

1792 [ classSymbol "A a" (R 0 0 0 15) []

1123 [ classSymbol "A a" (R 0 0 0 15) []

@@ -1794,7 +1125,7 @@ outlineTests = testGroup

1794 ]

1125 ]

1795 , testSessionWait "type family" $ do

1126 , testSessionWait "type family" $ do

1796 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]

1127 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]

1797− docId <- createDoc "A.hs" "haskell" source

1128+ docId <- openDoc' "A.hs" "haskell" source

1798 symbols <- getDocumentSymbols docId

1129 symbols <- getDocumentSymbols docId

1799 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]

1130 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]

1800 , testSessionWait "type family instance " $ do

1131 , testSessionWait "type family instance " $ do

@@ -1803,7 +1134,7 @@ outlineTests = testGroup

1803 , "type family A a"

1134 , "type family A a"

1804 , "type instance A () = ()"

1135 , "type instance A () = ()"

1805 ]

1136 ]

1806− docId <- createDoc "A.hs" "haskell" source

1137+ docId <- openDoc' "A.hs" "haskell" source

1807 symbols <- getDocumentSymbols docId

1138 symbols <- getDocumentSymbols docId

1808 liftIO $ symbols @?= Left

1139 liftIO $ symbols @?= Left

1809 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)

1140 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)

@@ -1811,7 +1142,7 @@ outlineTests = testGroup

1811 ]

1142 ]

1812 , testSessionWait "data family" $ do

1143 , testSessionWait "data family" $ do

1813 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]

1144 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]

1814− docId <- createDoc "A.hs" "haskell" source

1145+ docId <- openDoc' "A.hs" "haskell" source

1815 symbols <- getDocumentSymbols docId

1146 symbols <- getDocumentSymbols docId

1816 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]

1147 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]

1817 , testSessionWait "data family instance " $ do

1148 , testSessionWait "data family instance " $ do

@@ -1820,7 +1151,7 @@ outlineTests = testGroup

1820 , "data family A a"

1151 , "data family A a"

1821 , "data instance A () = A ()"

1152 , "data instance A () = A ()"

1822 ]

1153 ]

1823− docId <- createDoc "A.hs" "haskell" source

1154+ docId <- openDoc' "A.hs" "haskell" source

1824 symbols <- getDocumentSymbols docId

1155 symbols <- getDocumentSymbols docId

1825 liftIO $ symbols @?= Left

1156 liftIO $ symbols @?= Left

1826 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)

1157 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)

@@ -1828,36 +1159,36 @@ outlineTests = testGroup

1828 ]

1159 ]

1829 , testSessionWait "constant" $ do

1160 , testSessionWait "constant" $ do

1830 let source = T.unlines ["a = ()"]

1161 let source = T.unlines ["a = ()"]

1831− docId <- createDoc "A.hs" "haskell" source

1162+ docId <- openDoc' "A.hs" "haskell" source

1832 symbols <- getDocumentSymbols docId

1163 symbols <- getDocumentSymbols docId

1833 liftIO $ symbols @?= Left

1164 liftIO $ symbols @?= Left

1834 [docSymbol "a" SkFunction (R 0 0 0 6)]

1165 [docSymbol "a" SkFunction (R 0 0 0 6)]

1835 , testSessionWait "pattern" $ do

1166 , testSessionWait "pattern" $ do

1836 let source = T.unlines ["Just foo = Just 21"]

1167 let source = T.unlines ["Just foo = Just 21"]

1837− docId <- createDoc "A.hs" "haskell" source

1168+ docId <- openDoc' "A.hs" "haskell" source

1838 symbols <- getDocumentSymbols docId

1169 symbols <- getDocumentSymbols docId

1839 liftIO $ symbols @?= Left

1170 liftIO $ symbols @?= Left

1840 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]

1171 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]

1841 , testSessionWait "pattern with type signature" $ do

1172 , testSessionWait "pattern with type signature" $ do

1842 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]

1173 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]

1843− docId <- createDoc "A.hs" "haskell" source

1174+ docId <- openDoc' "A.hs" "haskell" source

1844 symbols <- getDocumentSymbols docId

1175 symbols <- getDocumentSymbols docId

1845 liftIO $ symbols @?= Left

1176 liftIO $ symbols @?= Left

1846 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]

1177 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]

1847 , testSessionWait "function" $ do

1178 , testSessionWait "function" $ do

1848 let source = T.unlines ["a x = ()"]

1179 let source = T.unlines ["a x = ()"]

1849− docId <- createDoc "A.hs" "haskell" source

1180+ docId <- openDoc' "A.hs" "haskell" source

1850 symbols <- getDocumentSymbols docId

1181 symbols <- getDocumentSymbols docId

1851 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]

1182 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]

1852 , testSessionWait "type synonym" $ do

1183 , testSessionWait "type synonym" $ do

1853 let source = T.unlines ["type A = Bool"]

1184 let source = T.unlines ["type A = Bool"]

1854− docId <- createDoc "A.hs" "haskell" source

1185+ docId <- openDoc' "A.hs" "haskell" source

1855 symbols <- getDocumentSymbols docId

1186 symbols <- getDocumentSymbols docId

1856 liftIO $ symbols @?= Left

1187 liftIO $ symbols @?= Left

1857 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]

1188 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]

1858 , testSessionWait "datatype" $ do

1189 , testSessionWait "datatype" $ do

1859 let source = T.unlines ["data A = C"]

1190 let source = T.unlines ["data A = C"]

1860− docId <- createDoc "A.hs" "haskell" source

1191+ docId <- openDoc' "A.hs" "haskell" source

1861 symbols <- getDocumentSymbols docId

1192 symbols <- getDocumentSymbols docId

1862 liftIO $ symbols @?= Left

1193 liftIO $ symbols @?= Left

1863 [ docSymbolWithChildren "A"

1194 [ docSymbolWithChildren "A"

@@ -1865,47 +1196,18 @@ outlineTests = testGroup

1865 (R 0 0 0 10)

1196 (R 0 0 0 10)

1866 [docSymbol "C" SkConstructor (R 0 9 0 10)]

1197 [docSymbol "C" SkConstructor (R 0 9 0 10)]

1867 ]

1198 ]

1868− , testSessionWait "record fields" $ do

1869− let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"]

1870− docId <- createDoc "A.hs" "haskell" source

1871− symbols <- getDocumentSymbols docId

1872− liftIO $ symbols @=? Left

1873− [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13)

1874− [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10)

1875− [ docSymbol "x" SkField (R 1 2 1 3)

1876− , docSymbol "y" SkField (R 2 4 2 5)

1877− ]

1878− ]

1879− ]

1880 , testSessionWait "import" $ do

1199 , testSessionWait "import" $ do

1881 let source = T.unlines ["import Data.Maybe"]

1200 let source = T.unlines ["import Data.Maybe"]

1882− docId <- createDoc "A.hs" "haskell" source

1201+ docId <- openDoc' "A.hs" "haskell" source

1883 symbols <- getDocumentSymbols docId

1202 symbols <- getDocumentSymbols docId

1884 liftIO $ symbols @?= Left

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

1204+ [docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)]

1889− ]

1890− ]

1891− , testSessionWait "multiple import" $ do

1892− let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]

1893− docId <- createDoc "A.hs" "haskell" source

1894− symbols <- getDocumentSymbols docId

1895− liftIO $ symbols @?= Left

1896− [docSymbolWithChildren "imports"

1897− SkModule

1898− (R 1 0 3 24)

1899− [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 17)

1900− , docSymbol "import Control.Exception" SkModule (R 3 0 3 24)

1901− ]

1902− ]

1903 , testSessionWait "foreign import" $ do

1205 , testSessionWait "foreign import" $ do

1904 let source = T.unlines

1206 let source = T.unlines

1905 [ "{-# language ForeignFunctionInterface #-}"

1207 [ "{-# language ForeignFunctionInterface #-}"

1906 , "foreign import ccall \"a\" a :: Int"

1208 , "foreign import ccall \"a\" a :: Int"

1907 ]

1209 ]

1908− docId <- createDoc "A.hs" "haskell" source

1210+ docId <- openDoc' "A.hs" "haskell" source

1909 symbols <- getDocumentSymbols docId

1211 symbols <- getDocumentSymbols docId

1910 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]

1212 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]

1911 , testSessionWait "foreign export" $ do

1213 , testSessionWait "foreign export" $ do

@@ -1913,7 +1215,7 @@ outlineTests = testGroup

1913 [ "{-# language ForeignFunctionInterface #-}"

1215 [ "{-# language ForeignFunctionInterface #-}"

1914 , "foreign export ccall odd :: Int -> Bool"

1216 , "foreign export ccall odd :: Int -> Bool"

1915 ]

1217 ]

1916− docId <- createDoc "A.hs" "haskell" source

1218+ docId <- openDoc' "A.hs" "haskell" source

1917 symbols <- getDocumentSymbols docId

1219 symbols <- getDocumentSymbols docId

1918 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]

1220 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]

1919 ]

1221 ]

@@ -1926,8 +1228,6 @@ outlineTests = testGroup

1926 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing

1228 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing

1927 docSymbolWithChildren name kind loc cc =

1229 docSymbolWithChildren name kind loc cc =

1928 DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)

1230 DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)

1929− docSymbolWithChildren' name kind loc selectionLoc cc =

1930− DocumentSymbol name Nothing kind Nothing loc selectionLoc (Just $ List cc)

1931 moduleSymbol name loc cc = DocumentSymbol name

1231 moduleSymbol name loc cc = DocumentSymbol name

1932 Nothing

1232 Nothing

1933 SkFile

1233 SkFile

@@ -1949,247 +1249,16 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')

1949xfail :: TestTree -> String -> TestTree

1249xfail :: TestTree -> String -> TestTree

1950xfail = flip expectFailBecause

1250xfail = flip expectFailBecause

1951

1251

1952−xfail8101 :: TestTree -> String -> TestTree

1953−#if MIN_GHC_API_VERSION(8,10,0)

1954−xfail8101 = flip expectFailBecause

1955−#else

1956−xfail8101 t _ = t

1957−#endif

1958−

1959data Expect

1252data Expect

1960 = ExpectRange Range -- Both gotoDef and hover should report this range

1253 = ExpectRange Range -- Both gotoDef and hover should report this range

1961− | ExpectLocation Location

1962-- | ExpectDefRange Range -- Only gotoDef should report this range

1254-- | ExpectDefRange Range -- Only gotoDef should report this range

1963 | ExpectHoverRange Range -- Only hover should report this range

1255 | ExpectHoverRange Range -- Only hover should report this range

1964 | ExpectHoverText [T.Text] -- the hover message must contain these snippets

1256 | ExpectHoverText [T.Text] -- the hover message must contain these snippets

1965 | ExpectExternFail -- definition lookup in other file expected to fail

1257 | ExpectExternFail -- definition lookup in other file expected to fail

1966− | ExpectNoDefinitions

1967− | ExpectNoHover

1968-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples

1258-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples

1969− deriving Eq

1970

1259

1971mkR :: Int -> Int -> Int -> Int -> Expect

1260mkR :: Int -> Int -> Int -> Int -> Expect

1972mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn

1261mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn

1973−

1974−mkL :: Uri -> Int -> Int -> Int -> Int -> Expect

1975−mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn

1976−

1977−haddockTests :: TestTree

1978−haddockTests

1979− = testGroup "haddock"

1980− [ testCase "Num" $ checkHaddock

1981− (unlines

1982− [ "However, '(+)' and '(*)' are"

1983− , "customarily expected to define a ring and have the following properties:"

1984− , ""

1985− , "[__Associativity of (+)__]: @(x + y) + z@ = @x + (y + z)@"

1986− , "[__Commutativity of (+)__]: @x + y@ = @y + x@"

1987− , "[__@fromInteger 0@ is the additive identity__]: @x + fromInteger 0@ = @x@"

1988− ]

1989− )

1990− (unlines

1991− [ ""

1992− , ""

1993− , "However, `(+)` and `(*)` are"

1994− , "customarily expected to define a ring and have the following properties: "

1995− , "+ ****Associativity of (+)****: `(x + y) + z` = `x + (y + z)`"

1996− , "+ ****Commutativity of (+)****: `x + y` = `y + x`"

1997− , "+ ****`fromInteger 0` is the additive identity****: `x + fromInteger 0` = `x`"

1998− ]

1999− )

2000− , testCase "unsafePerformIO" $ checkHaddock

2001− (unlines

2002− [ "may require"

2003− , "different precautions:"

2004− , ""

2005− , " * Use @{\\-\\# NOINLINE foo \\#-\\}@ as a pragma on any function @foo@"

2006− , " that calls 'unsafePerformIO'. If the call is inlined,"

2007− , " the I\\/O may be performed more than once."

2008− , ""

2009− , " * Use the compiler flag @-fno-cse@ to prevent common sub-expression"

2010− , " elimination being performed on the module."

2011− , ""

2012− ]

2013− )

2014− (unlines

2015− [ ""

2016− , ""

2017− , "may require"

2018− , "different precautions: "

2019− , "+ Use `{-# NOINLINE foo #-}` as a pragma on any function `foo` "

2020− , " that calls `unsafePerformIO` . If the call is inlined,"

2021− , " the I/O may be performed more than once."

2022− , ""

2023− , "+ Use the compiler flag `-fno-cse` to prevent common sub-expression"

2024− , " elimination being performed on the module."

2025− , ""

2026− ]

2027− )

2028− ]

2029− where

2030− checkHaddock s txt = spanDocToMarkdownForTest s @?= txt

2031−

2032−cradleTests :: TestTree

2033−cradleTests = testGroup "cradle"

2034− [testGroup "dependencies" [sessionDepsArePickedUp]

2035− ,testGroup "loading" [loadCradleOnlyonce]

2036− ,testGroup "multi" [simpleMultiTest, simpleMultiTest2]

2037− ]

2038−

2039−loadCradleOnlyonce :: TestTree

2040−loadCradleOnlyonce = testGroup "load cradle only once"

2041− [ testSession' "implicit" implicit

2042− , testSession' "direct" direct

2043− ]

2044− where

2045− direct dir = do

2046− liftIO $ writeFileUTF8 (dir </> "hie.yaml")

2047− "cradle: {direct: {arguments: []}}"

2048− test dir

2049− implicit dir = test dir

2050− test _dir = do

2051− doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"

2052− msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

2053− liftIO $ length msgs @?= 1

2054− changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]

2055− msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

2056− liftIO $ length msgs @?= 0

2057− _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"

2058− msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))

2059− liftIO $ length msgs @?= 0

2060−

2061−

2062−dependentFileTest :: TestTree

2063−dependentFileTest = testGroup "addDependentFile"

2064− [testGroup "file-changed" [testSession' "test" test]

2065− ]

2066− where

2067− test dir = do

2068− -- If the file contains B then no type error

2069− -- otherwise type error

2070− liftIO $ writeFile (dir </> "dep-file.txt") "A"

2071− let fooContent = T.unlines

2072− [ "{-# LANGUAGE TemplateHaskell #-}"

2073− , "module Foo where"

2074− , "import Language.Haskell.TH.Syntax"

2075− , "foo :: Int"

2076− , "foo = 1 + $(do"

2077− , " qAddDependentFile \"dep-file.txt\""

2078− , " f <- qRunIO (readFile \"dep-file.txt\")"

2079− , " if f == \"B\" then [| 1 |] else lift f)"

2080− ]

2081− let bazContent = T.unlines ["module Baz where", "import Foo"]

2082− _ <-createDoc "Foo.hs" "haskell" fooContent

2083− doc <- createDoc "Baz.hs" "haskell" bazContent

2084− expectDiagnostics

2085− [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]

2086− -- Now modify the dependent file

2087− liftIO $ writeFile (dir </> "dep-file.txt") "B"

2088− let change = TextDocumentContentChangeEvent

2089− { _range = Just (Range (Position 2 0) (Position 2 6))

2090− , _rangeLength = Nothing

2091− , _text = "f = ()"

2092− }

2093− -- Modifying Baz will now trigger Foo to be rebuilt as well

2094− changeDoc doc [change]

2095− expectDiagnostics [("Foo.hs", [])]

2096−

2097−

2098−cradleLoadedMessage :: Session FromServerMessage

2099−cradleLoadedMessage = satisfy $ \case

2100− NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod

2101− _ -> False

2102−

2103−cradleLoadedMethod :: T.Text

2104−cradleLoadedMethod = "ghcide/cradle/loaded"

2105−

2106−-- Stack sets this which trips up cabal in the multi-component tests.

2107−-- However, our plugin tests rely on those env vars so we unset it locally.

2108−withoutStackEnv :: IO a -> IO a

2109−withoutStackEnv s =

2110− bracket

2111− (mapM getEnv vars >>= \prevState -> mapM_ unsetEnv vars >> pure prevState)

2112− (\prevState -> mapM_ (\(var, value) -> restore var value) (zip vars prevState))

2113− (const s)

2114− where vars =

2115− [ "GHC_PACKAGE_PATH"

2116− , "GHC_ENVIRONMENT"

2117− , "HASKELL_DIST_DIR"

2118− , "HASKELL_PACKAGE_SANDBOX"

2119− , "HASKELL_PACKAGE_SANDBOXES"

2120− ]

2121− restore var Nothing = unsetEnv var

2122− restore var (Just val) = setEnv var val True

2123−

2124−simpleMultiTest :: TestTree

2125−simpleMultiTest = testCase "simple-multi-test" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do

2126− let aPath = dir </> "a/A.hs"

2127− bPath = dir </> "b/B.hs"

2128− aSource <- liftIO $ readFileUtf8 aPath

2129− (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource

2130− expectNoMoreDiagnostics 0.5

2131− bSource <- liftIO $ readFileUtf8 bPath

2132− bdoc <- createDoc bPath "haskell" bSource

2133− expectNoMoreDiagnostics 0.5

2134− locs <- getDefinitions bdoc (Position 2 7)

2135− let fooL = mkL adoc 2 0 2 3

2136− checkDefs locs (pure [fooL])

2137− expectNoMoreDiagnostics 0.5

2138−

2139−-- Like simpleMultiTest but open the files in the other order

2140−simpleMultiTest2 :: TestTree

2141−simpleMultiTest2 = testCase "simple-multi-test2" $ withoutStackEnv $ runWithExtraFiles "multi" $ \dir -> do

2142− let aPath = dir </> "a/A.hs"

2143− bPath = dir </> "b/B.hs"

2144− bSource <- liftIO $ readFileUtf8 bPath

2145− bdoc <- createDoc bPath "haskell" bSource

2146− expectNoMoreDiagnostics 5

2147− aSource <- liftIO $ readFileUtf8 aPath

2148− (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource

2149− -- Need to have some delay here or the test fails

2150− expectNoMoreDiagnostics 5

2151− locs <- getDefinitions bdoc (Position 2 7)

2152− let fooL = mkL adoc 2 0 2 3

2153− checkDefs locs (pure [fooL])

2154− expectNoMoreDiagnostics 0.5

2155−

2156−sessionDepsArePickedUp :: TestTree

2157−sessionDepsArePickedUp = testSession'

2158− "session-deps-are-picked-up"

2159− $ \dir -> do

2160− liftIO $

2161− writeFileUTF8

2162− (dir </> "hie.yaml")

2163− "cradle: {direct: {arguments: []}}"

2164− -- Open without OverloadedStrings and expect an error.

2165− doc <- createDoc "Foo.hs" "haskell" fooContent

2166− expectDiagnostics

2167− [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])]

2168− -- Update hie.yaml to enable OverloadedStrings.

2169− liftIO $

2170− writeFileUTF8

2171− (dir </> "hie.yaml")

2172− "cradle: {direct: {arguments: [-XOverloadedStrings]}}"

2173− -- Send change event.

2174− let change =

2175− TextDocumentContentChangeEvent

2176− { _range = Just (Range (Position 4 0) (Position 4 0)),

2177− _rangeLength = Nothing,

2178− _text = "\n"

2179− }

2180− changeDoc doc [change]

2181− -- Now no errors.

2182− expectDiagnostics [("Foo.hs", [])]

2183− where

2184− fooContent =

2185− T.unlines

2186− [ "module Foo where",

2187− "import Data.Text",

2188− "foo :: Text",

2189− "foo = \"hello\""

2190− ]

2191−

2192−

2193----------------------------------------------------------------------

1262----------------------------------------------------------------------

2194-- Utils

1263-- Utils

2195

1264

@@ -2197,12 +1266,6 @@ sessionDepsArePickedUp = testSession'

2197testSession :: String -> Session () -> TestTree

1266testSession :: String -> Session () -> TestTree

2198testSession name = testCase name . run

1267testSession name = testCase name . run

2199

1268

2200−testSessionWithExtraFiles :: FilePath -> String -> (FilePath -> Session ()) -> TestTree

2201−testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix

2202−

2203−testSession' :: String -> (FilePath -> Session ()) -> TestTree

2204−testSession' name = testCase name . run'

2205−

2206testSessionWait :: String -> Session () -> TestTree

1269testSessionWait :: String -> Session () -> TestTree

2207testSessionWait name = testSession name .

1270testSessionWait name = testSession name .

2208 -- Check that any diagnostics produced were already consumed by the test case.

1271 -- Check that any diagnostics produced were already consumed by the test case.

@@ -2213,284 +1276,42 @@ testSessionWait name = testSession name .

2213 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.

1276 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.

2214 ( >> expectNoMoreDiagnostics 0.5)

1277 ( >> expectNoMoreDiagnostics 0.5)

2215

1278

2216−pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction

1279+pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction

2217−pickActionWithTitle title actions = do

1280+pickActionWithTitle title actions = head

2218− assertBool ("Found no matching actions: " <> show titles) (not $ null matches)

2219− return $ head matches

2220− where

2221− titles =

2222− [ actionTitle

2223− | CACodeAction CodeAction { _title = actionTitle } <- actions

2224− ]

2225− matches =

2226− [ action

1281+ [ action

2227− | CACodeAction action@CodeAction { _title = actionTitle } <- actions

1282+ | CACodeAction action@CodeAction{ _title = actionTitle } <- actions

2228− , title == actionTitle

1283+ , title == actionTitle ]

2229− ]

2230

1284

2231mkRange :: Int -> Int -> Int -> Int -> Range

1285mkRange :: Int -> Int -> Int -> Int -> Range

2232mkRange a b c d = Range (Position a b) (Position c d)

1286mkRange a b c d = Range (Position a b) (Position c d)

2233

1287

2234run :: Session a -> IO a

1288run :: Session a -> IO a

2235−run s = withTempDir $ \dir -> runInDir dir s

1289+run s = withTempDir $ \dir -> do

2236−

2237−runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a

2238−runWithExtraFiles prefix s = withTempDir $ \dir -> do

2239− copyTestDataFiles dir prefix

2240− runInDir dir (s dir)

2241−

2242−copyTestDataFiles :: FilePath -> FilePath -> IO ()

2243−copyTestDataFiles dir prefix = do

2244− -- Copy all the test data files to the temporary workspace

2245− testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]

2246− for_ testDataFiles $ \f -> do

2247− createDirectoryIfMissing True $ dir </> takeDirectory f

2248− copyFile ("test/data" </> prefix </> f) (dir </> f)

2249−

2250−run' :: (FilePath -> Session a) -> IO a

2251−run' s = withTempDir $ \dir -> runInDir dir (s dir)

2252−

2253−runInDir :: FilePath -> Session a -> IO a

2254−runInDir dir s = do

2255 ghcideExe <- locateGhcideExecutable

1290 ghcideExe <- locateGhcideExecutable

2256

1291

2257 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56

1292 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56

2258 -- since the package import test creates "Data/List.hs", which otherwise has no physical home

1293 -- since the package import test creates "Data/List.hs", which otherwise has no physical home

2259 createDirectoryIfMissing True $ dir ++ "/Data"

1294 createDirectoryIfMissing True $ dir ++ "/Data"

2260

1295

2261−

2262− let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]

1296+ let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]

2263 -- HIE calls getXgdDirectory which assumes that HOME is set.

1297 -- HIE calls getXgdDirectory which assumes that HOME is set.

2264 -- Only sets HOME if it wasn't already set.

1298 -- Only sets HOME if it wasn't already set.

2265 setEnv "HOME" "/homeless-shelter" False

1299 setEnv "HOME" "/homeless-shelter" False

2266− let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }

1300+ runSessionWithConfig conf cmd fullCaps { _window = Just $ WindowClientCapabilities $ Just True } dir s

2267− runSessionWithConfig conf cmd lspTestCaps dir s

2268 where

1301 where

2269 conf = defaultConfig

1302 conf = defaultConfig

2270− -- If you uncomment this you can see all logging

1303+ -- If you uncomment this you can see all messages

2271 -- which can be quite useful for debugging.

1304 -- which can be quite useful for debugging.

2272− -- { logStdErr = True, logColor = False }

2273− -- If you really want to, you can also see all messages

2274− -- { logMessages = True, logColor = False }

1305+ -- { logMessages = True, logColor = False, logStdErr = True }

2275

1306

2276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier

1307openTestDataDoc :: FilePath -> Session TextDocumentIdentifier

2277openTestDataDoc path = do

1308openTestDataDoc path = do

2278 source <- liftIO $ readFileUtf8 $ "test/data" </> path

1309 source <- liftIO $ readFileUtf8 $ "test/data" </> path

2279− createDoc path "haskell" source

1310+ openDoc' path "haskell" source

2280−

2281−findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]

2282−findCodeActions doc range expectedTitles = do

2283− actions <- getCodeActions doc range

2284− let matches = sequence

2285− [ listToMaybe

2286− [ action

2287− | CACodeAction action@CodeAction { _title = actionTitle } <- actions

2288− , actionTitle == expectedTitle ]

2289− | expectedTitle <- expectedTitles]

2290− let msg = show

2291− [ actionTitle

2292− | CACodeAction CodeAction { _title = actionTitle } <- actions

2293− ]

2294− ++ " is not a superset of "

2295− ++ show expectedTitles

2296− liftIO $ case matches of

2297− Nothing -> assertFailure msg

2298− Just _ -> pure ()

2299− return (fromJust matches)

2300−

2301−findCodeAction :: TextDocumentIdentifier -> Range -> T.Text -> Session CodeAction

2302−findCodeAction doc range t = head <$> findCodeActions doc range [t]

2303

1311

2304unitTests :: TestTree

1312unitTests :: TestTree

2305unitTests = do

1313unitTests = do

2306 testGroup "Unit"

1314 testGroup "Unit"

2307− [ testCase "empty file path does NOT work with the empty String literal" $

1315+ [ testCase "empty file path" $

2308− uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "."

1316+ uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just ""

2309− , testCase "empty file path works using toNormalizedFilePath'" $

2310− uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just ""

2311− , testCase "empty path URI" $ do

2312− Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri)

2313− uriScheme @?= "file:"

2314− uriPath @?= ""

2315− , testCase "from empty path URI" $ do

2316− let uri = Uri "file://"

2317− uriToFilePath' uri @?= Just ""

2318 ]

1317 ]

2319−

2320−positionMappingTests :: TestTree

2321−positionMappingTests =

2322− testGroup "position mapping"

2323− [ testGroup "toCurrent"

2324− [ testCase "before" $

2325− toCurrent

2326− (Range (Position 0 1) (Position 0 3))

2327− "ab"

2328− (Position 0 0) @?= Just (Position 0 0)

2329− , testCase "after, same line, same length" $

2330− toCurrent

2331− (Range (Position 0 1) (Position 0 3))

2332− "ab"

2333− (Position 0 3) @?= Just (Position 0 3)

2334− , testCase "after, same line, increased length" $

2335− toCurrent

2336− (Range (Position 0 1) (Position 0 3))

2337− "abc"

2338− (Position 0 3) @?= Just (Position 0 4)

2339− , testCase "after, same line, decreased length" $

2340− toCurrent

2341− (Range (Position 0 1) (Position 0 3))

2342− "a"

2343− (Position 0 3) @?= Just (Position 0 2)

2344− , testCase "after, next line, no newline" $

2345− toCurrent

2346− (Range (Position 0 1) (Position 0 3))

2347− "abc"

2348− (Position 1 3) @?= Just (Position 1 3)

2349− , testCase "after, next line, newline" $

2350− toCurrent

2351− (Range (Position 0 1) (Position 0 3))

2352− "abc\ndef"

2353− (Position 1 0) @?= Just (Position 2 0)

2354− , testCase "after, same line, newline" $

2355− toCurrent

2356− (Range (Position 0 1) (Position 0 3))

2357− "abc\nd"

2358− (Position 0 4) @?= Just (Position 1 2)

2359− , testCase "after, same line, newline + newline at end" $

2360− toCurrent

2361− (Range (Position 0 1) (Position 0 3))

2362− "abc\nd\n"

2363− (Position 0 4) @?= Just (Position 2 1)

2364− , testCase "after, same line, newline + newline at end" $

2365− toCurrent

2366− (Range (Position 0 1) (Position 0 1))

2367− "abc"

2368− (Position 0 1) @?= Just (Position 0 4)

2369− ]

2370− , testGroup "fromCurrent"

2371− [ testCase "before" $

2372− fromCurrent

2373− (Range (Position 0 1) (Position 0 3))

2374− "ab"

2375− (Position 0 0) @?= Just (Position 0 0)

2376− , testCase "after, same line, same length" $

2377− fromCurrent

2378− (Range (Position 0 1) (Position 0 3))

2379− "ab"

2380− (Position 0 3) @?= Just (Position 0 3)

2381− , testCase "after, same line, increased length" $

2382− fromCurrent

2383− (Range (Position 0 1) (Position 0 3))

2384− "abc"

2385− (Position 0 4) @?= Just (Position 0 3)

2386− , testCase "after, same line, decreased length" $

2387− fromCurrent

2388− (Range (Position 0 1) (Position 0 3))

2389− "a"

2390− (Position 0 2) @?= Just (Position 0 3)

2391− , testCase "after, next line, no newline" $

2392− fromCurrent

2393− (Range (Position 0 1) (Position 0 3))

2394− "abc"

2395− (Position 1 3) @?= Just (Position 1 3)

2396− , testCase "after, next line, newline" $

2397− fromCurrent

2398− (Range (Position 0 1) (Position 0 3))

2399− "abc\ndef"

2400− (Position 2 0) @?= Just (Position 1 0)

2401− , testCase "after, same line, newline" $

2402− fromCurrent

2403− (Range (Position 0 1) (Position 0 3))

2404− "abc\nd"

2405− (Position 1 2) @?= Just (Position 0 4)

2406− , testCase "after, same line, newline + newline at end" $

2407− fromCurrent

2408− (Range (Position 0 1) (Position 0 3))

2409− "abc\nd\n"

2410− (Position 2 1) @?= Just (Position 0 4)

2411− , testCase "after, same line, newline + newline at end" $

2412− fromCurrent

2413− (Range (Position 0 1) (Position 0 1))

2414− "abc"

2415− (Position 0 4) @?= Just (Position 0 1)

2416− ]

2417− , adjustOption (\(QuickCheckTests i) -> QuickCheckTests (max 1000 i)) $ testGroup "properties"

2418− [ testProperty "fromCurrent r t <=< toCurrent r t" $ do

2419− -- Note that it is important to use suchThatMap on all values at once

2420− -- instead of only using it on the position. Otherwise you can get

2421− -- into situations where there is no position that can be mapped back

2422− -- for the edit which will result in QuickCheck looping forever.

2423− let gen = do

2424− rope <- genRope

2425− range <- genRange rope

2426− PrintableText replacement <- arbitrary

2427− oldPos <- genPosition rope

2428− pure (range, replacement, oldPos)

2429− forAll

2430− (suchThatMap gen

2431− (\(range, replacement, oldPos) -> (range, replacement, oldPos,) <$> toCurrent range replacement oldPos)) $

2432− \(range, replacement, oldPos, newPos) ->

2433− fromCurrent range replacement newPos === Just oldPos

2434− , testProperty "toCurrent r t <=< fromCurrent r t" $ do

2435− let gen = do

2436− rope <- genRope

2437− range <- genRange rope

2438− PrintableText replacement <- arbitrary

2439− let newRope = applyChange rope (TextDocumentContentChangeEvent (Just range) Nothing replacement)

2440− newPos <- genPosition newRope

2441− pure (range, replacement, newPos)

2442− forAll

2443− (suchThatMap gen

2444− (\(range, replacement, newPos) -> (range, replacement, newPos,) <$> fromCurrent range replacement newPos)) $

2445− \(range, replacement, newPos, oldPos) ->

2446− toCurrent range replacement oldPos === Just newPos

2447− ]

2448− ]

2449−

2450−newtype PrintableText = PrintableText { getPrintableText :: T.Text }

2451− deriving Show

2452−

2453−instance Arbitrary PrintableText where

2454− arbitrary = PrintableText . T.pack . getPrintableString <$> arbitrary

2455−

2456−

2457−genRope :: Gen Rope

2458−genRope = Rope.fromText . getPrintableText <$> arbitrary

2459−

2460−genPosition :: Rope -> Gen Position

2461−genPosition r = do

2462− row <- choose (0, max 0 $ rows - 1)

2463− let columns = Rope.columns (nthLine row r)

2464− column <- choose (0, max 0 $ columns - 1)

2465− pure $ Position row column

2466− where rows = Rope.rows r

2467−

2468−genRange :: Rope -> Gen Range

2469−genRange r = do

2470− startPos@(Position startLine startColumn) <- genPosition r

2471− let maxLineDiff = max 0 $ rows - 1 - startLine

2472− endLine <- choose (startLine, startLine + maxLineDiff)

2473− let columns = Rope.columns (nthLine endLine r)

2474− endColumn <-

2475− if startLine == endLine

2476− then choose (startColumn, columns)

2477− else choose (0, max 0 $ columns - 1)

2478− pure $ Range startPos (Position endLine endColumn)

2479− where rows = Rope.rows r

2480−

2481−-- | Get the ith line of a rope, starting from 0. Trailing newline not included.

2482−nthLine :: Int -> Rope -> Rope

2483−nthLine i r

2484− | i < 0 = error $ "Negative line number: " <> show i

2485− | i == 0 && Rope.rows r == 0 = r

2486− | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)

2487− | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r

2488−

2489−getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]

2490−getWatchedFilesSubscriptionsUntil = do

2491− msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)

2492− return

2493− [ args

2494− | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs

2495− , Registration _id WorkspaceDidChangeWatchedFiles args <- regs

2496− ]

test/src/Development/IDE/Test.hs+2−8

@@ -1,13 +1,10 @@

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

4−{-# LANGUAGE DuplicateRecordFields #-}

5−

6module Development.IDE.Test

4module Development.IDE.Test

7 ( Cursor

5 ( Cursor

8 , cursorPosition

6 , cursorPosition

9 , requireDiagnostic

7 , requireDiagnostic

10− , diagnostic

11 , expectDiagnostics

8 , expectDiagnostics

12 , expectNoMoreDiagnostics

9 , expectNoMoreDiagnostics

13 ) where

10 ) where

@@ -18,7 +15,7 @@ import Control.Monad

18import Control.Monad.IO.Class

15import Control.Monad.IO.Class

19import qualified Data.Map.Strict as Map

16import qualified Data.Map.Strict as Map

20import qualified Data.Text as T

17import qualified Data.Text as T

21−import Language.Haskell.LSP.Test hiding (message)

18+import Language.Haskell.LSP.Test hiding (message, openDoc')

22import qualified Language.Haskell.LSP.Test as LspTest

19import qualified Language.Haskell.LSP.Test as LspTest

23import Language.Haskell.LSP.Types

20import Language.Haskell.LSP.Types

24import Language.Haskell.LSP.Types.Lens as Lsp

21import Language.Haskell.LSP.Types.Lens as Lsp

@@ -80,7 +77,7 @@ expectDiagnostics expected = do

80 go m

77 go m

81 | Map.null m = pure ()

78 | Map.null m = pure ()

82 | otherwise = do

79 | otherwise = do

83− diagsNot <- skipManyTill anyMessage diagnostic

80+ diagsNot <- skipManyTill anyMessage LspTest.message :: Session PublishDiagnosticsNotification

84 let fileUri = diagsNot ^. params . uri

81 let fileUri = diagsNot ^. params . uri

85 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of

82 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of

86 Nothing -> do

83 Nothing -> do

@@ -99,9 +96,6 @@ expectDiagnostics expected = do

99 " but got " <> show actual

96 " but got " <> show actual

100 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m

97 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m

101

102−diagnostic :: Session PublishDiagnosticsNotification

103−diagnostic = LspTest.message

104−

105standardizeQuotes :: T.Text -> T.Text

99standardizeQuotes :: T.Text -> T.Text

106standardizeQuotes msg = let

100standardizeQuotes msg = let

107 repl '‘' = '\''

101 repl '‘' = '\''