b9374aa...master · ghcide

git.iko.soy/ghcide

79 files changed+11553−1758

since splitsnapshots

unifiedsplit

.azure/linux-stack.ymlnew file+63

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

1+jobs:

2+- job: ghcide_stack_linux

3+ timeoutInMinutes: 60

4+ pool:

5+ vmImage: 'ubuntu-latest'

6+ strategy:

7+ matrix:

8+ stack_810:

9+ STACK_YAML: "stack810.yaml"

10+ stack_88:

11+ STACK_YAML: "stack88.yaml"

12+ stack_86:

13+ STACK_YAML: "stack.yaml"

14+ stack_84:

15+ STACK_YAML: "stack84.yaml"

16+ stack_ghc_lib_88:

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

18+ steps:

19+ - checkout: self

20+ - task: Cache@2

21+ inputs:

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

23+ path: .azure-cache

24+ cacheHitVar: CACHE_RESTORED

25+ displayName: "Cache stack artifacts"

26+ - bash: |

27+ mkdir -p ~/.stack

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

29+ displayName: "Unpack cache"

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

31+ - bash: |

32+ ./fmt.sh

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

34+ - bash: |

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

36+ sudo apt-get update

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

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

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

40+ fi

41+ displayName: 'Install Stack'

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

43+ displayName: 'stack setup'

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

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

46+ - bash: |

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

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

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

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

51+ - bash: |

52+ mkdir -p .azure-cache

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

54+ displayName: "Pack cache"

55+ - bash: |

56+ set -euo pipefail

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

58+ curl -XPOST \

59+ -i \

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

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

62+ $(Slack.URL)

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

.azure/windows-stack.ymlnew file+68

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

1+jobs:

2+- job: ghcide_stack_windows

3+ timeoutInMinutes: 60

4+ pool:

5+ vmImage: 'windows-2019'

6+ strategy:

7+ matrix:

8+ stack_810:

9+ STACK_YAML: "stack810.yaml"

10+ stack_88:

11+ STACK_YAML: "stack88.yaml"

12+ stack_86:

13+ STACK_YAML: "stack.yaml"

14+ stack_84:

15+ STACK_YAML: "stack84.yaml"

16+ stack_ghc_lib_88:

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

18+ variables:

19+ STACK_ROOT: "C:\\sr"

20+ steps:

21+ - checkout: self

22+ - task: Cache@2

23+ inputs:

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

25+ path: .azure-cache

26+ cacheHitVar: CACHE_RESTORED

27+ displayName: "Cache stack artifacts"

28+ - bash: |

29+ mkdir -p $STACK_ROOT

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

31+ mkdir -p .stack-work

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

33+ displayName: "Unpack cache"

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

35+ - bash: |

36+ ./fmt.sh

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

38+ - bash: |

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

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

41+ mkdir -p "$STACK_ROOT"

42+ displayName: 'Install Stack'

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

44+ displayName: 'stack setup'

45+ - bash: |

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

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

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

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

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

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

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

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

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

55+ - bash: |

56+ mkdir -p .azure-cache

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

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

59+ displayName: "Pack cache"

60+ - bash: |

61+ set -euo pipefail

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

63+ curl -XPOST \

64+ -i \

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

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

67+ $(Slack.URL)

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

.editorconfignew file+11

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

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

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

4+root = true

6+[*]

7+end_of_line = LF

8+indent_style = space

9+indent_size = 4

10+trim_trailing_whitespace = true

11+insert_final_newline = true

.ghcideleted−24

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

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

2−

3−:set -XBangPatterns

4−:set -XDeriveFunctor

5−:set -XDeriveGeneric

6−:set -XGeneralizedNewtypeDeriving

7−:set -XLambdaCase

8−:set -XNamedFieldPuns

9−:set -XOverloadedStrings

10−:set -XRecordWildCards

11−:set -XScopedTypeVariables

12−:set -XStandaloneDeriving

13−:set -XTupleSections

14−:set -XTypeApplications

15−:set -XViewPatterns

16−

17−:set -package=ghc

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

19−:set -DGHC_STABLE

20−:set -Iinclude

21−:set -isrc

22−:set -iexe

23−

24−:load Main

.gitignore+4

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

44cabal.project.local

55*~

66*.lock

7+/.tasty-rerun-log

8+.vscode

9+/.hlint-*

10+bench/example

.hlint.yaml+12−2

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

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

7474

7575 # Shady extensions

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

7776 - name: CPP

7877 within:

78+ - Development.IDE.Compat

7979 - Development.IDE.Core.FileStore

8080 - Development.IDE.Core.Compile

81+ - Development.IDE.Core.Rules

8182 - Development.IDE.GHC.Compat

83+ - Development.IDE.GHC.Orphans

8284 - Development.IDE.GHC.Util

8385 - Development.IDE.Import.FindImports

84− - Development.IDE.LSP.CodeAction

86+ - Development.IDE.LSP.Outline

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

8693 - Main

8794

8895- flags:

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

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

95102#

96103- functions:

104+ # Things that are unsafe in Haskell base library

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

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

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

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

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

100110

101111# Add custom hints for this project

102112#

CHANGELOG.md+57

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

11### unreleased

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

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

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

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

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

9+ files) (thanks @jinwoo)

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

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

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

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

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

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

16+ @pepeiborra)

17+* Minor improvements to completions

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

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

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

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

22+

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+

360### 0.0.5 (2019-12-12)

461

562* Support for GHC plugins (see #192)

README.md+87−6

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

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

2626| Remove redundant imports, replace suggested typos for values and module imports, fill type holes, insert missing type signatures, add suggested ghc extensions | codeAction (quickfix) |

2727

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+

2845## Using it

2946

3047### Install `ghcide`

3148

3249#### With Nix

3350

34−[See ghcide-nix repository](https://github.com/hercules-ci/ghcide-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)

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

3562

3663#### With Cabal or Stack

3764

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

6491

6592If 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.

6693

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+

6798### Using with VS Code

6899

69100You can install the VSCode extension from the [VSCode

70101marketplace](https://marketplace.visualstudio.com/items?itemName=DigitalAssetHoldingsLLC.ghcide).

71102

103+### Using with Atom

104+

105+You can follow the [instructions](https://github.com/moodmosaic/ide-haskell-ghcide#readme) to install with `apm`.

106+

107+### Using with Sublime Text

108+

109+* Install [LSP](https://packagecontrol.io/packages/LSP)

110+* Press Ctrl+Shift+P or Cmd+Shift+P in Sublime Text and search for *Preferences: LSP Settings*, then paste these settings

111+```

112+{

113+ "clients":

114+ {

115+ "ghcide":

116+ {

117+ "enabled" : true,

118+ "languageId": "haskell",

119+ "command" : ["ghcide", "--lsp"],

120+ "scopes" : ["source.haskell"],

121+ "syntaxes" : ["Packages/Haskell/Haskell.sublime-syntax"]

122+ }

123+ }

124+}

125+```

126+

72127### Using with Emacs

73128

74129If you don't already have [MELPA](https://melpa.org/#/) package installation configured, visit MELPA [getting started](https://melpa.org/#/getting-started) page to get set up. Then, install [`use-package`](https://melpa.org/#/use-package).

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

179234```

180235

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

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

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

238+

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

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

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

183242

184243### SpaceVim

185244

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

200259{

201260 "languageserver": {

202261 "haskell": {

203− "command": "stack",

262+ "command": "ghcide",

204263 "args": [

205− "exec",

206− "ghcide",

207264 "--lsp"

208265 ],

209266 "rootPatterns": [

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

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

227284using `stack install ghcide` within a project.

228285

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+

229300## Hacking on ghcide

230301

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

232303running `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.

233312

234313### Building the extension

235314

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

246325

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

248327

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+

249330The 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).

250331

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

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

252333

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

azure-pipelines.yml+3−184

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

44 branches:

55 include:

66 - master

7+ - azure*

89# Enable PR triggers that target the master branch

910pr:

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

1314 - master

1415

1516jobs:

16− - job: ghcide_stack_86

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

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

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

bench/Main.hsnew file+287

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

1+{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE ExistentialQuantification #-}

3+{-# LANGUAGE ImplicitParams #-}

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

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

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

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

11+

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

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

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

15+

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

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

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

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

20+

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

22+

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

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

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

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

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

28+

29+ How to run:

30+ 1. `cabal bench`

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

32+

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

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

35+ produce the same results.

36+

37+ -}

38+

39+import Control.Applicative.Combinators

40+import Control.Concurrent

41+import Control.Exception.Safe

42+import Control.Monad.Extra

43+import Control.Monad.IO.Class

44+import Data.Aeson

45+import Data.List

46+import Data.Maybe

47+import Data.Version

48+import Language.Haskell.LSP.Test

49+import Language.Haskell.LSP.Types

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

51+import Numeric.Natural

52+import Options.Applicative

53+import System.Directory

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

55+import System.Process

56+import System.Time.Extra

57+

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

59+-- convenient for hygienic edits

60+hygienicP :: Position

61+hygienicP = Position 854 23

62+

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

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

65+identifierP :: Position

66+identifierP = Position 853 12

67+

68+main :: IO ()

69+main = do

70+ config <- execParser $ info configP fullDesc

71+ let ?config = config

72+

73+ output "starting test"

74+

75+ cleanUp <- setup

76+

77+ runBenchmarks

78+ [ ---------------------------------------------------------------------------------------

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

80+ isJust <$> getHover doc identifierP,

81+ ---------------------------------------------------------------------------------------

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

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

84+ ---------------------------------------------------------------------------------------

85+ bench "documentSymbols" 100 $

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

87+ ---------------------------------------------------------------------------------------

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

89+ let change =

90+ TextDocumentContentChangeEvent

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

92+ _rangeLength = Nothing,

93+ _text = " "

94+ }

95+ changeDoc doc [change]

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

97+ ---------------------------------------------------------------------------------------

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

99+ let change =

100+ TextDocumentContentChangeEvent

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

102+ _rangeLength = Nothing,

103+ _text = " "

104+ }

105+ changeDoc doc [change]

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

107+ ---------------------------------------------------------------------------------------

108+ benchWithSetup

109+ "code actions"

110+ 10

111+ ( \doc -> do

112+ let p = identifierP

113+ let change =

114+ TextDocumentContentChangeEvent

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

116+ _rangeLength = Nothing,

117+ _text = "a"

118+ }

119+ changeDoc doc [change]

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

121+ return p

122+ )

123+ ( \p doc -> do

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

125+ ),

126+ ---------------------------------------------------------------------------------------

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

128+ let p = identifierP

129+ let change =

130+ TextDocumentContentChangeEvent

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

132+ _rangeLength = Nothing,

133+ _text = "a"

134+ }

135+ changeDoc doc [change]

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

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

138+ ]

139+ `finally` cleanUp

140+

141+---------------------------------------------------------------------------------------------

142+

143+examplePackageName :: String

144+examplePackageName = "Cabal"

145+

146+examplePackageVersion :: Version

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

148+

149+examplePackage :: String

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

151+

152+exampleModulePath :: FilePath

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

154+

155+examplesPath :: FilePath

156+examplesPath = "bench/example"

157+

158+data Config = Config

159+ { verbose :: !Bool,

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

161+ shakeProfiling :: !(Maybe FilePath),

162+ outputCSV :: !Bool

163+ }

164+

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

166+

167+configP :: Parser Config

168+configP = Config

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

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

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

172+

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

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

175+

176+---------------------------------------------------------------------------------------

177+

178+type Experiment = TextDocumentIdentifier -> Session Bool

179+

180+data Bench = forall setup.

181+ Bench

182+ { name :: !String,

183+ samples :: !Natural,

184+ benchSetup :: TextDocumentIdentifier -> Session setup,

185+ experiment :: setup -> Experiment

186+ }

187+

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

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

190+ where

191+ experiment () = userExperiment

192+ benchSetup _ = return ()

193+

194+benchWithSetup ::

195+ String ->

196+ Natural ->

197+ (TextDocumentIdentifier -> Session p) ->

198+ (p -> Experiment) ->

199+ Bench

200+benchWithSetup = Bench

201+

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

203+runBenchmarks benchmarks = do

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

205+

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

207+ output $

208+ "TOTAL "

209+ <> name

210+ <> " = "

211+ <> showDuration duration

212+ <> " ("

213+ <> show samples

214+ <> " repetitions)"

215+

216+ when (outputCSV ?config) $ do

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

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

219+

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

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

222+ $ runSessionWithConfig conf cmd lspTestCaps dir

223+ $ do

224+ doc <- openDoc exampleModulePath "haskell"

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

226+

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

228+ userState <- benchSetup doc

229+ let loop 0 = return True

230+ loop n = do

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

232+ if not res

233+ then return False

234+ else do

235+ output (showDuration t)

236+ loop (n -1)

237+

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

239+

240+ exitServer

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

242+ liftIO $ threadDelay 50000

243+

244+ return $ if res then t else -1

245+ where

246+ cmd =

247+ unwords $

248+ [ "ghcide",

249+ "--lsp",

250+ "--cwd",

251+ dir,

252+ "+RTS",

253+ "-S",

254+ "-RTS"

255+ ]

256+ ++ concat

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

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

259+ ]

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

261+ lspTestCaps =

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

263+ conf =

264+ defaultConfig

265+ { logStdErr = verbose ?config,

266+ logMessages = False,

267+ logColor = False

268+ }

269+

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

271+setup = do

272+ alreadyExists <- doesDirectoryExist examplesPath

273+ when alreadyExists $ removeDirectoryRecursive examplesPath

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

275+ writeFile

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

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

278+

279+ whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True

280+

281+ return $ removeDirectoryRecursive examplesPath

282+

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

284+exitServer :: Session ()

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

286+

287+--------------------------------------------------------------------------------------------

docs/Setup.md+38−1

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

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

5555```

5656

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+

5768## ghc: readCreateProcess: does not exist

5869

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

71+

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

6073

6174And we figured a hack around for this:

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

6982

7083## Could not find module ...

7184

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

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

86+

87+## Ambiguous main module

88+

89+```console

90+$ stack exec ghcide

91+

92+...

93+

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

95+```

96+

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

98+

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

73100

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

75102

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

106133## Docker stack builds

107134

108135You'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,6 +11,9 @@ data Arguments = Arguments

1111 ,argsCwd :: Maybe FilePath

1212 ,argFiles :: [FilePath]

1313 ,argsVersion :: Bool

14+ ,argsShakeProfiling :: Maybe FilePath

15+ ,argsTesting :: Bool

16+ ,argsThreads :: Int

1417 }

1518

1619getArguments :: IO Arguments

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

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

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

2932 <*> 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+563−85

@@ -2,19 +2,32 @@

22-- SPDX-License-Identifier: Apache-2.0

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

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

5+{-# LANGUAGE TemplateHaskell #-}

6+{-# LANGUAGE TypeFamilies #-}

68module Main(main) where

10+import Linker (initDynLinker)

11+import Data.IORef

12+import NameCache

13+import Packages

14+import Module

815import Arguments

9−import Data.Maybe

10−import Data.List.Extra

11−import System.FilePath

16+import Control.Concurrent.Async

1217import Control.Concurrent.Extra

1318import Control.Exception

1419import Control.Monad.Extra

1520import Control.Monad.IO.Class

1621import Data.Default

17−import System.Time.Extra

22+import Data.Either

23+import Data.Function

24+import Data.List.Extra

25+import Data.Maybe

26+import qualified Data.Text as T

27+import qualified Data.Text.IO as T

28+import Data.Time.Clock (UTCTime)

29+import Data.Version

30+import Development.IDE.Core.Debouncer

1831import Development.IDE.Core.FileStore

1932import Development.IDE.Core.OfInterest

2033import Development.IDE.Core.Service

@@ -27,34 +40,53 @@ import Development.IDE.Types.Diagnostics

2740import Development.IDE.Types.Options

2841import Development.IDE.Types.Logger

2942import Development.IDE.GHC.Util

30−import qualified Data.Text as T

31−import qualified Data.Text.IO as T

43+import Development.IDE.Plugin

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

3247import Language.Haskell.LSP.Messages

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

34−import Linker

35−import Data.Version

48+import Language.Haskell.LSP.Types

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

3650import Development.IDE.LSP.LanguageServer

37−import System.Directory.Extra as IO

51+import qualified System.Directory.Extra as IO

3852import System.Environment

3953import System.IO

4054import System.Exit

55+import System.FilePath

56+import System.Directory

57+import System.Time.Extra

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

4159import Paths_ghcide

60+import Development.GitRev

4261import Development.Shake (Action, action)

43−import qualified Data.Set as Set

62+import qualified Data.HashSet as HashSet

63+import qualified Data.HashMap.Strict as HM

4464import qualified Data.Map.Strict as Map

45−

65+import qualified Crypto.Hash.SHA1 as H

66+import qualified Data.ByteString.Char8 as B

67+import Data.ByteString.Base16 (encode)

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

69+import GhcMonad

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

4671import GHC hiding (def)

47−import qualified GHC.Paths

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

73+import Data.Either.Extra

4874

49−import HIE.Bios

75+import HIE.Bios.Cradle

76+import HIE.Bios.Types

5077

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

52−getLibdir :: IO FilePath

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

78+import Utils

5479

55−ghcideVersion :: String

56−ghcideVersion = "ghcide version: " <> showVersion version

57− <> " (GHC: " <> VERSION_ghc <> ")"

80+ghcideVersion :: IO String

81+ghcideVersion = do

82+ path <- getExecutablePath

83+ let gitHashSection = case $(gitHash) of

84+ x | x == "UNKNOWN" -> ""

85+ x -> " (GIT hash: " <> x <> ")"

86+ return $ "ghcide version: " <> showVersion version

87+ <> " (GHC: " <> VERSION_ghc

88+ <> ") (PATH: " <> path <> ")"

89+ <> gitHashSection

5890

5991main :: IO ()

6092main = do

@@ -62,72 +94,76 @@ main = do

6294 -- then the language server will not work

6395 Arguments{..} <- getArguments

6496

65− if argsVersion then putStrLn ghcideVersion >> exitSuccess

66− else hPutStrLn stderr {- see WARNING above -} ghcideVersion

97+ if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess

98+ else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion

6799

68100 -- lock to avoid overlapping output on stdout

69101 lock <- newLock

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

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

72104

73− whenJust argsCwd setCurrentDirectory

105+ whenJust argsCwd IO.setCurrentDirectory

74106

75− dir <- getCurrentDirectory

107+ dir <- IO.getCurrentDirectory

108+ command <- makeLspCommandId "typesignature.add"

109+

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

111+ onInitialConfiguration = const $ Right ()

112+ onConfigurationChange = const $ Right ()

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

114+ , LSP.completionTriggerCharacters = Just "."

115+ }

76116

77117 if argLSP then do

78118 t <- offsetTime

79119 hPutStrLn stderr "Starting LSP server..."

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

81− runLanguageServer def def $ \getLspId event vfs caps -> do

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

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

82122 t <- t

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

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

85− session <- loadSession dir

86− let options = (defaultIdeOptions $ return session)

87− { optReportProgress = clientSupportsProgress caps }

88− initialise (mainRule >> action kick) getLspId event (logger minBound) options vfs

124+ let options = (defaultIdeOptions $ loadSessionShake dir)

125+ { 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

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

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

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

92140

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

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

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

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

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

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

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

96146

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

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

98148 cradles <- mapM findCradle files

99149 let ucradles = nubOrd cradles

100150 let n = length ucradles

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

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

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

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

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

106− when (isNothing x) $ print cradle

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

108− cradleToSession cradle

109−

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

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

111153 vfs <- makeVFSHandle

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

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

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

115− cradle <- Map.lookup file filesToCradles

116− Map.lookup cradle cradlesToSessions

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

118−

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

120− setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files

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

154+ debouncer <- newAsyncDebouncer

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

156+

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

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

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

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

123161 when (failed /= []) $

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

125163

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

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

128−

129− unless (null failed) exitFailure

130−

166+ return ()

131167

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

133169expandFiles = concatMapM $ \x -> do

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

136172 let recurse "." = True

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

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

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

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

140176 when (null files) $

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

142178 return files

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

145181kick :: Action ()

146182kick = do

147183 files <- getFilesOfInterest

148− void $ uses TypeCheck $ Set.toList files

184+ void $ uses TypeCheck $ HashSet.toList files

149185

150186-- | Print an LSP event.

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

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

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

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

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

155191showEvent lock e = withLock lock $ print e

156192

157193

158−cradleToSession :: Cradle -> IO HscEnvEq

159−cradleToSession cradle = do

160− cradleRes <- getCompilerOptions "" cradle

161− opts <- case cradleRes of

162− CradleSuccess r -> pure r

163− CradleFail err -> throwIO err

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

165− -- That will require some more changes.

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

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

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

196+cradleToSessionOpts cradle file = do

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

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

199+ case cradleRes of

200+ CradleSuccess r -> pure (Right r)

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

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

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

204+ CradleNone -> return (Left [])

205+

206+emptyHscEnv :: IO HscEnv

207+emptyHscEnv = do

167208 libdir <- getLibdir

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

169− _targets <- initSession opts

170− getSession

209+ env <- runGhc (Just libdir) getSession

171210 initDynLinker env

172− newHscEnvEq env

211+ pure env

212+

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

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

215+-- directories

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

217+-- to canonicalise it.

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

219+targetToFile is (TargetModule mod) = do

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

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

222+ mapM (fmap toNormalizedFilePath' . canonicalizePath) fps

223+targetToFile _ (TargetFile f _) = do

224+ f' <- canonicalizePath f

225+ return [toNormalizedFilePath' f']

226+

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

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

229+

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

231+loadSessionShake fp = do

232+ se <- getShakeExtras

233+ IdeOptions{optTesting} <- getIdeOptions

234+ res <- liftIO $ loadSession optTesting se fp

235+ return (fmap liftIO res)

236+

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

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

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

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

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

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

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

244+ -- Mapping from a Filepath to HscEnv

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

246+

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

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

249+ res <- findCradle v

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

251+ -- try and normalise that

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

253+ res' <- traverse IO.makeAbsolute res

254+ return $ normalise <$> res'

255+

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

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

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

259+ -- which contains the union.

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

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

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

263+ -- Parse DynFlags for the newly discovered component

264+ hscEnv <- emptyHscEnv

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

266+ setOptions opts (hsc_dflags hscEnv)

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

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

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

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

271+ -- (unitId, DynFlag, Targets)

272+ modifyVar hscEnvs $ \m -> do

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

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

275+ let oldDeps = Map.lookup hieYaml m

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

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

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

279+ -- information.

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

281+ : maybe [] snd oldDeps

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

283+ inplace = map rawComponentUnitId new_deps

284+

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

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

287+ -- components in this HscEnv

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

289+ let prefix = show rawComponentUnitId

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

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

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

293+ -- contain any packages which are also loaded

294+ -- into the same component.

295+ pure $ ComponentInfo rawComponentUnitId

296+ processed_df

297+ uids

298+ rawComponentTargets

299+ rawComponentFP

300+ rawComponentCOptions

301+ rawComponentDependencyInfo

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

303+ -- scratch again (for now)

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

305+ -- that I do not fully understand

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

307+ hscEnv <- case oldDeps of

308+ Nothing -> emptyHscEnv

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

310+ newHscEnv <-

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

312+ evalGhcEnv hscEnv $ do

313+ _ <- setSessionDynFlags df

314+ getSession

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

316+ -- HscEnv

317+ -- Returns

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

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

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

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

322+ -- existing packages

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

324+

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

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

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

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

329+ -- resolve imports. (especially PackageImports)

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

331+

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

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

334+

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

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

337+ let new_cache = newComponentCache logger hscEnv uids

338+ (cs, res) <- new_cache new

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

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

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

342+ modifyVar_ fileToFlags $ \var -> do

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

344+

345+ return (fst res)

346+

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

348+ consultCradle hieYaml cfp = do

349+ when optTesting $ eventer $ notifyCradleLoaded cfp

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

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

352+ eopts <- cradleToSessionOpts cradle cfp

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

354+ case eopts of

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

356+ -- into and HscEnv.

357+ Right opts -> do

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

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

360+ Left err -> do

361+ dep_info <- getDependencyInfo (maybeToList hieYaml)

362+ let ncfp = toNormalizedFilePath' cfp

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

364+ modifyVar_ fileToFlags $ \var -> do

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

366+ return res

367+

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

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

370+ sessionOpts (hieYaml, file) = do

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

372+ cfp <- canonicalizePath file

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

374+ Just (opts, old_di) -> do

375+ deps_ok <- checkDependencyInfo old_di

376+ if not deps_ok

377+ then do

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

379+ -- again.

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

381+ -- Keep the same name cache

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

383+ consultCradle hieYaml cfp

384+ else return opts

385+ Nothing -> consultCradle hieYaml cfp

173386

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)

174403

175−loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq)

176−loadSession dir = do

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

178− res <- findCradle v

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

180− -- try and normalise that

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

182− res' <- traverse makeAbsolute res

183− return $ normalise <$> res'

184− session <- memoIO $ \file -> do

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

186− cradleToSession c

187− return $ \file -> liftIO $ session =<< cradleLoc file

188404

189405

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+

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

191593--

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

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

203605 res <- onceFork $ op k

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

205607 Just res -> return (mp, res)

608+

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

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

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

612+ let dflags'' =

613+ -- disabled, generated directly by ghcide instead

614+ flip gopt_unset Opt_WriteInterface $

615+ -- disabled, generated directly by ghcide instead

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

617+ dontWriteHieFiles $

618+ setIgnoreInterfacePragmas $

619+ setLinkerOptions $

620+ disableOptimisation $

621+ makeDynFlagsAbsolute compRoot dflags'

622+ -- initPackages parses the -package flags and

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

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

625+ return (final_df, targets)

626+

627+

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

629+-- (HscInterpreted) which implies LinkInMemory

630+-- HscInterpreted

631+setLinkerOptions :: DynFlags -> DynFlags

632+setLinkerOptions df = df {

633+ ghcLink = LinkInMemory

634+ , hscTarget = HscNothing

635+ , ghcMode = CompManager

636+ }

637+

638+setIgnoreInterfacePragmas :: DynFlags -> DynFlags

639+setIgnoreInterfacePragmas df =

640+ gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges

641+

642+disableOptimisation :: DynFlags -> DynFlags

643+disableOptimisation df = updOptLevel 0 df

644+

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

646+setHiDir f d =

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

648+ d { hiDir = Just f}

649+

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

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

652+ where

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

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

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

656+

657+-- | Sub directory for the cache path

658+cacheDir :: String

659+cacheDir = "ghcide"

660+

661+notifyCradleLoaded :: FilePath -> FromServerMessage

662+notifyCradleLoaded fp =

663+ NotCustomServer $

664+ NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $

665+ toJSON fp

666+

667+cradleLoadedMethod :: T.Text

668+cradleLoadedMethod = "ghcide/cradle/loaded"

669+

670+ghcVersionChecker :: IO VersionCheck

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

672+

673+checkGhcVersion :: IO (Maybe HscEnvEq)

674+checkGhcVersion = do

675+ res <- ghcVersionChecker

676+ case res of

677+ Failure err -> do

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

679+ return Nothing

680+ Mismatch {..} ->

681+ return $ Just GhcVersionMismatch {..}

682+ _ ->

683+ return Nothing

exe/Utils.hsnew file+9

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

1+module Utils (getLibdir) where

3+import qualified GHC.Paths

4+import System.Environment

5+import Data.Maybe

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

8+getLibdir :: IO FilePath

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

fmt.sh+1−1

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

11#!/usr/bin/env bash

22set -eou pipefail

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

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

ghcide.cabal+156−18

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

22build-type: Simple

33category: Development

44name: ghcide

5−version: 0.0.5

5+version: 0.2.0

66license: Apache-2.0

77license-file: LICENSE

88author: Digital Asset

99maintainer: Digital Asset

10−copyright: Digital Asset 2018-2019

10+copyright: Digital Asset 2018-2020

1111synopsis: The core of an IDE

1212description:

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

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

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

1616tested-with: GHC==8.6.5

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

18− test/data/GotoHover.hs

18+ test/data/hover/*.hs

19+ test/data/multi/cabal.project

20+ test/data/multi/hie.yaml

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

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

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

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

1925

2026source-repository head

2127 type: git

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

3036 default-language: Haskell2010

3137 build-depends:

3238 aeson,

39+ array,

3340 async,

3441 base == 4.*,

3542 binary,

@@ -39,25 +46,28 @@ library

3946 deepseq,

4047 directory,

4148 extra,

49+ fuzzy,

4250 filepath,

51+ haddock-library >= 1.8,

4352 hashable,

44− haskell-lsp-types == 0.19.*,

45− haskell-lsp == 0.19.*,

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

54+ haskell-lsp == 0.22.*,

4655 mtl,

4756 network-uri,

4857 prettyprinter-ansi-terminal,

4958 prettyprinter-ansi-terminal,

5059 prettyprinter,

60+ regex-tdfa >= 1.3.1.0,

5161 rope-utf16-splay,

5262 safe-exceptions,

53− shake >= 0.17.5,

63+ shake >= 0.18.4,

5464 sorted-list,

5565 stm,

5666 syb,

5767 text,

5868 time,

5969 transformers,

60− unordered-containers,

70+ unordered-containers >= 0.2.10.0,

6171 utf8-string,

6272 hslogger

6373 if flag(ghc-lib)

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

7080 ghc-boot-th,

7181 ghc-boot,

7282 ghc >= 8.4

73− if !os(windows)

83+ if os(windows)

84+ build-depends:

85+ Win32

86+ else

7487 build-depends:

7588 unix

7689 c-sources:

@@ -96,71 +109,133 @@ library

96109 include-dirs:

97110 include

98111 exposed-modules:

112+ Development.IDE.Compat

113+ Development.IDE.Core.Debouncer

99114 Development.IDE.Core.FileStore

115+ Development.IDE.Core.IdeConfiguration

100116 Development.IDE.Core.OfInterest

101117 Development.IDE.Core.PositionMapping

102118 Development.IDE.Core.Rules

103119 Development.IDE.Core.RuleTypes

104120 Development.IDE.Core.Service

105121 Development.IDE.Core.Shake

122+ Development.IDE.GHC.Error

106123 Development.IDE.GHC.Util

107124 Development.IDE.Import.DependencyInformation

125+ Development.IDE.LSP.HoverDefinition

108126 Development.IDE.LSP.LanguageServer

127+ Development.IDE.LSP.Outline

109128 Development.IDE.LSP.Protocol

110129 Development.IDE.LSP.Server

130+ Development.IDE.Spans.Common

111131 Development.IDE.Types.Diagnostics

112132 Development.IDE.Types.Location

113133 Development.IDE.Types.Logger

114134 Development.IDE.Types.Options

135+ Development.IDE.Plugin

136+ Development.IDE.Plugin.Completions

137+ Development.IDE.Plugin.CodeAction

115138 other-modules:

116− Development.IDE.Core.Debouncer

117139 Development.IDE.Core.Compile

118140 Development.IDE.Core.Preprocessor

141+ Development.IDE.Core.FileExists

119142 Development.IDE.GHC.Compat

120143 Development.IDE.GHC.CPP

121− Development.IDE.GHC.Error

122144 Development.IDE.GHC.Orphans

123145 Development.IDE.GHC.Warnings

146+ Development.IDE.GHC.WithDynFlags

124147 Development.IDE.Import.FindImports

125− Development.IDE.LSP.CodeAction

126− Development.IDE.LSP.HoverDefinition

127148 Development.IDE.LSP.Notifications

128149 Development.IDE.Spans.AtPoint

129150 Development.IDE.Spans.Calculate

130151 Development.IDE.Spans.Documentation

131152 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

167+

168+executable ghcide-test-preprocessor

169+ default-language: Haskell2010

170+ hs-source-dirs: test/preprocessor

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

172+ main-is: Main.hs

173+ build-depends:

174+ base == 4.*

133175

134176executable ghcide

135177 if flag(ghc-lib)

136178 buildable: False

137179 default-language: Haskell2010

138180 hs-source-dirs: exe

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

181+ ghc-options:

182+ -threaded

183+ -Wall

184+ -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"

140191 main-is: Main.hs

141192 build-depends:

193+ time,

194+ async,

142195 hslogger,

196+ aeson,

143197 base == 4.*,

198+ binary,

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

200+ bytestring,

144201 containers,

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

145203 data-default,

204+ deepseq,

146205 directory,

147206 extra,

148207 filepath,

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

149209 ghc-paths,

150210 ghc,

211+ gitrev,

212+ hashable,

151213 haskell-lsp,

152− hie-bios >= 0.3 && < 0.4,

214+ haskell-lsp-types,

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

153216 ghcide,

154217 optparse-applicative,

155218 shake,

156− text

219+ text,

220+ unordered-containers

157221 other-modules:

222+ Utils

158223 Arguments

159224 Paths_ghcide

160225

161226 default-extensions:

227+ BangPatterns

228+ DeriveFunctor

229+ DeriveGeneric

230+ GeneralizedNewtypeDeriving

231+ LambdaCase

232+ NamedFieldPuns

233+ OverloadedStrings

162234 RecordWildCards

235+ ScopedTypeVariables

236+ StandaloneDeriving

163237 TupleSections

238+ TypeApplications

164239 ViewPatterns

165240

166241test-suite ghcide-tests

@@ -169,8 +244,10 @@ test-suite ghcide-tests

169244 type: exitcode-stdio-1.0

170245 default-language: Haskell2010

171246 build-tool-depends:

172− ghcide:ghcide

247+ ghcide:ghcide,

248+ ghcide:ghcide-test-preprocessor

173249 build-depends:

250+ aeson,

174251 base,

175252 bytestring,

176253 containers,

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

187264 --------------------------------------------------------------

188265 ghcide,

189266 ghc-typelits-knownnat,

267+ haddock-library,

268+ haskell-lsp,

190269 haskell-lsp-types,

270+ network-uri,

191271 lens,

192− lsp-test >= 0.8,

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

193273 parser-combinators,

274+ QuickCheck,

275+ quickcheck-instances,

276+ rope-utf16-splay,

277+ shake,

194278 tasty,

195− tasty-hunit,

196279 tasty-expected-failure,

280+ tasty-hunit,

281+ tasty-quickcheck,

282+ tasty-rerun,

197283 text

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

199285 include-dirs: include

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

203289 Development.IDE.Test

204290 Development.IDE.Test.Runfiles

205291 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

206338 OverloadedStrings

339+ RecordWildCards

340+ ScopedTypeVariables

341+ StandaloneDeriving

342+ TupleSections

343+ TypeApplications

344+ ViewPatterns

hie.yaml+12−1

@@ -1 +1,12 @@

1−cradle: {stack}

1+cradle:

2+ cabal:

3+ - path: "./src"

4+ component: "ghcide:lib:ghcide"

5+ - path: "./exe"

6+ component: "ghcide:exe:ghcide"

7+ - path: "./test"

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

9+ - path: "./bench"

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

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

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

src-ghc810/Development/IDE/GHC/HieAst.hsnew file+1928

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

3+{-

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

6+Main functions for .hie file generation

7+-}

8+{- HLINT ignore -}

9+{-# LANGUAGE OverloadedStrings #-}

10+{-# LANGUAGE FlexibleInstances #-}

11+{-# LANGUAGE UndecidableInstances #-}

12+{-# LANGUAGE FlexibleContexts #-}

13+{-# LANGUAGE TypeSynonymInstances #-}

14+{-# LANGUAGE ScopedTypeVariables #-}

15+{-# LANGUAGE TypeFamilies #-}

16+{-# LANGUAGE TypeApplications #-}

17+{-# LANGUAGE AllowAmbiguousTypes #-}

18+{-# LANGUAGE ViewPatterns #-}

19+{-# LANGUAGE DeriveDataTypeable #-}

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

21+

22+import GhcPrelude

23+

24+import Avail ( Avails )

25+import Bag ( Bag, bagToList )

26+import BasicTypes

27+import BooleanFormula

28+import Class ( FunDep )

29+import CoreUtils ( exprType )

30+import ConLike ( conLikeName )

31+import Desugar ( deSugarExpr )

32+import FieldLabel

33+import GHC.Hs

34+import HscTypes

35+import Module ( ModuleName, ml_hs_file )

36+import MonadUtils ( concatMapM, liftIO )

37+import Name ( Name, nameSrcSpan, setNameLoc )

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

39+import SrcLoc

40+import TcHsSyn ( hsLitType, hsPatType )

41+import Type ( mkVisFunTys, Type )

42+import TysWiredIn ( mkListTy, mkSumTy )

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

44+import TcRnTypes

45+import MkIface ( mkIfaceExports )

46+import Panic

47+

48+import HieTypes

49+import HieUtils

50+

51+import qualified Data.Array as A

52+import qualified Data.ByteString as BS

53+import qualified Data.Map as M

54+import qualified Data.Set as S

55+import Data.Data ( Data, Typeable )

56+import Data.List ( foldl1' )

57+import Data.Maybe ( listToMaybe )

58+import Control.Monad.Trans.Reader

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

60+

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

62+

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

64+need to pay attention to the following things:

65+

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

67+

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

69+ something the user typed

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

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

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

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

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

75+

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

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

78+

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

80+

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

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

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

84+

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

86+

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

88+

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

90+

91+data ContextInfo

92+ = Use -- ^ regular variable

93+ | MatchBind

94+ | IEThing IEType -- ^ import/export

95+ | TyDecl

96+ -- | Value binding

97+ | ValBind

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

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

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

101+ ...

102+

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

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

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

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

107+

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

109+particular location, you would do the following:

110+

111+ toHie $ C Use located_name

112+

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

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

115+`SrcSpans`.

116+

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

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

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

120+in HieAst.

121+

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

123+the name.

124+

125+For a function definition `foo`:

126+

127+foo x = x + y

128+ where y = x^2

129+

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

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

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

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

134+

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

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

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

138+.hie file.

139+

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

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

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

143+

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

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

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

147+

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

149+

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

151+ HsVar _ (L _ var) ->

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

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

154+ ]

155+ HsConLikeOut _ con ->

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

157+ ]

158+ ...

159+ HsApp _ a b ->

160+ [ toHie a

161+ , toHie b

162+ ]

163+

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

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

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

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

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

169+appropriately annotated symbols contained in the subtree.

170+

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

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

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

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

175+when given a typechecked AST:

176+

177+class Data a => HasType a where

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

179+instance HasType (LHsExpr GhcTc) where

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

181+instance HasType (LHsExpr GhcRn) where

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

183+

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

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

186+

187+-}

188+

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

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

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

192+ , Maybe LHsDocString )

193+type TypecheckedSource = LHsBinds GhcTc

194+

195+

196+{- Note [Name Remapping]

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

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

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

200+-}

201+newtype HieState = HieState

202+ { name_remapping :: NameEnv Id

203+ }

204+

205+initState :: HieState

206+initState = HieState emptyNameEnv

207+

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

209+ addSubstitution :: a -> a -> HieState -> HieState

210+

211+instance ModifyState Name where

212+ addSubstitution _ _ hs = hs

213+

214+instance ModifyState Id where

215+ addSubstitution mono poly hs =

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

217+

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

219+modifyState = foldr go id

220+ where

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

222+ go _ f = f

223+

224+type HieM = ReaderT HieState Hsc

225+

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

227+mkHieFile :: ModSummary

228+ -> TcGblEnv

229+ -> RenamedSource

230+ -> BS.ByteString -> Hsc HieFile

231+mkHieFile ms ts rs src = do

232+ let tc_binds = tcg_binds ts

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

234+ let Just src_file = ml_hs_file $ ms_location ms

235+ return $ HieFile

236+ { hie_hs_file = src_file

237+ , hie_module = ms_mod ms

238+ , hie_types = arr

239+ , hie_asts = asts'

240+ -- mkIfaceExports sorts the AvailInfos for stability

241+ , hie_exports = mkIfaceExports (tcg_exports ts)

242+ , hie_hs_src = src

243+ }

244+

245+getCompressedAsts :: TypecheckedSource -> RenamedSource

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

247+getCompressedAsts ts rs = do

248+ asts <- enrichHie ts rs

249+ return $ compressTypes asts

250+

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

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

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

254+ rasts <- processGrp hsGrp

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

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

257+ let spanFile children = case children of

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

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

260+ (realSrcSpanEnd $ nodeSpan $ last children)

261+

262+ modulify xs =

263+ Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs

264+

265+ asts = HieASTs

266+ $ resolveTyVarScopes

267+ $ M.map (modulify . mergeSortAsts)

268+ $ M.fromListWith (++)

269+ $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts

270+

271+ flat_asts = concat

272+ [ tasts

273+ , rasts

274+ , imps

275+ , exps

276+ ]

277+ return asts

278+ where

279+ processGrp grp = concatM

280+ [ toHie $ fmap (RS ModuleScope ) hs_valds grp

281+ , toHie $ hs_splcds grp

282+ , toHie $ hs_tyclds grp

283+ , toHie $ hs_derivds grp

284+ , toHie $ hs_fixds grp

285+ , toHie $ hs_defds grp

286+ , toHie $ hs_fords grp

287+ , toHie $ hs_warnds grp

288+ , toHie $ hs_annds grp

289+ , toHie $ hs_ruleds grp

290+ ]

291+

292+getRealSpan :: SrcSpan -> Maybe Span

293+getRealSpan (RealSrcSpan sp) = Just sp

294+getRealSpan _ = Nothing

295+

296+grhss_span :: GRHSs p body -> SrcSpan

297+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)

298+grhss_span (XGRHSs _) = panic "XGRHS has no span"

299+

300+bindingsOnly :: [Context Name] -> [HieAST a]

301+bindingsOnly [] = []

302+bindingsOnly (C c n : xs) = case nameSrcSpan n of

303+ RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs

304+ where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)

305+ info = mempty{identInfo = S.singleton c}

306+ _ -> bindingsOnly xs

307+

308+concatM :: Monad m => [m [a]] -> m [a]

309+concatM xs = concat <$> sequence xs

310+

311+{- Note [Capturing Scopes and other non local information]

312+toHie is a local tranformation, but scopes of bindings cannot be known locally,

313+hence we have to push the relevant info down into the binding nodes.

314+We use the following types (*Context and *Scoped) to wrap things and

315+carry the required info

316+(Maybe Span) always carries the span of the entire binding, including rhs

317+-}

318+data Context a = C ContextInfo a -- Used for names and bindings

319+

320+data RContext a = RC RecFieldContext a

321+data RFContext a = RFC RecFieldContext (Maybe Span) a

322+-- ^ context for record fields

323+

324+data IEContext a = IEC IEType a

325+-- ^ context for imports/exports

326+

327+data BindContext a = BC BindType Scope a

328+-- ^ context for imports/exports

329+

330+data PatSynFieldContext a = PSC (Maybe Span) a

331+-- ^ context for pattern synonym fields.

332+

333+data SigContext a = SC SigInfo a

334+-- ^ context for type signatures

335+

336+data SigInfo = SI SigType (Maybe Span)

337+

338+data SigType = BindSig | ClassSig | InstSig

339+

340+data RScoped a = RS Scope a

341+-- ^ Scope spans over everything to the right of a, (mostly) not

342+-- including a itself

343+-- (Includes a in a few special cases like recursive do bindings) or

344+-- let/where bindings

345+

346+-- | Pattern scope

347+data PScoped a = PS (Maybe Span)

348+ Scope -- ^ use site of the pattern

349+ Scope -- ^ pattern to the right of a, not including a

350+ a

351+ deriving (Typeable, Data) -- Pattern Scope

352+

353+{- Note [TyVar Scopes]

354+Due to -XScopedTypeVariables, type variables can be in scope quite far from

355+their original binding. We resolve the scope of these type variables

356+in a separate pass

357+-}

358+data TScoped a = TS TyVarScope a -- TyVarScope

359+

360+data TVScoped a = TVS TyVarScope Scope a -- TyVarScope

361+-- ^ First scope remains constant

362+-- Second scope is used to build up the scope of a tyvar over

363+-- things to its right, ala RScoped

364+

365+-- | Each element scopes over the elements to the right

366+listScopes :: Scope -> [Located a] -> [RScoped (Located a)]

367+listScopes _ [] = []

368+listScopes rhsScope [pat] = [RS rhsScope pat]

369+listScopes rhsScope (pat : pats) = RS sc pat : pats'

370+ where

371+ pats'@((RS scope p):_) = listScopes rhsScope pats

372+ sc = combineScopes scope $ mkScope $ getLoc p

373+

374+-- | 'listScopes' specialised to 'PScoped' things

375+patScopes

376+ :: Maybe Span

377+ -> Scope

378+ -> Scope

379+ -> [LPat (GhcPass p)]

380+ -> [PScoped (LPat (GhcPass p))]

381+patScopes rsp useScope patScope xs =

382+ map (\(RS sc a) -> PS rsp useScope sc (composeSrcSpan a)) $

383+ listScopes patScope (map dL xs)

384+

385+-- | 'listScopes' specialised to 'TVScoped' things

386+tvScopes

387+ :: TyVarScope

388+ -> Scope

389+ -> [LHsTyVarBndr a]

390+ -> [TVScoped (LHsTyVarBndr a)]

391+tvScopes tvScope rhsScope xs =

392+ map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs

393+

394+{- Note [Scoping Rules for SigPat]

395+Explicitly quantified variables in pattern type signatures are not

396+brought into scope in the rhs, but implicitly quantified variables

397+are (HsWC and HsIB).

398+This is unlike other signatures, where explicitly quantified variables

399+are brought into the RHS Scope

400+For example

401+foo :: forall a. ...;

402+foo = ... -- a is in scope here

403+

404+bar (x :: forall a. a -> a) = ... -- a is not in scope here

405+-- ^ a is in scope here (pattern body)

406+

407+bax (x :: a) = ... -- a is in scope here

408+Because of HsWC and HsIB pass on their scope to their children

409+we must wrap the LHsType in pattern signatures in a

410+Shielded explictly, so that the HsWC/HsIB scope is not passed

411+on the the LHsType

412+-}

413+

414+data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead

415+

416+type family ProtectedSig a where

417+ ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs

418+ GhcRn

419+ (Shielded (LHsType GhcRn)))

420+ ProtectedSig GhcTc = NoExtField

421+

422+class ProtectSig a where

423+ protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a

424+

425+instance (HasLoc a) => HasLoc (Shielded a) where

426+ loc (SH _ a) = loc a

427+

428+instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where

429+ toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)

430+

431+instance ProtectSig GhcTc where

432+ protectSig _ _ = noExtField

433+

434+instance ProtectSig GhcRn where

435+ protectSig sc (HsWC a (HsIB b sig)) =

436+ HsWC a (HsIB b (SH sc sig))

437+ protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec

438+ protectSig _ (XHsWildCardBndrs nec) = noExtCon nec

439+

440+class HasLoc a where

441+ -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can

442+ -- know what their implicit bindings are scoping over

443+ loc :: a -> SrcSpan

444+

445+instance HasLoc thing => HasLoc (TScoped thing) where

446+ loc (TS _ a) = loc a

447+

448+instance HasLoc thing => HasLoc (PScoped thing) where

449+ loc (PS _ _ _ a) = loc a

450+

451+instance HasLoc (LHsQTyVars GhcRn) where

452+ loc (HsQTvs _ vs) = loc vs

453+ loc _ = noSrcSpan

454+

455+instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where

456+ loc (HsIB _ a) = loc a

457+ loc _ = noSrcSpan

458+

459+instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where

460+ loc (HsWC _ a) = loc a

461+ loc _ = noSrcSpan

462+

463+instance HasLoc (Located a) where

464+ loc (L l _) = l

465+

466+instance HasLoc a => HasLoc [a] where

467+ loc [] = noSrcSpan

468+ loc xs = foldl1' combineSrcSpans $ map loc xs

469+

470+instance HasLoc a => HasLoc (FamEqn s a) where

471+ loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]

472+ loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans

473+ [loc a, loc tvs, loc b, loc c]

474+ loc _ = noSrcSpan

475+instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where

476+ loc (HsValArg tm) = loc tm

477+ loc (HsTypeArg _ ty) = loc ty

478+ loc (HsArgPar sp) = sp

479+

480+instance HasLoc (HsDataDefn GhcRn) where

481+ loc def@(HsDataDefn{}) = loc $ dd_cons def

482+ -- Only used for data family instances, so we only need rhs

483+ -- Most probably the rest will be unhelpful anyway

484+ loc _ = noSrcSpan

485+

486+{- Note [Real DataCon Name]

487+The typechecker subtitutes the conLikeWrapId for the name, but we don't want

488+this showing up in the hieFile, so we replace the name in the Id with the

489+original datacon name

490+See also Note [Data Constructor Naming]

491+-}

492+class HasRealDataConName p where

493+ getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p)

494+

495+instance HasRealDataConName GhcRn where

496+ getRealDataCon _ n = n

497+instance HasRealDataConName GhcTc where

498+ getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) =

499+ L sp (setVarName var (conLikeName con))

500+

501+-- | The main worker class

502+-- See Note [Updating HieAst for changes in the GHC AST] for more information

503+-- on how to add/modify instances for this.

504+class ToHie a where

505+ toHie :: a -> HieM [HieAST Type]

506+

507+-- | Used to collect type info

508+class Data a => HasType a where

509+ getTypeNode :: a -> HieM [HieAST Type]

510+

511+instance (ToHie a) => ToHie [a] where

512+ toHie = concatMapM toHie

513+

514+instance (ToHie a) => ToHie (Bag a) where

515+ toHie = toHie . bagToList

516+

517+instance (ToHie a) => ToHie (Maybe a) where

518+ toHie = maybe (pure []) toHie

519+

520+instance ToHie (Context (Located NoExtField)) where

521+ toHie _ = pure []

522+

523+instance ToHie (TScoped NoExtField) where

524+ toHie _ = pure []

525+

526+instance ToHie (IEContext (Located ModuleName)) where

527+ toHie (IEC c (L (RealSrcSpan span) mname)) =

528+ pure $ [Node (NodeInfo S.empty [] idents) span []]

529+ where details = mempty{identInfo = S.singleton (IEThing c)}

530+ idents = M.singleton (Left mname) details

531+ toHie _ = pure []

532+

533+instance ToHie (Context (Located Var)) where

534+ toHie c = case c of

535+ C context (L (RealSrcSpan span) name')

536+ -> do

537+ m <- asks name_remapping

538+ let name = case lookupNameEnv m (varName name') of

539+ Just var -> var

540+ Nothing-> name'

541+ pure

542+ [Node

543+ (NodeInfo S.empty [] $

544+ M.singleton (Right $ varName name)

545+ (IdentifierDetails (Just $ varType name')

546+ (S.singleton context)))

547+ span

548+ []]

549+ _ -> pure []

550+

551+instance ToHie (Context (Located Name)) where

552+ toHie c = case c of

553+ C context (L (RealSrcSpan span) name') -> do

554+ m <- asks name_remapping

555+ let name = case lookupNameEnv m name' of

556+ Just var -> varName var

557+ Nothing -> name'

558+ pure

559+ [Node

560+ (NodeInfo S.empty [] $

561+ M.singleton (Right name)

562+ (IdentifierDetails Nothing

563+ (S.singleton context)))

564+ span

565+ []]

566+ _ -> pure []

567+

568+-- | Dummy instances - never called

569+instance ToHie (TScoped (LHsSigWcType GhcTc)) where

570+ toHie _ = pure []

571+instance ToHie (TScoped (LHsWcType GhcTc)) where

572+ toHie _ = pure []

573+instance ToHie (SigContext (LSig GhcTc)) where

574+ toHie _ = pure []

575+instance ToHie (TScoped Type) where

576+ toHie _ = pure []

577+

578+instance HasType (LHsBind GhcRn) where

579+ getTypeNode (L spn bind) = makeNode bind spn

580+

581+instance HasType (LHsBind GhcTc) where

582+ getTypeNode (L spn bind) = case bind of

583+ FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)

584+ _ -> makeNode bind spn

585+

586+instance HasType (Located (Pat GhcRn)) where

587+ getTypeNode (dL -> L spn pat) = makeNode pat spn

588+

589+instance HasType (Located (Pat GhcTc)) where

590+ getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)

591+

592+instance HasType (LHsExpr GhcRn) where

593+ getTypeNode (L spn e) = makeNode e spn

594+

595+-- | This instance tries to construct 'HieAST' nodes which include the type of

596+-- the expression. It is not yet possible to do this efficiently for all

597+-- expression forms, so we skip filling in the type for those inputs.

598+--

599+-- 'HsApp', for example, doesn't have any type information available directly on

600+-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then

601+-- query the type of that. Yet both the desugaring call and the type query both

602+-- involve recursive calls to the function and argument! This is particularly

603+-- problematic when you realize that the HIE traversal will eventually visit

604+-- those nodes too and ask for their types again.

605+--

606+-- Since the above is quite costly, we just skip cases where computing the

607+-- expression's type is going to be expensive.

608+--

609+-- See #16233

610+instance HasType (LHsExpr GhcTc) where

611+ getTypeNode e@(L spn e') = lift $

612+ -- Some expression forms have their type immediately available

613+ let tyOpt = case e' of

614+ HsLit _ l -> Just (hsLitType l)

615+ HsOverLit _ o -> Just (overLitType o)

616+

617+ HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)

618+ HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)

619+ HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)

620+

621+ ExplicitList ty _ _ -> Just (mkListTy ty)

622+ ExplicitSum ty _ _ _ -> Just (mkSumTy ty)

623+ HsDo ty _ _ -> Just ty

624+ HsMultiIf ty _ -> Just ty

625+

626+ _ -> Nothing

627+

628+ in

629+ case tyOpt of

630+ Just t -> makeTypeNode e' spn t

631+ Nothing

632+ | skipDesugaring e' -> fallback

633+ | otherwise -> do

634+ hs_env <- Hsc $ \e w -> return (e,w)

635+ (_,mbe) <- liftIO $ deSugarExpr hs_env e

636+ maybe fallback (makeTypeNode e' spn . exprType) mbe

637+ where

638+ fallback = makeNode e' spn

639+

640+ matchGroupType :: MatchGroupTc -> Type

641+ matchGroupType (MatchGroupTc args res) = mkVisFunTys args res

642+

643+ -- | Skip desugaring of these expressions for performance reasons.

644+ --

645+ -- See impact on Haddock output (esp. missing type annotations or links)

646+ -- before marking more things here as 'False'. See impact on Haddock

647+ -- performance before marking more things as 'True'.

648+ skipDesugaring :: HsExpr a -> Bool

649+ skipDesugaring e = case e of

650+ HsVar{} -> False

651+ HsUnboundVar{} -> False

652+ HsConLikeOut{} -> False

653+ HsRecFld{} -> False

654+ HsOverLabel{} -> False

655+ HsIPVar{} -> False

656+ HsWrap{} -> False

657+ _ -> True

658+

659+instance ( ToHie (Context (Located (IdP a)))

660+ , ToHie (MatchGroup a (LHsExpr a))

661+ , ToHie (PScoped (LPat a))

662+ , ToHie (GRHSs a (LHsExpr a))

663+ , ToHie (LHsExpr a)

664+ , ToHie (Located (PatSynBind a a))

665+ , HasType (LHsBind a)

666+ , ModifyState (IdP a)

667+ , Data (HsBind a)

668+ ) => ToHie (BindContext (LHsBind a)) where

669+ toHie (BC context scope b@(L span bind)) =

670+ concatM $ getTypeNode b : case bind of

671+ FunBind{fun_id = name, fun_matches = matches} ->

672+ [ toHie $ C (ValBind context scope $ getRealSpan span) name

673+ , toHie matches

674+ ]

675+ PatBind{pat_lhs = lhs, pat_rhs = rhs} ->

676+ [ toHie $ PS (getRealSpan span) scope NoScope lhs

677+ , toHie rhs

678+ ]

679+ VarBind{var_rhs = expr} ->

680+ [ toHie expr

681+ ]

682+ AbsBinds{abs_exports = xs, abs_binds = binds} ->

683+ [ local (modifyState xs) $ -- Note [Name Remapping]

684+ toHie $ fmap (BC context scope) binds

685+ ]

686+ PatSynBind _ psb ->

687+ [ toHie $ L span psb -- PatSynBinds only occur at the top level

688+ ]

689+ XHsBindsLR _ -> []

690+

691+instance ( ToHie (LMatch a body)

692+ ) => ToHie (MatchGroup a body) where

693+ toHie mg = concatM $ case mg of

694+ MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->

695+ [ pure $ locOnly span

696+ , toHie alts

697+ ]

698+ MG{} -> []

699+ XMatchGroup _ -> []

700+

701+instance ( ToHie (Context (Located (IdP a)))

702+ , ToHie (PScoped (LPat a))

703+ , ToHie (HsPatSynDir a)

704+ ) => ToHie (Located (PatSynBind a a)) where

705+ toHie (L sp psb) = concatM $ case psb of

706+ PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->

707+ [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var

708+ , toHie $ toBind dets

709+ , toHie $ PS Nothing lhsScope NoScope pat

710+ , toHie dir

711+ ]

712+ where

713+ lhsScope = combineScopes varScope detScope

714+ varScope = mkLScope var

715+ detScope = case dets of

716+ (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args

717+ (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)

718+ (RecCon r) -> foldr go NoScope r

719+ go (RecordPatSynField a b) c = combineScopes c

720+ $ combineScopes (mkLScope a) (mkLScope b)

721+ detSpan = case detScope of

722+ LocalScope a -> Just a

723+ _ -> Nothing

724+ toBind (PrefixCon args) = PrefixCon $ map (C Use) args

725+ toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)

726+ toBind (RecCon r) = RecCon $ map (PSC detSpan) r

727+ XPatSynBind _ -> []

728+

729+instance ( ToHie (MatchGroup a (LHsExpr a))

730+ ) => ToHie (HsPatSynDir a) where

731+ toHie dir = case dir of

732+ ExplicitBidirectional mg -> toHie mg

733+ _ -> pure []

734+

735+instance ( a ~ GhcPass p

736+ , ToHie body

737+ , ToHie (HsMatchContext (NameOrRdrName (IdP a)))

738+ , ToHie (PScoped (LPat a))

739+ , ToHie (GRHSs a body)

740+ , Data (Match a body)

741+ ) => ToHie (LMatch (GhcPass p) body) where

742+ toHie (L span m ) = concatM $ makeNode m span : case m of

743+ Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->

744+ [ toHie mctx

745+ , let rhsScope = mkScope $ grhss_span grhss

746+ in toHie $ patScopes Nothing rhsScope NoScope pats

747+ , toHie grhss

748+ ]

749+ XMatch _ -> []

750+

751+instance ( ToHie (Context (Located a))

752+ ) => ToHie (HsMatchContext a) where

753+ toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name

754+ toHie (StmtCtxt a) = toHie a

755+ toHie _ = pure []

756+

757+instance ( ToHie (HsMatchContext a)

758+ ) => ToHie (HsStmtContext a) where

759+ toHie (PatGuard a) = toHie a

760+ toHie (ParStmtCtxt a) = toHie a

761+ toHie (TransStmtCtxt a) = toHie a

762+ toHie _ = pure []

763+

764+instance ( a ~ GhcPass p

765+ , ToHie (Context (Located (IdP a)))

766+ , ToHie (RContext (HsRecFields a (PScoped (LPat a))))

767+ , ToHie (LHsExpr a)

768+ , ToHie (TScoped (LHsSigWcType a))

769+ , ProtectSig a

770+ , ToHie (TScoped (ProtectedSig a))

771+ , HasType (LPat a)

772+ , Data (HsSplice a)

773+ ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where

774+ toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =

775+ concatM $ getTypeNode lpat : case opat of

776+ WildPat _ ->

777+ []

778+ VarPat _ lname ->

779+ [ toHie $ C (PatternBind scope pscope rsp) lname

780+ ]

781+ LazyPat _ p ->

782+ [ toHie $ PS rsp scope pscope p

783+ ]

784+ AsPat _ lname pat ->

785+ [ toHie $ C (PatternBind scope

786+ (combineScopes (mkLScope (dL pat)) pscope)

787+ rsp)

788+ lname

789+ , toHie $ PS rsp scope pscope pat

790+ ]

791+ ParPat _ pat ->

792+ [ toHie $ PS rsp scope pscope pat

793+ ]

794+ BangPat _ pat ->

795+ [ toHie $ PS rsp scope pscope pat

796+ ]

797+ ListPat _ pats ->

798+ [ toHie $ patScopes rsp scope pscope pats

799+ ]

800+ TuplePat _ pats _ ->

801+ [ toHie $ patScopes rsp scope pscope pats

802+ ]

803+ SumPat _ pat _ _ ->

804+ [ toHie $ PS rsp scope pscope pat

805+ ]

806+ ConPatIn c dets ->

807+ [ toHie $ C Use c

808+ , toHie $ contextify dets

809+ ]

810+ ConPatOut {pat_con = con, pat_args = dets}->

811+ [ toHie $ C Use $ fmap conLikeName con

812+ , toHie $ contextify dets

813+ ]

814+ ViewPat _ expr pat ->

815+ [ toHie expr

816+ , toHie $ PS rsp scope pscope pat

817+ ]

818+ SplicePat _ sp ->

819+ [ toHie $ L ospan sp

820+ ]

821+ LitPat _ _ ->

822+ []

823+ NPat _ _ _ _ ->

824+ []

825+ NPlusKPat _ n _ _ _ _ ->

826+ [ toHie $ C (PatternBind scope pscope rsp) n

827+ ]

828+ SigPat _ pat sig ->

829+ [ toHie $ PS rsp scope pscope pat

830+ , let cscope = mkLScope (dL pat) in

831+ toHie $ TS (ResolvedScopes [cscope, scope, pscope])

832+ (protectSig @a cscope sig)

833+ -- See Note [Scoping Rules for SigPat]

834+ ]

835+ CoPat _ _ _ _ ->

836+ []

837+ XPat _ -> []

838+ where

839+ contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args

840+ contextify (InfixCon a b) = InfixCon a' b'

841+ where [a', b'] = patScopes rsp scope pscope [a,b]

842+ contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r

843+ contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a

844+ where

845+ go (RS fscope (L spn (HsRecField lbl pat pun))) =

846+ L spn $ HsRecField lbl (PS rsp scope fscope pat) pun

847+ scoped_fds = listScopes pscope fds

848+

849+instance ( ToHie body

850+ , ToHie (LGRHS a body)

851+ , ToHie (RScoped (LHsLocalBinds a))

852+ ) => ToHie (GRHSs a body) where

853+ toHie grhs = concatM $ case grhs of

854+ GRHSs _ grhss binds ->

855+ [ toHie grhss

856+ , toHie $ RS (mkScope $ grhss_span grhs) binds

857+ ]

858+ XGRHSs _ -> []

859+

860+instance ( ToHie (Located body)

861+ , ToHie (RScoped (GuardLStmt a))

862+ , Data (GRHS a (Located body))

863+ ) => ToHie (LGRHS a (Located body)) where

864+ toHie (L span g) = concatM $ makeNode g span : case g of

865+ GRHS _ guards body ->

866+ [ toHie $ listScopes (mkLScope body) guards

867+ , toHie body

868+ ]

869+ XGRHS _ -> []

870+

871+instance ( a ~ GhcPass p

872+ , ToHie (Context (Located (IdP a)))

873+ , HasType (LHsExpr a)

874+ , ToHie (PScoped (LPat a))

875+ , ToHie (MatchGroup a (LHsExpr a))

876+ , ToHie (LGRHS a (LHsExpr a))

877+ , ToHie (RContext (HsRecordBinds a))

878+ , ToHie (RFContext (Located (AmbiguousFieldOcc a)))

879+ , ToHie (ArithSeqInfo a)

880+ , ToHie (LHsCmdTop a)

881+ , ToHie (RScoped (GuardLStmt a))

882+ , ToHie (RScoped (LHsLocalBinds a))

883+ , ToHie (TScoped (LHsWcType (NoGhcTc a)))

884+ , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))

885+ , Data (HsExpr a)

886+ , Data (HsSplice a)

887+ , Data (HsTupArg a)

888+ , Data (AmbiguousFieldOcc a)

889+ , (HasRealDataConName a)

890+ ) => ToHie (LHsExpr (GhcPass p)) where

891+ toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of

892+ HsVar _ (L _ var) ->

893+ [ toHie $ C Use (L mspan var)

894+ -- Patch up var location since typechecker removes it

895+ ]

896+ HsUnboundVar _ _ ->

897+ []

898+ HsConLikeOut _ con ->

899+ [ toHie $ C Use $ L mspan $ conLikeName con

900+ ]

901+ HsRecFld _ fld ->

902+ [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)

903+ ]

904+ HsOverLabel _ _ _ -> []

905+ HsIPVar _ _ -> []

906+ HsOverLit _ _ -> []

907+ HsLit _ _ -> []

908+ HsLam _ mg ->

909+ [ toHie mg

910+ ]

911+ HsLamCase _ mg ->

912+ [ toHie mg

913+ ]

914+ HsApp _ a b ->

915+ [ toHie a

916+ , toHie b

917+ ]

918+ HsAppType _ expr sig ->

919+ [ toHie expr

920+ , toHie $ TS (ResolvedScopes []) sig

921+ ]

922+ OpApp _ a b c ->

923+ [ toHie a

924+ , toHie b

925+ , toHie c

926+ ]

927+ NegApp _ a _ ->

928+ [ toHie a

929+ ]

930+ HsPar _ a ->

931+ [ toHie a

932+ ]

933+ SectionL _ a b ->

934+ [ toHie a

935+ , toHie b

936+ ]

937+ SectionR _ a b ->

938+ [ toHie a

939+ , toHie b

940+ ]

941+ ExplicitTuple _ args _ ->

942+ [ toHie args

943+ ]

944+ ExplicitSum _ _ _ expr ->

945+ [ toHie expr

946+ ]

947+ HsCase _ expr matches ->

948+ [ toHie expr

949+ , toHie matches

950+ ]

951+ HsIf _ _ a b c ->

952+ [ toHie a

953+ , toHie b

954+ , toHie c

955+ ]

956+ HsMultiIf _ grhss ->

957+ [ toHie grhss

958+ ]

959+ HsLet _ binds expr ->

960+ [ toHie $ RS (mkLScope expr) binds

961+ , toHie expr

962+ ]

963+ HsDo _ _ (L ispan stmts) ->

964+ [ pure $ locOnly ispan

965+ , toHie $ listScopes NoScope stmts

966+ ]

967+ ExplicitList _ _ exprs ->

968+ [ toHie exprs

969+ ]

970+ RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} ->

971+ [ toHie $ C Use (getRealDataCon @a mrealcon name)

972+ -- See Note [Real DataCon Name]

973+ , toHie $ RC RecFieldAssign $ binds

974+ ]

975+ RecordUpd {rupd_expr = expr, rupd_flds = upds}->

976+ [ toHie expr

977+ , toHie $ map (RC RecFieldAssign) upds

978+ ]

979+ ExprWithTySig _ expr sig ->

980+ [ toHie expr

981+ , toHie $ TS (ResolvedScopes [mkLScope expr]) sig

982+ ]

983+ ArithSeq _ _ info ->

984+ [ toHie info

985+ ]

986+ HsSCC _ _ _ expr ->

987+ [ toHie expr

988+ ]

989+ HsCoreAnn _ _ _ expr ->

990+ [ toHie expr

991+ ]

992+ HsProc _ pat cmdtop ->

993+ [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat

994+ , toHie cmdtop

995+ ]

996+ HsStatic _ expr ->

997+ [ toHie expr

998+ ]

999+ HsTick _ _ expr ->

1000+ [ toHie expr

1001+ ]

1002+ HsBinTick _ _ _ expr ->

1003+ [ toHie expr

1004+ ]

1005+ HsTickPragma _ _ _ _ expr ->

1006+ [ toHie expr

1007+ ]

1008+ HsWrap _ _ a ->

1009+ [ toHie $ L mspan a

1010+ ]

1011+ HsBracket _ b ->

1012+ [ toHie b

1013+ ]

1014+ HsRnBracketOut _ b p ->

1015+ [ toHie b

1016+ , toHie p

1017+ ]

1018+ HsTcBracketOut _ b p ->

1019+ [ toHie b

1020+ , toHie p

1021+ ]

1022+ HsSpliceE _ x ->

1023+ [ toHie $ L mspan x

1024+ ]

1025+ XExpr _ -> []

1026+

1027+instance ( a ~ GhcPass p

1028+ , ToHie (LHsExpr a)

1029+ , Data (HsTupArg a)

1030+ ) => ToHie (LHsTupArg (GhcPass p)) where

1031+ toHie (L span arg) = concatM $ makeNode arg span : case arg of

1032+ Present _ expr ->

1033+ [ toHie expr

1034+ ]

1035+ Missing _ -> []

1036+ XTupArg _ -> []

1037+

1038+instance ( a ~ GhcPass p

1039+ , ToHie (PScoped (LPat a))

1040+ , ToHie (LHsExpr a)

1041+ , ToHie (SigContext (LSig a))

1042+ , ToHie (RScoped (LHsLocalBinds a))

1043+ , ToHie (RScoped (ApplicativeArg a))

1044+ , ToHie (Located body)

1045+ , Data (StmtLR a a (Located body))

1046+ , Data (StmtLR a a (Located (HsExpr a)))

1047+ ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where

1048+ toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of

1049+ LastStmt _ body _ _ ->

1050+ [ toHie body

1051+ ]

1052+ BindStmt _ pat body _ _ ->

1053+ [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat

1054+ , toHie body

1055+ ]

1056+ ApplicativeStmt _ stmts _ ->

1057+ [ concatMapM (toHie . RS scope . snd) stmts

1058+ ]

1059+ BodyStmt _ body _ _ ->

1060+ [ toHie body

1061+ ]

1062+ LetStmt _ binds ->

1063+ [ toHie $ RS scope binds

1064+ ]

1065+ ParStmt _ parstmts _ _ ->

1066+ [ concatMapM (\(ParStmtBlock _ stmts _ _) ->

1067+ toHie $ listScopes NoScope stmts)

1068+ parstmts

1069+ ]

1070+ TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->

1071+ [ toHie $ listScopes scope stmts

1072+ , toHie using

1073+ , toHie by

1074+ ]

1075+ RecStmt {recS_stmts = stmts} ->

1076+ [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts

1077+ ]

1078+ XStmtLR _ -> []

1079+

1080+instance ( ToHie (LHsExpr a)

1081+ , ToHie (PScoped (LPat a))

1082+ , ToHie (BindContext (LHsBind a))

1083+ , ToHie (SigContext (LSig a))

1084+ , ToHie (RScoped (HsValBindsLR a a))

1085+ , Data (HsLocalBinds a)

1086+ ) => ToHie (RScoped (LHsLocalBinds a)) where

1087+ toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of

1088+ EmptyLocalBinds _ -> []

1089+ HsIPBinds _ _ -> []

1090+ HsValBinds _ valBinds ->

1091+ [ toHie $ RS (combineScopes scope $ mkScope sp)

1092+ valBinds

1093+ ]

1094+ XHsLocalBindsLR _ -> []

1095+

1096+instance ( ToHie (BindContext (LHsBind a))

1097+ , ToHie (SigContext (LSig a))

1098+ , ToHie (RScoped (XXValBindsLR a a))

1099+ ) => ToHie (RScoped (HsValBindsLR a a)) where

1100+ toHie (RS sc v) = concatM $ case v of

1101+ ValBinds _ binds sigs ->

1102+ [ toHie $ fmap (BC RegularBind sc) binds

1103+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs

1104+ ]

1105+ XValBindsLR x -> [ toHie $ RS sc x ]

1106+

1107+instance ToHie (RScoped (NHsValBindsLR GhcTc)) where

1108+ toHie (RS sc (NValBinds binds sigs)) = concatM $

1109+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)

1110+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs

1111+ ]

1112+instance ToHie (RScoped (NHsValBindsLR GhcRn)) where

1113+ toHie (RS sc (NValBinds binds sigs)) = concatM $

1114+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)

1115+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs

1116+ ]

1117+

1118+instance ( ToHie (RContext (LHsRecField a arg))

1119+ ) => ToHie (RContext (HsRecFields a arg)) where

1120+ toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields

1121+

1122+instance ( ToHie (RFContext (Located label))

1123+ , ToHie arg

1124+ , HasLoc arg

1125+ , Data label

1126+ , Data arg

1127+ ) => ToHie (RContext (LHsRecField' label arg)) where

1128+ toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of

1129+ HsRecField label expr _ ->

1130+ [ toHie $ RFC c (getRealSpan $ loc expr) label

1131+ , toHie expr

1132+ ]

1133+

1134+removeDefSrcSpan :: Name -> Name

1135+removeDefSrcSpan n = setNameLoc n noSrcSpan

1136+

1137+instance ToHie (RFContext (LFieldOcc GhcRn)) where

1138+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1139+ FieldOcc name _ ->

1140+ [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)

1141+ ]

1142+ XFieldOcc _ -> []

1143+

1144+instance ToHie (RFContext (LFieldOcc GhcTc)) where

1145+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1146+ FieldOcc var _ ->

1147+ let var' = setVarName var (removeDefSrcSpan $ varName var)

1148+ in [ toHie $ C (RecField c rhs) (L nspan var')

1149+ ]

1150+ XFieldOcc _ -> []

1151+

1152+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where

1153+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1154+ Unambiguous name _ ->

1155+ [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name

1156+ ]

1157+ Ambiguous _name _ ->

1158+ [ ]

1159+ XAmbiguousFieldOcc _ -> []

1160+

1161+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where

1162+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1163+ Unambiguous var _ ->

1164+ let var' = setVarName var (removeDefSrcSpan $ varName var)

1165+ in [ toHie $ C (RecField c rhs) (L nspan var')

1166+ ]

1167+ Ambiguous var _ ->

1168+ let var' = setVarName var (removeDefSrcSpan $ varName var)

1169+ in [ toHie $ C (RecField c rhs) (L nspan var')

1170+ ]

1171+ XAmbiguousFieldOcc _ -> []

1172+

1173+instance ( a ~ GhcPass p

1174+ , ToHie (PScoped (LPat a))

1175+ , ToHie (BindContext (LHsBind a))

1176+ , ToHie (LHsExpr a)

1177+ , ToHie (SigContext (LSig a))

1178+ , ToHie (RScoped (HsValBindsLR a a))

1179+ , Data (StmtLR a a (Located (HsExpr a)))

1180+ , Data (HsLocalBinds a)

1181+ ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where

1182+ toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM

1183+ [ toHie $ PS Nothing sc NoScope pat

1184+ , toHie expr

1185+ ]

1186+ toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM

1187+ [ toHie $ listScopes NoScope stmts

1188+ , toHie $ PS Nothing sc NoScope pat

1189+ ]

1190+ toHie (RS _ (XApplicativeArg _)) = pure []

1191+

1192+instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where

1193+ toHie (PrefixCon args) = toHie args

1194+ toHie (RecCon rec) = toHie rec

1195+ toHie (InfixCon a b) = concatM [ toHie a, toHie b]

1196+

1197+instance ( ToHie (LHsCmd a)

1198+ , Data (HsCmdTop a)

1199+ ) => ToHie (LHsCmdTop a) where

1200+ toHie (L span top) = concatM $ makeNode top span : case top of

1201+ HsCmdTop _ cmd ->

1202+ [ toHie cmd

1203+ ]

1204+ XCmdTop _ -> []

1205+

1206+instance ( a ~ GhcPass p

1207+ , ToHie (PScoped (LPat a))

1208+ , ToHie (BindContext (LHsBind a))

1209+ , ToHie (LHsExpr a)

1210+ , ToHie (MatchGroup a (LHsCmd a))

1211+ , ToHie (SigContext (LSig a))

1212+ , ToHie (RScoped (HsValBindsLR a a))

1213+ , Data (HsCmd a)

1214+ , Data (HsCmdTop a)

1215+ , Data (StmtLR a a (Located (HsCmd a)))

1216+ , Data (HsLocalBinds a)

1217+ , Data (StmtLR a a (Located (HsExpr a)))

1218+ ) => ToHie (LHsCmd (GhcPass p)) where

1219+ toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of

1220+ HsCmdArrApp _ a b _ _ ->

1221+ [ toHie a

1222+ , toHie b

1223+ ]

1224+ HsCmdArrForm _ a _ _ cmdtops ->

1225+ [ toHie a

1226+ , toHie cmdtops

1227+ ]

1228+ HsCmdApp _ a b ->

1229+ [ toHie a

1230+ , toHie b

1231+ ]

1232+ HsCmdLam _ mg ->

1233+ [ toHie mg

1234+ ]

1235+ HsCmdPar _ a ->

1236+ [ toHie a

1237+ ]

1238+ HsCmdCase _ expr alts ->

1239+ [ toHie expr

1240+ , toHie alts

1241+ ]

1242+ HsCmdIf _ _ a b c ->

1243+ [ toHie a

1244+ , toHie b

1245+ , toHie c

1246+ ]

1247+ HsCmdLet _ binds cmd' ->

1248+ [ toHie $ RS (mkLScope cmd') binds

1249+ , toHie cmd'

1250+ ]

1251+ HsCmdDo _ (L ispan stmts) ->

1252+ [ pure $ locOnly ispan

1253+ , toHie $ listScopes NoScope stmts

1254+ ]

1255+ HsCmdWrap _ _ _ -> []

1256+ XCmd _ -> []

1257+

1258+instance ToHie (TyClGroup GhcRn) where

1259+ toHie TyClGroup{ group_tyclds = classes

1260+ , group_roles = roles

1261+ , group_kisigs = sigs

1262+ , group_instds = instances } =

1263+ concatM

1264+ [ toHie classes

1265+ , toHie sigs

1266+ , toHie roles

1267+ , toHie instances

1268+ ]

1269+ toHie (XTyClGroup _) = pure []

1270+

1271+instance ToHie (LTyClDecl GhcRn) where

1272+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1273+ FamDecl {tcdFam = fdecl} ->

1274+ [ toHie (L span fdecl)

1275+ ]

1276+ SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->

1277+ [ toHie $ C (Decl SynDec $ getRealSpan span) name

1278+ , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars

1279+ , toHie typ

1280+ ]

1281+ DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->

1282+ [ toHie $ C (Decl DataDec $ getRealSpan span) name

1283+ , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars

1284+ , toHie defn

1285+ ]

1286+ where

1287+ quant_scope = mkLScope $ dd_ctxt defn

1288+ rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc

1289+ sig_sc = maybe NoScope mkLScope $ dd_kindSig defn

1290+ con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn

1291+ deriv_sc = mkLScope $ dd_derivs defn

1292+ ClassDecl { tcdCtxt = context

1293+ , tcdLName = name

1294+ , tcdTyVars = vars

1295+ , tcdFDs = deps

1296+ , tcdSigs = sigs

1297+ , tcdMeths = meths

1298+ , tcdATs = typs

1299+ , tcdATDefs = deftyps

1300+ } ->

1301+ [ toHie $ C (Decl ClassDec $ getRealSpan span) name

1302+ , toHie context

1303+ , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars

1304+ , toHie deps

1305+ , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs

1306+ , toHie $ fmap (BC InstanceBind ModuleScope) meths

1307+ , toHie typs

1308+ , concatMapM (pure . locOnly . getLoc) deftyps

1309+ , toHie deftyps

1310+ ]

1311+ where

1312+ context_scope = mkLScope context

1313+ rhs_scope = foldl1' combineScopes $ map mkScope

1314+ [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]

1315+ XTyClDecl _ -> []

1316+

1317+instance ToHie (LFamilyDecl GhcRn) where

1318+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1319+ FamilyDecl _ info name vars _ sig inj ->

1320+ [ toHie $ C (Decl FamDec $ getRealSpan span) name

1321+ , toHie $ TS (ResolvedScopes [rhsSpan]) vars

1322+ , toHie info

1323+ , toHie $ RS injSpan sig

1324+ , toHie inj

1325+ ]

1326+ where

1327+ rhsSpan = sigSpan `combineScopes` injSpan

1328+ sigSpan = mkScope $ getLoc sig

1329+ injSpan = maybe NoScope (mkScope . getLoc) inj

1330+ XFamilyDecl _ -> []

1331+

1332+instance ToHie (FamilyInfo GhcRn) where

1333+ toHie (ClosedTypeFamily (Just eqns)) = concatM $

1334+ [ concatMapM (pure . locOnly . getLoc) eqns

1335+ , toHie $ map go eqns

1336+ ]

1337+ where

1338+ go (L l ib) = TS (ResolvedScopes [mkScope l]) ib

1339+ toHie _ = pure []

1340+

1341+instance ToHie (RScoped (LFamilyResultSig GhcRn)) where

1342+ toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of

1343+ NoSig _ ->

1344+ []

1345+ KindSig _ k ->

1346+ [ toHie k

1347+ ]

1348+ TyVarSig _ bndr ->

1349+ [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr

1350+ ]

1351+ XFamilyResultSig _ -> []

1352+

1353+instance ToHie (Located (FunDep (Located Name))) where

1354+ toHie (L span fd@(lhs, rhs)) = concatM $

1355+ [ makeNode fd span

1356+ , toHie $ map (C Use) lhs

1357+ , toHie $ map (C Use) rhs

1358+ ]

1359+

1360+instance (ToHie rhs, HasLoc rhs)

1361+ => ToHie (TScoped (FamEqn GhcRn rhs)) where

1362+ toHie (TS _ f) = toHie f

1363+

1364+instance (ToHie rhs, HasLoc rhs)

1365+ => ToHie (FamEqn GhcRn rhs) where

1366+ toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $

1367+ [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var

1368+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1369+ , toHie pats

1370+ , toHie rhs

1371+ ]

1372+ where scope = combineScopes patsScope rhsScope

1373+ patsScope = mkScope (loc pats)

1374+ rhsScope = mkScope (loc rhs)

1375+ toHie (XFamEqn _) = pure []

1376+

1377+instance ToHie (LInjectivityAnn GhcRn) where

1378+ toHie (L span ann) = concatM $ makeNode ann span : case ann of

1379+ InjectivityAnn lhs rhs ->

1380+ [ toHie $ C Use lhs

1381+ , toHie $ map (C Use) rhs

1382+ ]

1383+

1384+instance ToHie (HsDataDefn GhcRn) where

1385+ toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM

1386+ [ toHie ctx

1387+ , toHie mkind

1388+ , toHie cons

1389+ , toHie derivs

1390+ ]

1391+ toHie (XHsDataDefn _) = pure []

1392+

1393+instance ToHie (HsDeriving GhcRn) where

1394+ toHie (L span clauses) = concatM

1395+ [ pure $ locOnly span

1396+ , toHie clauses

1397+ ]

1398+

1399+instance ToHie (LHsDerivingClause GhcRn) where

1400+ toHie (L span cl) = concatM $ makeNode cl span : case cl of

1401+ HsDerivingClause _ strat (L ispan tys) ->

1402+ [ toHie strat

1403+ , pure $ locOnly ispan

1404+ , toHie $ map (TS (ResolvedScopes [])) tys

1405+ ]

1406+ XHsDerivingClause _ -> []

1407+

1408+instance ToHie (Located (DerivStrategy GhcRn)) where

1409+ toHie (L span strat) = concatM $ makeNode strat span : case strat of

1410+ StockStrategy -> []

1411+ AnyclassStrategy -> []

1412+ NewtypeStrategy -> []

1413+ ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]

1414+

1415+instance ToHie (Located OverlapMode) where

1416+ toHie (L span _) = pure $ locOnly span

1417+

1418+instance ToHie (LConDecl GhcRn) where

1419+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1420+ ConDeclGADT { con_names = names, con_qvars = qvars

1421+ , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->

1422+ [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names

1423+ , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars

1424+ , toHie ctx

1425+ , toHie args

1426+ , toHie typ

1427+ ]

1428+ where

1429+ rhsScope = combineScopes argsScope tyScope

1430+ ctxScope = maybe NoScope mkLScope ctx

1431+ argsScope = condecl_scope args

1432+ tyScope = mkLScope typ

1433+ ConDeclH98 { con_name = name, con_ex_tvs = qvars

1434+ , con_mb_cxt = ctx, con_args = dets } ->

1435+ [ toHie $ C (Decl ConDec $ getRealSpan span) name

1436+ , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars

1437+ , toHie ctx

1438+ , toHie dets

1439+ ]

1440+ where

1441+ rhsScope = combineScopes ctxScope argsScope

1442+ ctxScope = maybe NoScope mkLScope ctx

1443+ argsScope = condecl_scope dets

1444+ XConDecl _ -> []

1445+ where condecl_scope args = case args of

1446+ PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs

1447+ InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)

1448+ RecCon x -> mkLScope x

1449+

1450+instance ToHie (Located [LConDeclField GhcRn]) where

1451+ toHie (L span decls) = concatM $

1452+ [ pure $ locOnly span

1453+ , toHie decls

1454+ ]

1455+

1456+instance ( HasLoc thing

1457+ , ToHie (TScoped thing)

1458+ ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where

1459+ toHie (TS sc (HsIB ibrn a)) = concatM $

1460+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn

1461+ , toHie $ TS sc a

1462+ ]

1463+ where span = loc a

1464+ toHie (TS _ (XHsImplicitBndrs _)) = pure []

1465+

1466+instance ( HasLoc thing

1467+ , ToHie (TScoped thing)

1468+ ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where

1469+ toHie (TS sc (HsWC names a)) = concatM $

1470+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names

1471+ , toHie $ TS sc a

1472+ ]

1473+ where span = loc a

1474+ toHie (TS _ (XHsWildCardBndrs _)) = pure []

1475+

1476+instance ToHie (LStandaloneKindSig GhcRn) where

1477+ toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]

1478+

1479+instance ToHie (StandaloneKindSig GhcRn) where

1480+ toHie sig = concatM $ case sig of

1481+ StandaloneKindSig _ name typ ->

1482+ [ toHie $ C TyDecl name

1483+ , toHie $ TS (ResolvedScopes []) typ

1484+ ]

1485+ XStandaloneKindSig _ -> []

1486+

1487+instance ToHie (SigContext (LSig GhcRn)) where

1488+ toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of

1489+ TypeSig _ names typ ->

1490+ [ toHie $ map (C TyDecl) names

1491+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1492+ ]

1493+ PatSynSig _ names typ ->

1494+ [ toHie $ map (C TyDecl) names

1495+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1496+ ]

1497+ ClassOpSig _ _ names typ ->

1498+ [ case styp of

1499+ ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names

1500+ _ -> toHie $ map (C $ TyDecl) names

1501+ , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ

1502+ ]

1503+ IdSig _ _ -> []

1504+ FixSig _ fsig ->

1505+ [ toHie $ L sp fsig

1506+ ]

1507+ InlineSig _ name _ ->

1508+ [ toHie $ (C Use) name

1509+ ]

1510+ SpecSig _ name typs _ ->

1511+ [ toHie $ (C Use) name

1512+ , toHie $ map (TS (ResolvedScopes [])) typs

1513+ ]

1514+ SpecInstSig _ _ typ ->

1515+ [ toHie $ TS (ResolvedScopes []) typ

1516+ ]

1517+ MinimalSig _ _ form ->

1518+ [ toHie form

1519+ ]

1520+ SCCFunSig _ _ name mtxt ->

1521+ [ toHie $ (C Use) name

1522+ , pure $ maybe [] (locOnly . getLoc) mtxt

1523+ ]

1524+ CompleteMatchSig _ _ (L ispan names) typ ->

1525+ [ pure $ locOnly ispan

1526+ , toHie $ map (C Use) names

1527+ , toHie $ fmap (C Use) typ

1528+ ]

1529+ XSig _ -> []

1530+

1531+instance ToHie (LHsType GhcRn) where

1532+ toHie x = toHie $ TS (ResolvedScopes []) x

1533+

1534+instance ToHie (TScoped (LHsType GhcRn)) where

1535+ toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of

1536+ HsForAllTy _ _ bndrs body ->

1537+ [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs

1538+ , toHie body

1539+ ]

1540+ HsQualTy _ ctx body ->

1541+ [ toHie ctx

1542+ , toHie body

1543+ ]

1544+ HsTyVar _ _ var ->

1545+ [ toHie $ C Use var

1546+ ]

1547+ HsAppTy _ a b ->

1548+ [ toHie a

1549+ , toHie b

1550+ ]

1551+ HsAppKindTy _ ty ki ->

1552+ [ toHie ty

1553+ , toHie $ TS (ResolvedScopes []) ki

1554+ ]

1555+ HsFunTy _ a b ->

1556+ [ toHie a

1557+ , toHie b

1558+ ]

1559+ HsListTy _ a ->

1560+ [ toHie a

1561+ ]

1562+ HsTupleTy _ _ tys ->

1563+ [ toHie tys

1564+ ]

1565+ HsSumTy _ tys ->

1566+ [ toHie tys

1567+ ]

1568+ HsOpTy _ a op b ->

1569+ [ toHie a

1570+ , toHie $ C Use op

1571+ , toHie b

1572+ ]

1573+ HsParTy _ a ->

1574+ [ toHie a

1575+ ]

1576+ HsIParamTy _ ip ty ->

1577+ [ toHie ip

1578+ , toHie ty

1579+ ]

1580+ HsKindSig _ a b ->

1581+ [ toHie a

1582+ , toHie b

1583+ ]

1584+ HsSpliceTy _ a ->

1585+ [ toHie $ L span a

1586+ ]

1587+ HsDocTy _ a _ ->

1588+ [ toHie a

1589+ ]

1590+ HsBangTy _ _ ty ->

1591+ [ toHie ty

1592+ ]

1593+ HsRecTy _ fields ->

1594+ [ toHie fields

1595+ ]

1596+ HsExplicitListTy _ _ tys ->

1597+ [ toHie tys

1598+ ]

1599+ HsExplicitTupleTy _ tys ->

1600+ [ toHie tys

1601+ ]

1602+ HsTyLit _ _ -> []

1603+ HsWildCardTy _ -> []

1604+ HsStarTy _ _ -> []

1605+ XHsType _ -> []

1606+

1607+instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where

1608+ toHie (HsValArg tm) = toHie tm

1609+ toHie (HsTypeArg _ ty) = toHie ty

1610+ toHie (HsArgPar sp) = pure $ locOnly sp

1611+

1612+instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where

1613+ toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1614+ UserTyVar _ var ->

1615+ [ toHie $ C (TyVarBind sc tsc) var

1616+ ]

1617+ KindedTyVar _ var kind ->

1618+ [ toHie $ C (TyVarBind sc tsc) var

1619+ , toHie kind

1620+ ]

1621+ XTyVarBndr _ -> []

1622+

1623+instance ToHie (TScoped (LHsQTyVars GhcRn)) where

1624+ toHie (TS sc (HsQTvs implicits vars)) = concatM $

1625+ [ pure $ bindingsOnly bindings

1626+ , toHie $ tvScopes sc NoScope vars

1627+ ]

1628+ where

1629+ varLoc = loc vars

1630+ bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits

1631+ toHie (TS _ (XLHsQTyVars _)) = pure []

1632+

1633+instance ToHie (LHsContext GhcRn) where

1634+ toHie (L span tys) = concatM $

1635+ [ pure $ locOnly span

1636+ , toHie tys

1637+ ]

1638+

1639+instance ToHie (LConDeclField GhcRn) where

1640+ toHie (L span field) = concatM $ makeNode field span : case field of

1641+ ConDeclField _ fields typ _ ->

1642+ [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields

1643+ , toHie typ

1644+ ]

1645+ XConDeclField _ -> []

1646+

1647+instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where

1648+ toHie (From expr) = toHie expr

1649+ toHie (FromThen a b) = concatM $

1650+ [ toHie a

1651+ , toHie b

1652+ ]

1653+ toHie (FromTo a b) = concatM $

1654+ [ toHie a

1655+ , toHie b

1656+ ]

1657+ toHie (FromThenTo a b c) = concatM $

1658+ [ toHie a

1659+ , toHie b

1660+ , toHie c

1661+ ]

1662+

1663+instance ToHie (LSpliceDecl GhcRn) where

1664+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1665+ SpliceDecl _ splice _ ->

1666+ [ toHie splice

1667+ ]

1668+ XSpliceDecl _ -> []

1669+

1670+instance ToHie (HsBracket a) where

1671+ toHie _ = pure []

1672+

1673+instance ToHie PendingRnSplice where

1674+ toHie _ = pure []

1675+

1676+instance ToHie PendingTcSplice where

1677+ toHie _ = pure []

1678+

1679+instance ToHie (LBooleanFormula (Located Name)) where

1680+ toHie (L span form) = concatM $ makeNode form span : case form of

1681+ Var a ->

1682+ [ toHie $ C Use a

1683+ ]

1684+ And forms ->

1685+ [ toHie forms

1686+ ]

1687+ Or forms ->

1688+ [ toHie forms

1689+ ]

1690+ Parens f ->

1691+ [ toHie f

1692+ ]

1693+

1694+instance ToHie (Located HsIPName) where

1695+ toHie (L span e) = makeNode e span

1696+

1697+instance ( ToHie (LHsExpr a)

1698+ , Data (HsSplice a)

1699+ ) => ToHie (Located (HsSplice a)) where

1700+ toHie (L span sp) = concatM $ makeNode sp span : case sp of

1701+ HsTypedSplice _ _ _ expr ->

1702+ [ toHie expr

1703+ ]

1704+ HsUntypedSplice _ _ _ expr ->

1705+ [ toHie expr

1706+ ]

1707+ HsQuasiQuote _ _ _ ispan _ ->

1708+ [ pure $ locOnly ispan

1709+ ]

1710+ HsSpliced _ _ _ ->

1711+ []

1712+ HsSplicedT _ ->

1713+ []

1714+ XSplice _ -> []

1715+

1716+instance ToHie (LRoleAnnotDecl GhcRn) where

1717+ toHie (L span annot) = concatM $ makeNode annot span : case annot of

1718+ RoleAnnotDecl _ var roles ->

1719+ [ toHie $ C Use var

1720+ , concatMapM (pure . locOnly . getLoc) roles

1721+ ]

1722+ XRoleAnnotDecl _ -> []

1723+

1724+instance ToHie (LInstDecl GhcRn) where

1725+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1726+ ClsInstD _ d ->

1727+ [ toHie $ L span d

1728+ ]

1729+ DataFamInstD _ d ->

1730+ [ toHie $ L span d

1731+ ]

1732+ TyFamInstD _ d ->

1733+ [ toHie $ L span d

1734+ ]

1735+ XInstDecl _ -> []

1736+

1737+instance ToHie (LClsInstDecl GhcRn) where

1738+ toHie (L span decl) = concatM

1739+ [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl

1740+ , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl

1741+ , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl

1742+ , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl

1743+ , toHie $ cid_tyfam_insts decl

1744+ , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl

1745+ , toHie $ cid_datafam_insts decl

1746+ , toHie $ cid_overlap_mode decl

1747+ ]

1748+

1749+instance ToHie (LDataFamInstDecl GhcRn) where

1750+ toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1751+

1752+instance ToHie (LTyFamInstDecl GhcRn) where

1753+ toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1754+

1755+instance ToHie (Context a)

1756+ => ToHie (PatSynFieldContext (RecordPatSynField a)) where

1757+ toHie (PSC sp (RecordPatSynField a b)) = concatM $

1758+ [ toHie $ C (RecField RecFieldDecl sp) a

1759+ , toHie $ C Use b

1760+ ]

1761+

1762+instance ToHie (LDerivDecl GhcRn) where

1763+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1764+ DerivDecl _ typ strat overlap ->

1765+ [ toHie $ TS (ResolvedScopes []) typ

1766+ , toHie strat

1767+ , toHie overlap

1768+ ]

1769+ XDerivDecl _ -> []

1770+

1771+instance ToHie (LFixitySig GhcRn) where

1772+ toHie (L span sig) = concatM $ makeNode sig span : case sig of

1773+ FixitySig _ vars _ ->

1774+ [ toHie $ map (C Use) vars

1775+ ]

1776+ XFixitySig _ -> []

1777+

1778+instance ToHie (LDefaultDecl GhcRn) where

1779+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1780+ DefaultDecl _ typs ->

1781+ [ toHie typs

1782+ ]

1783+ XDefaultDecl _ -> []

1784+

1785+instance ToHie (LForeignDecl GhcRn) where

1786+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1787+ ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->

1788+ [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name

1789+ , toHie $ TS (ResolvedScopes []) sig

1790+ , toHie fi

1791+ ]

1792+ ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->

1793+ [ toHie $ C Use name

1794+ , toHie $ TS (ResolvedScopes []) sig

1795+ , toHie fe

1796+ ]

1797+ XForeignDecl _ -> []

1798+

1799+instance ToHie ForeignImport where

1800+ toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $

1801+ [ locOnly a

1802+ , locOnly b

1803+ , locOnly c

1804+ ]

1805+

1806+instance ToHie ForeignExport where

1807+ toHie (CExport (L a _) (L b _)) = pure $ concat $

1808+ [ locOnly a

1809+ , locOnly b

1810+ ]

1811+

1812+instance ToHie (LWarnDecls GhcRn) where

1813+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1814+ Warnings _ _ warnings ->

1815+ [ toHie warnings

1816+ ]

1817+ XWarnDecls _ -> []

1818+

1819+instance ToHie (LWarnDecl GhcRn) where

1820+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1821+ Warning _ vars _ ->

1822+ [ toHie $ map (C Use) vars

1823+ ]

1824+ XWarnDecl _ -> []

1825+

1826+instance ToHie (LAnnDecl GhcRn) where

1827+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1828+ HsAnnotation _ _ prov expr ->

1829+ [ toHie prov

1830+ , toHie expr

1831+ ]

1832+ XAnnDecl _ -> []

1833+

1834+instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where

1835+ toHie (ValueAnnProvenance a) = toHie $ C Use a

1836+ toHie (TypeAnnProvenance a) = toHie $ C Use a

1837+ toHie ModuleAnnProvenance = pure []

1838+

1839+instance ToHie (LRuleDecls GhcRn) where

1840+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1841+ HsRules _ _ rules ->

1842+ [ toHie rules

1843+ ]

1844+ XRuleDecls _ -> []

1845+

1846+instance ToHie (LRuleDecl GhcRn) where

1847+ toHie (L _ (XRuleDecl _)) = pure []

1848+ toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM

1849+ [ makeNode r span

1850+ , pure $ locOnly $ getLoc rname

1851+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1852+ , toHie $ map (RS $ mkScope span) bndrs

1853+ , toHie exprA

1854+ , toHie exprB

1855+ ]

1856+ where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc

1857+ bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)

1858+ exprA_sc = mkLScope exprA

1859+ exprB_sc = mkLScope exprB

1860+

1861+instance ToHie (RScoped (LRuleBndr GhcRn)) where

1862+ toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1863+ RuleBndr _ var ->

1864+ [ toHie $ C (ValBind RegularBind sc Nothing) var

1865+ ]

1866+ RuleBndrSig _ var typ ->

1867+ [ toHie $ C (ValBind RegularBind sc Nothing) var

1868+ , toHie $ TS (ResolvedScopes [sc]) typ

1869+ ]

1870+ XRuleBndr _ -> []

1871+

1872+instance ToHie (LImportDecl GhcRn) where

1873+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1874+ ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->

1875+ [ toHie $ IEC Import name

1876+ , toHie $ fmap (IEC ImportAs) as

1877+ , maybe (pure []) goIE hidden

1878+ ]

1879+ XImportDecl _ -> []

1880+ where

1881+ goIE (hiding, (L sp liens)) = concatM $

1882+ [ pure $ locOnly sp

1883+ , toHie $ map (IEC c) liens

1884+ ]

1885+ where

1886+ c = if hiding then ImportHiding else Import

1887+

1888+instance ToHie (IEContext (LIE GhcRn)) where

1889+ toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of

1890+ IEVar _ n ->

1891+ [ toHie $ IEC c n

1892+ ]

1893+ IEThingAbs _ n ->

1894+ [ toHie $ IEC c n

1895+ ]

1896+ IEThingAll _ n ->

1897+ [ toHie $ IEC c n

1898+ ]

1899+ IEThingWith _ n _ ns flds ->

1900+ [ toHie $ IEC c n

1901+ , toHie $ map (IEC c) ns

1902+ , toHie $ map (IEC c) flds

1903+ ]

1904+ IEModuleContents _ n ->

1905+ [ toHie $ IEC c n

1906+ ]

1907+ IEGroup _ _ _ -> []

1908+ IEDoc _ _ -> []

1909+ IEDocNamed _ _ -> []

1910+ XIE _ -> []

1911+

1912+instance ToHie (IEContext (LIEWrappedName Name)) where

1913+ toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of

1914+ IEName n ->

1915+ [ toHie $ C (IEThing c) n

1916+ ]

1917+ IEPattern p ->

1918+ [ toHie $ C (IEThing c) p

1919+ ]

1920+ IEType n ->

1921+ [ toHie $ C (IEThing c) n

1922+ ]

1923+

1924+instance ToHie (IEContext (Located (FieldLbl Name))) where

1925+ toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of

1926+ FieldLabel _ _ n ->

1927+ [ toHie $ C (IEThing c) $ L span n

1928+ ]

src-ghc88/Development/IDE/GHC/HieAst.hsnew file+1789

@@ -0,0 +1,1789 @@

2+{-

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

5+Main functions for .hie file generation

6+-}

7+{- HLINT ignore -}

8+{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE FlexibleInstances #-}

10+{-# LANGUAGE UndecidableInstances #-}

11+{-# LANGUAGE FlexibleContexts #-}

12+{-# LANGUAGE TypeSynonymInstances #-}

13+{-# LANGUAGE ScopedTypeVariables #-}

14+{-# LANGUAGE TypeFamilies #-}

15+{-# LANGUAGE TypeApplications #-}

16+{-# LANGUAGE AllowAmbiguousTypes #-}

17+{-# LANGUAGE ViewPatterns #-}

18+{-# LANGUAGE DeriveDataTypeable #-}

19+module Development.IDE.GHC.HieAst ( mkHieFile ) where

20+

21+import Avail ( Avails )

22+import Bag ( Bag, bagToList )

23+import BasicTypes

24+import BooleanFormula

25+import Class ( FunDep )

26+import CoreUtils ( exprType )

27+import ConLike ( conLikeName )

28+import Desugar ( deSugarExpr )

29+import FieldLabel

30+import HsSyn

31+import HscTypes

32+import Module ( ModuleName, ml_hs_file )

33+import MonadUtils ( concatMapM, liftIO )

34+import Name ( Name, nameSrcSpan, setNameLoc )

35+import SrcLoc

36+import TcHsSyn ( hsLitType, hsPatType )

37+import Type ( mkFunTys, Type )

38+import TysWiredIn ( mkListTy, mkSumTy )

39+import Var ( Id, Var, setVarName, varName, varType )

40+import TcRnTypes

41+import MkIface ( mkIfaceExports )

42+

43+import HieTypes

44+import HieUtils

45+

46+import qualified Data.Array as A

47+import qualified Data.ByteString as BS

48+import qualified Data.Map as M

49+import qualified Data.Set as S

50+import Data.Data ( Data, Typeable )

51+import Data.List (foldl', foldl1' )

52+import Data.Maybe ( listToMaybe )

53+import Control.Monad.Trans.Reader

54+import Control.Monad.Trans.Class ( lift )

55+

56+-- These synonyms match those defined in main/GHC.hs

57+type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn]

58+ , Maybe [(LIE GhcRn, Avails)]

59+ , Maybe LHsDocString )

60+type TypecheckedSource = LHsBinds GhcTc

61+

62+

63+{- Note [Name Remapping]

64+The Typechecker introduces new names for mono names in AbsBinds.

65+We don't care about the distinction between mono and poly bindings,

66+so we replace all occurrences of the mono name with the poly name.

67+-}

68+newtype HieState = HieState

69+ { name_remapping :: M.Map Name Id

70+ }

71+

72+initState :: HieState

73+initState = HieState M.empty

74+

75+class ModifyState a where -- See Note [Name Remapping]

76+ addSubstitution :: a -> a -> HieState -> HieState

77+

78+instance ModifyState Name where

79+ addSubstitution _ _ hs = hs

80+

81+instance ModifyState Id where

82+ addSubstitution mono poly hs =

83+ hs{name_remapping = M.insert (varName mono) poly (name_remapping hs)}

84+

85+modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState

86+modifyState = foldr go id

87+ where

88+ go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f

89+ go _ f = f

90+

91+type HieM = ReaderT HieState Hsc

92+

93+-- | Construct an 'HieFile' from the outputs of the typechecker.

94+mkHieFile :: ModSummary

95+ -> TcGblEnv

96+ -> RenamedSource

97+ -> BS.ByteString

98+ -> Hsc HieFile

99+mkHieFile ms ts rs src = do

100+ let tc_binds = tcg_binds ts

101+ (asts', arr) <- getCompressedAsts tc_binds rs

102+ let Just src_file = ml_hs_file $ ms_location ms

103+ return $ HieFile

104+ { hie_hs_file = src_file

105+ , hie_module = ms_mod ms

106+ , hie_types = arr

107+ , hie_asts = asts'

108+ -- mkIfaceExports sorts the AvailInfos for stability

109+ , hie_exports = mkIfaceExports (tcg_exports ts)

110+ , hie_hs_src = src

111+ }

112+

113+getCompressedAsts :: TypecheckedSource -> RenamedSource

114+ -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)

115+getCompressedAsts ts rs = do

116+ asts <- enrichHie ts rs

117+ return $ compressTypes asts

118+

119+enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)

120+enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do

121+ tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts

122+ rasts <- processGrp hsGrp

123+ imps <- toHie $ filter (not . ideclImplicit . unLoc) imports

124+ exps <- toHie $ fmap (map $ IEC Export . fst) exports

125+ let spanFile children = case children of

126+ [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)

127+ _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)

128+ (realSrcSpanEnd $ nodeSpan $ last children)

129+

130+ modulify xs =

131+ Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs

132+

133+ asts = HieASTs

134+ $ resolveTyVarScopes

135+ $ M.map (modulify . mergeSortAsts)

136+ $ M.fromListWith (++)

137+ $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts

138+

139+ flat_asts = concat

140+ [ tasts

141+ , rasts

142+ , imps

143+ , exps

144+ ]

145+ return asts

146+ where

147+ processGrp grp = concatM

148+ [ toHie $ fmap (RS ModuleScope ) hs_valds grp

149+ , toHie $ hs_splcds grp

150+ , toHie $ hs_tyclds grp

151+ , toHie $ hs_derivds grp

152+ , toHie $ hs_fixds grp

153+ , toHie $ hs_defds grp

154+ , toHie $ hs_fords grp

155+ , toHie $ hs_warnds grp

156+ , toHie $ hs_annds grp

157+ , toHie $ hs_ruleds grp

158+ ]

159+

160+getRealSpan :: SrcSpan -> Maybe Span

161+getRealSpan (RealSrcSpan sp) = Just sp

162+getRealSpan _ = Nothing

163+

164+grhss_span :: GRHSs p body -> SrcSpan

165+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)

166+grhss_span (XGRHSs _) = error "XGRHS has no span"

167+

168+bindingsOnly :: [Context Name] -> [HieAST a]

169+bindingsOnly [] = []

170+bindingsOnly (C c n : xs) = case nameSrcSpan n of

171+ RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs

172+ where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)

173+ info = mempty{identInfo = S.singleton c}

174+ _ -> bindingsOnly xs

175+

176+concatM :: Monad m => [m [a]] -> m [a]

177+concatM xs = concat <$> sequence xs

178+

179+{- Note [Capturing Scopes and other non local information]

180+toHie is a local tranformation, but scopes of bindings cannot be known locally,

181+hence we have to push the relevant info down into the binding nodes.

182+We use the following types (*Context and *Scoped) to wrap things and

183+carry the required info

184+(Maybe Span) always carries the span of the entire binding, including rhs

185+-}

186+data Context a = C ContextInfo a -- Used for names and bindings

187+

188+data RContext a = RC RecFieldContext a

189+data RFContext a = RFC RecFieldContext (Maybe Span) a

190+-- ^ context for record fields

191+

192+data IEContext a = IEC IEType a

193+-- ^ context for imports/exports

194+

195+data BindContext a = BC BindType Scope a

196+-- ^ context for imports/exports

197+

198+data PatSynFieldContext a = PSC (Maybe Span) a

199+-- ^ context for pattern synonym fields.

200+

201+data SigContext a = SC SigInfo a

202+-- ^ context for type signatures

203+

204+data SigInfo = SI SigType (Maybe Span)

205+

206+data SigType = BindSig | ClassSig | InstSig

207+

208+data RScoped a = RS Scope a

209+-- ^ Scope spans over everything to the right of a, (mostly) not

210+-- including a itself

211+-- (Includes a in a few special cases like recursive do bindings) or

212+-- let/where bindings

213+

214+-- | Pattern scope

215+data PScoped a = PS (Maybe Span)

216+ Scope -- ^ use site of the pattern

217+ Scope -- ^ pattern to the right of a, not including a

218+ a

219+ deriving (Typeable, Data) -- Pattern Scope

220+

221+{- Note [TyVar Scopes]

222+Due to -XScopedTypeVariables, type variables can be in scope quite far from

223+their original binding. We resolve the scope of these type variables

224+in a separate pass

225+-}

226+data TScoped a = TS TyVarScope a -- TyVarScope

227+

228+data TVScoped a = TVS TyVarScope Scope a -- TyVarScope

229+-- ^ First scope remains constant

230+-- Second scope is used to build up the scope of a tyvar over

231+-- things to its right, ala RScoped

232+

233+-- | Each element scopes over the elements to the right

234+listScopes :: Scope -> [Located a] -> [RScoped (Located a)]

235+listScopes _ [] = []

236+listScopes rhsScope [pat] = [RS rhsScope pat]

237+listScopes rhsScope (pat : pats) = RS sc pat : pats'

238+ where

239+ pats'@((RS scope p):_) = listScopes rhsScope pats

240+ sc = combineScopes scope $ mkScope $ getLoc p

241+

242+-- | 'listScopes' specialised to 'PScoped' things

243+patScopes

244+ :: Maybe Span

245+ -> Scope

246+ -> Scope

247+ -> [LPat (GhcPass p)]

248+ -> [PScoped (LPat (GhcPass p))]

249+patScopes rsp useScope patScope xs =

250+ map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $

251+ listScopes patScope (map dL xs)

252+

253+-- | 'listScopes' specialised to 'TVScoped' things

254+tvScopes

255+ :: TyVarScope

256+ -> Scope

257+ -> [LHsTyVarBndr a]

258+ -> [TVScoped (LHsTyVarBndr a)]

259+tvScopes tvScope rhsScope xs =

260+ map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs

261+

262+{- Note [Scoping Rules for SigPat]

263+Explicitly quantified variables in pattern type signatures are not

264+brought into scope in the rhs, but implicitly quantified variables

265+are (HsWC and HsIB).

266+This is unlike other signatures, where explicitly quantified variables

267+are brought into the RHS Scope

268+For example

269+foo :: forall a. ...;

270+foo = ... -- a is in scope here

271+

272+bar (x :: forall a. a -> a) = ... -- a is not in scope here

273+-- ^ a is in scope here (pattern body)

274+

275+bax (x :: a) = ... -- a is in scope here

276+Because of HsWC and HsIB pass on their scope to their children

277+we must wrap the LHsType in pattern signatures in a

278+Shielded explictly, so that the HsWC/HsIB scope is not passed

279+on the the LHsType

280+-}

281+

282+data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead

283+

284+type family ProtectedSig a where

285+ ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs

286+ GhcRn

287+ (Shielded (LHsType GhcRn)))

288+ ProtectedSig GhcTc = NoExt

289+

290+class ProtectSig a where

291+ protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a

292+

293+instance (HasLoc a) => HasLoc (Shielded a) where

294+ loc (SH _ a) = loc a

295+

296+instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where

297+ toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)

298+

299+instance ProtectSig GhcTc where

300+ protectSig _ _ = NoExt

301+

302+instance ProtectSig GhcRn where

303+ protectSig sc (HsWC a (HsIB b sig)) =

304+ HsWC a (HsIB b (SH sc sig))

305+ protectSig _ _ = error "protectSig not given HsWC (HsIB)"

306+

307+class HasLoc a where

308+ -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can

309+ -- know what their implicit bindings are scoping over

310+ loc :: a -> SrcSpan

311+

312+instance HasLoc thing => HasLoc (TScoped thing) where

313+ loc (TS _ a) = loc a

314+

315+instance HasLoc thing => HasLoc (PScoped thing) where

316+ loc (PS _ _ _ a) = loc a

317+

318+instance HasLoc (LHsQTyVars GhcRn) where

319+ loc (HsQTvs _ vs) = loc vs

320+ loc _ = noSrcSpan

321+

322+instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where

323+ loc (HsIB _ a) = loc a

324+ loc _ = noSrcSpan

325+

326+instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where

327+ loc (HsWC _ a) = loc a

328+ loc _ = noSrcSpan

329+

330+instance HasLoc (Located a) where

331+ loc (L l _) = l

332+

333+instance HasLoc a => HasLoc [a] where

334+ loc [] = noSrcSpan

335+ loc xs = foldl1' combineSrcSpans $ map loc xs

336+

337+instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where

338+ loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]

339+ loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans

340+ [loc a, loc tvs, loc b, loc c]

341+ loc _ = noSrcSpan

342+instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where

343+ loc (HsValArg tm) = loc tm

344+ loc (HsTypeArg _ ty) = loc ty

345+ loc (HsArgPar sp) = sp

346+

347+instance HasLoc (HsDataDefn GhcRn) where

348+ loc def@(HsDataDefn{}) = loc $ dd_cons def

349+ -- Only used for data family instances, so we only need rhs

350+ -- Most probably the rest will be unhelpful anyway

351+ loc _ = noSrcSpan

352+

353+instance HasLoc (Pat (GhcPass a)) where

354+ loc (dL -> L l _) = l

355+

356+-- | The main worker class

357+class ToHie a where

358+ toHie :: a -> HieM [HieAST Type]

359+

360+-- | Used to collect type info

361+class Data a => HasType a where

362+ getTypeNode :: a -> HieM [HieAST Type]

363+

364+instance (ToHie a) => ToHie [a] where

365+ toHie = concatMapM toHie

366+

367+instance (ToHie a) => ToHie (Bag a) where

368+ toHie = toHie . bagToList

369+

370+instance (ToHie a) => ToHie (Maybe a) where

371+ toHie = maybe (pure []) toHie

372+

373+instance ToHie (Context (Located NoExt)) where

374+ toHie _ = pure []

375+

376+instance ToHie (TScoped NoExt) where

377+ toHie _ = pure []

378+

379+instance ToHie (IEContext (Located ModuleName)) where

380+ toHie (IEC c (L (RealSrcSpan span) mname)) =

381+ pure $ [Node (NodeInfo S.empty [] idents) span []]

382+ where details = mempty{identInfo = S.singleton (IEThing c)}

383+ idents = M.singleton (Left mname) details

384+ toHie _ = pure []

385+

386+instance ToHie (Context (Located Var)) where

387+ toHie c = case c of

388+ C context (L (RealSrcSpan span) name')

389+ -> do

390+ m <- asks name_remapping

391+ let name = M.findWithDefault name' (varName name') m

392+ pure

393+ [Node

394+ (NodeInfo S.empty [] $

395+ M.singleton (Right $ varName name)

396+ (IdentifierDetails (Just $ varType name')

397+ (S.singleton context)))

398+ span

399+ []]

400+ _ -> pure []

401+

402+instance ToHie (Context (Located Name)) where

403+ toHie c = case c of

404+ C context (L (RealSrcSpan span) name') -> do

405+ m <- asks name_remapping

406+ let name = case M.lookup name' m of

407+ Just var -> varName var

408+ Nothing -> name'

409+ pure

410+ [Node

411+ (NodeInfo S.empty [] $

412+ M.singleton (Right name)

413+ (IdentifierDetails Nothing

414+ (S.singleton context)))

415+ span

416+ []]

417+ _ -> pure []

418+

419+-- | Dummy instances - never called

420+instance ToHie (TScoped (LHsSigWcType GhcTc)) where

421+ toHie _ = pure []

422+instance ToHie (TScoped (LHsWcType GhcTc)) where

423+ toHie _ = pure []

424+instance ToHie (SigContext (LSig GhcTc)) where

425+ toHie _ = pure []

426+instance ToHie (TScoped Type) where

427+ toHie _ = pure []

428+

429+instance HasType (LHsBind GhcRn) where

430+ getTypeNode (L spn bind) = makeNode bind spn

431+

432+instance HasType (LHsBind GhcTc) where

433+ getTypeNode (L spn bind) = case bind of

434+ FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)

435+ _ -> makeNode bind spn

436+

437+instance HasType (LPat GhcRn) where

438+ getTypeNode (dL -> L spn pat) = makeNode pat spn

439+

440+instance HasType (LPat GhcTc) where

441+ getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)

442+

443+instance HasType (LHsExpr GhcRn) where

444+ getTypeNode (L spn e) = makeNode e spn

445+

446+-- | This instance tries to construct 'HieAST' nodes which include the type of

447+-- the expression. It is not yet possible to do this efficiently for all

448+-- expression forms, so we skip filling in the type for those inputs.

449+--

450+-- 'HsApp', for example, doesn't have any type information available directly on

451+-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then

452+-- query the type of that. Yet both the desugaring call and the type query both

453+-- involve recursive calls to the function and argument! This is particularly

454+-- problematic when you realize that the HIE traversal will eventually visit

455+-- those nodes too and ask for their types again.

456+--

457+-- Since the above is quite costly, we just skip cases where computing the

458+-- expression's type is going to be expensive.

459+--

460+-- See #16233

461+instance HasType (LHsExpr GhcTc) where

462+ getTypeNode e@(L spn e') = lift $

463+ -- Some expression forms have their type immediately available

464+ let tyOpt = case e' of

465+ HsLit _ l -> Just (hsLitType l)

466+ HsOverLit _ o -> Just (overLitType o)

467+

468+ HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)

469+ HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)

470+ HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)

471+

472+ ExplicitList ty _ _ -> Just (mkListTy ty)

473+ ExplicitSum ty _ _ _ -> Just (mkSumTy ty)

474+ HsDo ty _ _ -> Just ty

475+ HsMultiIf ty _ -> Just ty

476+

477+ _ -> Nothing

478+

479+ in

480+ case tyOpt of

481+ _ | skipDesugaring e' -> fallback

482+ | otherwise -> do

483+ hs_env <- Hsc $ \e w -> return (e,w)

484+ (_,mbe) <- liftIO $ deSugarExpr hs_env e

485+ maybe fallback (makeTypeNode e' spn . exprType) mbe

486+ where

487+ fallback = makeNode e' spn

488+

489+ matchGroupType :: MatchGroupTc -> Type

490+ matchGroupType (MatchGroupTc args res) = mkFunTys args res

491+

492+ -- | Skip desugaring of these expressions for performance reasons.

493+ --

494+ -- See impact on Haddock output (esp. missing type annotations or links)

495+ -- before marking more things here as 'False'. See impact on Haddock

496+ -- performance before marking more things as 'True'.

497+ skipDesugaring :: HsExpr a -> Bool

498+ skipDesugaring e = case e of

499+ HsVar{} -> False

500+ HsUnboundVar{} -> False

501+ HsConLikeOut{} -> False

502+ HsRecFld{} -> False

503+ HsOverLabel{} -> False

504+ HsIPVar{} -> False

505+ HsWrap{} -> False

506+ _ -> True

507+

508+instance ( ToHie (Context (Located (IdP a)))

509+ , ToHie (MatchGroup a (LHsExpr a))

510+ , ToHie (PScoped (LPat a))

511+ , ToHie (GRHSs a (LHsExpr a))

512+ , ToHie (LHsExpr a)

513+ , ToHie (Located (PatSynBind a a))

514+ , HasType (LHsBind a)

515+ , ModifyState (IdP a)

516+ , Data (HsBind a)

517+ ) => ToHie (BindContext (LHsBind a)) where

518+ toHie (BC context scope b@(L span bind)) =

519+ concatM $ getTypeNode b : case bind of

520+ FunBind{fun_id = name, fun_matches = matches} ->

521+ [ toHie $ C (ValBind context scope $ getRealSpan span) name

522+ , toHie matches

523+ ]

524+ PatBind{pat_lhs = lhs, pat_rhs = rhs} ->

525+ [ toHie $ PS (getRealSpan span) scope NoScope lhs

526+ , toHie rhs

527+ ]

528+ VarBind{var_rhs = expr} ->

529+ [ toHie expr

530+ ]

531+ AbsBinds{abs_exports = xs, abs_binds = binds} ->

532+ [ local (modifyState xs) $ -- Note [Name Remapping]

533+ toHie $ fmap (BC context scope) binds

534+ ]

535+ PatSynBind _ psb ->

536+ [ toHie $ L span psb -- PatSynBinds only occur at the top level

537+ ]

538+ XHsBindsLR _ -> []

539+

540+instance ( ToHie (LMatch a body)

541+ ) => ToHie (MatchGroup a body) where

542+ toHie mg = concatM $ case mg of

543+ MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->

544+ [ pure $ locOnly span

545+ , toHie alts

546+ ]

547+ MG{} -> []

548+ XMatchGroup _ -> []

549+

550+instance ( ToHie (Context (Located (IdP a)))

551+ , ToHie (PScoped (LPat a))

552+ , ToHie (HsPatSynDir a)

553+ ) => ToHie (Located (PatSynBind a a)) where

554+ toHie (L sp psb) = concatM $ case psb of

555+ PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->

556+ [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var

557+ , toHie $ toBind dets

558+ , toHie $ PS Nothing lhsScope NoScope pat

559+ , toHie dir

560+ ]

561+ where

562+ lhsScope = combineScopes varScope detScope

563+ varScope = mkLScope var

564+ detScope = case dets of

565+ (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args

566+ (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)

567+ (RecCon r) -> foldr go NoScope r

568+ go (RecordPatSynField a b) c = combineScopes c

569+ $ combineScopes (mkLScope a) (mkLScope b)

570+ detSpan = case detScope of

571+ LocalScope a -> Just a

572+ _ -> Nothing

573+ toBind (PrefixCon args) = PrefixCon $ map (C Use) args

574+ toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)

575+ toBind (RecCon r) = RecCon $ map (PSC detSpan) r

576+ XPatSynBind _ -> []

577+

578+instance ( ToHie (MatchGroup a (LHsExpr a))

579+ ) => ToHie (HsPatSynDir a) where

580+ toHie dir = case dir of

581+ ExplicitBidirectional mg -> toHie mg

582+ _ -> pure []

583+

584+instance ( a ~ GhcPass p

585+ , ToHie body

586+ , ToHie (HsMatchContext (NameOrRdrName (IdP a)))

587+ , ToHie (PScoped (LPat a))

588+ , ToHie (GRHSs a body)

589+ , Data (Match a body)

590+ ) => ToHie (LMatch (GhcPass p) body) where

591+ toHie (L span m ) = concatM $ makeNode m span : case m of

592+ Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->

593+ [ toHie mctx

594+ , let rhsScope = mkScope $ grhss_span grhss

595+ in toHie $ patScopes Nothing rhsScope NoScope pats

596+ , toHie grhss

597+ ]

598+ XMatch _ -> []

599+

600+instance ( ToHie (Context (Located a))

601+ ) => ToHie (HsMatchContext a) where

602+ toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name

603+ toHie (StmtCtxt a) = toHie a

604+ toHie _ = pure []

605+

606+instance ( ToHie (HsMatchContext a)

607+ ) => ToHie (HsStmtContext a) where

608+ toHie (PatGuard a) = toHie a

609+ toHie (ParStmtCtxt a) = toHie a

610+ toHie (TransStmtCtxt a) = toHie a

611+ toHie _ = pure []

612+

613+instance ( a ~ GhcPass p

614+ , ToHie (Context (Located (IdP a)))

615+ , ToHie (RContext (HsRecFields a (PScoped (LPat a))))

616+ , ToHie (LHsExpr a)

617+ , ToHie (TScoped (LHsSigWcType a))

618+ , ProtectSig a

619+ , ToHie (TScoped (ProtectedSig a))

620+ , HasType (LPat a)

621+ , Data (HsSplice a)

622+ ) => ToHie (PScoped (LPat (GhcPass p))) where

623+ toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =

624+ concatM $ getTypeNode lpat : case opat of

625+ WildPat _ ->

626+ []

627+ VarPat _ lname ->

628+ [ toHie $ C (PatternBind scope pscope rsp) lname

629+ ]

630+ LazyPat _ p ->

631+ [ toHie $ PS rsp scope pscope p

632+ ]

633+ AsPat _ lname pat ->

634+ [ toHie $ C (PatternBind scope

635+ (combineScopes (mkLScope (dL pat)) pscope)

636+ rsp)

637+ lname

638+ , toHie $ PS rsp scope pscope pat

639+ ]

640+ ParPat _ pat ->

641+ [ toHie $ PS rsp scope pscope pat

642+ ]

643+ BangPat _ pat ->

644+ [ toHie $ PS rsp scope pscope pat

645+ ]

646+ ListPat _ pats ->

647+ [ toHie $ patScopes rsp scope pscope pats

648+ ]

649+ TuplePat _ pats _ ->

650+ [ toHie $ patScopes rsp scope pscope pats

651+ ]

652+ SumPat _ pat _ _ ->

653+ [ toHie $ PS rsp scope pscope pat

654+ ]

655+ ConPatIn c dets ->

656+ [ toHie $ C Use c

657+ , toHie $ contextify dets

658+ ]

659+ ConPatOut {pat_con = con, pat_args = dets}->

660+ [ toHie $ C Use $ fmap conLikeName con

661+ , toHie $ contextify dets

662+ ]

663+ ViewPat _ expr pat ->

664+ [ toHie expr

665+ , toHie $ PS rsp scope pscope pat

666+ ]

667+ SplicePat _ sp ->

668+ [ toHie $ L ospan sp

669+ ]

670+ LitPat _ _ ->

671+ []

672+ NPat _ _ _ _ ->

673+ []

674+ NPlusKPat _ n _ _ _ _ ->

675+ [ toHie $ C (PatternBind scope pscope rsp) n

676+ ]

677+ SigPat _ pat sig ->

678+ [ toHie $ PS rsp scope pscope pat

679+ , let cscope = mkLScope (dL pat) in

680+ toHie $ TS (ResolvedScopes [cscope, scope, pscope])

681+ (protectSig @a cscope sig)

682+ -- See Note [Scoping Rules for SigPat]

683+ ]

684+ CoPat _ _ _ _ ->

685+ []

686+ XPat _ -> []

687+ where

688+ contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args

689+ contextify (InfixCon a b) = InfixCon a' b'

690+ where [a', b'] = patScopes rsp scope pscope [a,b]

691+ contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r

692+ contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a

693+ where

694+ go (RS fscope (L spn (HsRecField lbl pat pun))) =

695+ L spn $ HsRecField lbl (PS rsp scope fscope pat) pun

696+ scoped_fds = listScopes pscope fds

697+

698+instance ( ToHie body

699+ , ToHie (LGRHS a body)

700+ , ToHie (RScoped (LHsLocalBinds a))

701+ ) => ToHie (GRHSs a body) where

702+ toHie grhs = concatM $ case grhs of

703+ GRHSs _ grhss binds ->

704+ [ toHie grhss

705+ , toHie $ RS (mkScope $ grhss_span grhs) binds

706+ ]

707+ XGRHSs _ -> []

708+

709+instance ( ToHie (Located body)

710+ , ToHie (RScoped (GuardLStmt a))

711+ , Data (GRHS a (Located body))

712+ ) => ToHie (LGRHS a (Located body)) where

713+ toHie (L span g) = concatM $ makeNode g span : case g of

714+ GRHS _ guards body ->

715+ [ toHie $ listScopes (mkLScope body) guards

716+ , toHie body

717+ ]

718+ XGRHS _ -> []

719+

720+instance ( a ~ GhcPass p

721+ , ToHie (Context (Located (IdP a)))

722+ , HasType (LHsExpr a)

723+ , ToHie (PScoped (LPat a))

724+ , ToHie (MatchGroup a (LHsExpr a))

725+ , ToHie (LGRHS a (LHsExpr a))

726+ , ToHie (RContext (HsRecordBinds a))

727+ , ToHie (RFContext (Located (AmbiguousFieldOcc a)))

728+ , ToHie (ArithSeqInfo a)

729+ , ToHie (LHsCmdTop a)

730+ , ToHie (RScoped (GuardLStmt a))

731+ , ToHie (RScoped (LHsLocalBinds a))

732+ , ToHie (TScoped (LHsWcType (NoGhcTc a)))

733+ , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))

734+ , Data (HsExpr a)

735+ , Data (HsSplice a)

736+ , Data (HsTupArg a)

737+ , Data (AmbiguousFieldOcc a)

738+ ) => ToHie (LHsExpr (GhcPass p)) where

739+ toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of

740+ HsVar _ (L _ var) ->

741+ [ toHie $ C Use (L mspan var)

742+ -- Patch up var location since typechecker removes it

743+ ]

744+ HsUnboundVar _ _ ->

745+ []

746+ HsConLikeOut _ con ->

747+ [ toHie $ C Use $ L mspan $ conLikeName con

748+ ]

749+ HsRecFld _ fld ->

750+ [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)

751+ ]

752+ HsOverLabel _ _ _ -> []

753+ HsIPVar _ _ -> []

754+ HsOverLit _ _ -> []

755+ HsLit _ _ -> []

756+ HsLam _ mg ->

757+ [ toHie mg

758+ ]

759+ HsLamCase _ mg ->

760+ [ toHie mg

761+ ]

762+ HsApp _ a b ->

763+ [ toHie a

764+ , toHie b

765+ ]

766+ HsAppType _ expr sig ->

767+ [ toHie expr

768+ , toHie $ TS (ResolvedScopes []) sig

769+ ]

770+ OpApp _ a b c ->

771+ [ toHie a

772+ , toHie b

773+ , toHie c

774+ ]

775+ NegApp _ a _ ->

776+ [ toHie a

777+ ]

778+ HsPar _ a ->

779+ [ toHie a

780+ ]

781+ SectionL _ a b ->

782+ [ toHie a

783+ , toHie b

784+ ]

785+ SectionR _ a b ->

786+ [ toHie a

787+ , toHie b

788+ ]

789+ ExplicitTuple _ args _ ->

790+ [ toHie args

791+ ]

792+ ExplicitSum _ _ _ expr ->

793+ [ toHie expr

794+ ]

795+ HsCase _ expr matches ->

796+ [ toHie expr

797+ , toHie matches

798+ ]

799+ HsIf _ _ a b c ->

800+ [ toHie a

801+ , toHie b

802+ , toHie c

803+ ]

804+ HsMultiIf _ grhss ->

805+ [ toHie grhss

806+ ]

807+ HsLet _ binds expr ->

808+ [ toHie $ RS (mkLScope expr) binds

809+ , toHie expr

810+ ]

811+ HsDo _ _ (L ispan stmts) ->

812+ [ pure $ locOnly ispan

813+ , toHie $ listScopes NoScope stmts

814+ ]

815+ ExplicitList _ _ exprs ->

816+ [ toHie exprs

817+ ]

818+ RecordCon {rcon_con_name = name, rcon_flds = binds}->

819+ [ toHie $ C Use name

820+ , toHie $ RC RecFieldAssign $ binds

821+ ]

822+ RecordUpd {rupd_expr = expr, rupd_flds = upds}->

823+ [ toHie expr

824+ , toHie $ map (RC RecFieldAssign) upds

825+ ]

826+ ExprWithTySig _ expr sig ->

827+ [ toHie expr

828+ , toHie $ TS (ResolvedScopes [mkLScope expr]) sig

829+ ]

830+ ArithSeq _ _ info ->

831+ [ toHie info

832+ ]

833+ HsSCC _ _ _ expr ->

834+ [ toHie expr

835+ ]

836+ HsCoreAnn _ _ _ expr ->

837+ [ toHie expr

838+ ]

839+ HsProc _ pat cmdtop ->

840+ [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat

841+ , toHie cmdtop

842+ ]

843+ HsStatic _ expr ->

844+ [ toHie expr

845+ ]

846+ HsArrApp _ a b _ _ ->

847+ [ toHie a

848+ , toHie b

849+ ]

850+ HsArrForm _ expr _ cmds ->

851+ [ toHie expr

852+ , toHie cmds

853+ ]

854+ HsTick _ _ expr ->

855+ [ toHie expr

856+ ]

857+ HsBinTick _ _ _ expr ->

858+ [ toHie expr

859+ ]

860+ HsTickPragma _ _ _ _ expr ->

861+ [ toHie expr

862+ ]

863+ HsWrap _ _ a ->

864+ [ toHie $ L mspan a

865+ ]

866+ HsBracket _ b ->

867+ [ toHie b

868+ ]

869+ HsRnBracketOut _ b p ->

870+ [ toHie b

871+ , toHie p

872+ ]

873+ HsTcBracketOut _ b p ->

874+ [ toHie b

875+ , toHie p

876+ ]

877+ HsSpliceE _ x ->

878+ [ toHie $ L mspan x

879+ ]

880+ EWildPat _ -> []

881+ EAsPat _ a b ->

882+ [ toHie $ C Use a

883+ , toHie b

884+ ]

885+ EViewPat _ a b ->

886+ [ toHie a

887+ , toHie b

888+ ]

889+ ELazyPat _ a ->

890+ [ toHie a

891+ ]

892+ XExpr _ -> []

893+

894+instance ( a ~ GhcPass p

895+ , ToHie (LHsExpr a)

896+ , Data (HsTupArg a)

897+ ) => ToHie (LHsTupArg (GhcPass p)) where

898+ toHie (L span arg) = concatM $ makeNode arg span : case arg of

899+ Present _ expr ->

900+ [ toHie expr

901+ ]

902+ Missing _ -> []

903+ XTupArg _ -> []

904+

905+instance ( a ~ GhcPass p

906+ , ToHie (PScoped (LPat a))

907+ , ToHie (LHsExpr a)

908+ , ToHie (SigContext (LSig a))

909+ , ToHie (RScoped (LHsLocalBinds a))

910+ , ToHie (RScoped (ApplicativeArg a))

911+ , ToHie (Located body)

912+ , Data (StmtLR a a (Located body))

913+ , Data (StmtLR a a (Located (HsExpr a)))

914+ ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where

915+ toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of

916+ LastStmt _ body _ _ ->

917+ [ toHie body

918+ ]

919+ BindStmt _ pat body _ _ ->

920+ [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat

921+ , toHie body

922+ ]

923+ ApplicativeStmt _ stmts _ ->

924+ [ concatMapM (toHie . RS scope . snd) stmts

925+ ]

926+ BodyStmt _ body _ _ ->

927+ [ toHie body

928+ ]

929+ LetStmt _ binds ->

930+ [ toHie $ RS scope binds

931+ ]

932+ ParStmt _ parstmts _ _ ->

933+ [ concatMapM (\(ParStmtBlock _ stmts _ _) ->

934+ toHie $ listScopes NoScope stmts)

935+ parstmts

936+ ]

937+ TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->

938+ [ toHie $ listScopes scope stmts

939+ , toHie using

940+ , toHie by

941+ ]

942+ RecStmt {recS_stmts = stmts} ->

943+ [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts

944+ ]

945+ XStmtLR _ -> []

946+

947+instance ( ToHie (LHsExpr a)

948+ , ToHie (PScoped (LPat a))

949+ , ToHie (BindContext (LHsBind a))

950+ , ToHie (SigContext (LSig a))

951+ , ToHie (RScoped (HsValBindsLR a a))

952+ , Data (HsLocalBinds a)

953+ ) => ToHie (RScoped (LHsLocalBinds a)) where

954+ toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of

955+ EmptyLocalBinds _ -> []

956+ HsIPBinds _ _ -> []

957+ HsValBinds _ valBinds ->

958+ [ toHie $ RS (combineScopes scope $ mkScope sp)

959+ valBinds

960+ ]

961+ XHsLocalBindsLR _ -> []

962+

963+instance ( ToHie (BindContext (LHsBind a))

964+ , ToHie (SigContext (LSig a))

965+ , ToHie (RScoped (XXValBindsLR a a))

966+ ) => ToHie (RScoped (HsValBindsLR a a)) where

967+ toHie (RS sc v) = concatM $ case v of

968+ ValBinds _ binds sigs ->

969+ [ toHie $ fmap (BC RegularBind sc) binds

970+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs

971+ ]

972+ XValBindsLR x -> [ toHie $ RS sc x ]

973+

974+instance ToHie (RScoped (NHsValBindsLR GhcTc)) where

975+ toHie (RS sc (NValBinds binds sigs)) = concatM $

976+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)

977+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs

978+ ]

979+instance ToHie (RScoped (NHsValBindsLR GhcRn)) where

980+ toHie (RS sc (NValBinds binds sigs)) = concatM $

981+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)

982+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs

983+ ]

984+

985+instance ( ToHie (RContext (LHsRecField a arg))

986+ ) => ToHie (RContext (HsRecFields a arg)) where

987+ toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields

988+

989+instance ( ToHie (RFContext (Located label))

990+ , ToHie arg

991+ , HasLoc arg

992+ , Data label

993+ , Data arg

994+ ) => ToHie (RContext (LHsRecField' label arg)) where

995+ toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of

996+ HsRecField label expr _ ->

997+ [ toHie $ RFC c (getRealSpan $ loc expr) label

998+ , toHie expr

999+ ]

1000+

1001+removeDefSrcSpan :: Name -> Name

1002+removeDefSrcSpan n = setNameLoc n noSrcSpan

1003+

1004+instance ToHie (RFContext (LFieldOcc GhcRn)) where

1005+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1006+ FieldOcc name _ ->

1007+ [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)

1008+ ]

1009+ XFieldOcc _ -> []

1010+

1011+instance ToHie (RFContext (LFieldOcc GhcTc)) where

1012+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1013+ FieldOcc var _ ->

1014+ let var' = setVarName var (removeDefSrcSpan $ varName var)

1015+ in [ toHie $ C (RecField c rhs) (L nspan var')

1016+ ]

1017+ XFieldOcc _ -> []

1018+

1019+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where

1020+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1021+ Unambiguous name _ ->

1022+ [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name

1023+ ]

1024+ Ambiguous _name _ ->

1025+ [ ]

1026+ XAmbiguousFieldOcc _ -> []

1027+

1028+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where

1029+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1030+ Unambiguous var _ ->

1031+ let var' = setVarName var (removeDefSrcSpan $ varName var)

1032+ in [ toHie $ C (RecField c rhs) (L nspan var')

1033+ ]

1034+ Ambiguous var _ ->

1035+ let var' = setVarName var (removeDefSrcSpan $ varName var)

1036+ in [ toHie $ C (RecField c rhs) (L nspan var')

1037+ ]

1038+ XAmbiguousFieldOcc _ -> []

1039+

1040+instance ( a ~ GhcPass p

1041+ , ToHie (PScoped (LPat a))

1042+ , ToHie (BindContext (LHsBind a))

1043+ , ToHie (LHsExpr a)

1044+ , ToHie (SigContext (LSig a))

1045+ , ToHie (RScoped (HsValBindsLR a a))

1046+ , Data (StmtLR a a (Located (HsExpr a)))

1047+ , Data (HsLocalBinds a)

1048+ ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where

1049+ toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM

1050+ [ toHie $ PS Nothing sc NoScope pat

1051+ , toHie expr

1052+ ]

1053+ toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM

1054+ [ toHie $ listScopes NoScope stmts

1055+ , toHie $ PS Nothing sc NoScope pat

1056+ ]

1057+ toHie (RS _ (XApplicativeArg _)) = pure []

1058+

1059+instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where

1060+ toHie (PrefixCon args) = toHie args

1061+ toHie (RecCon rec) = toHie rec

1062+ toHie (InfixCon a b) = concatM [ toHie a, toHie b]

1063+

1064+instance ( ToHie (LHsCmd a)

1065+ , Data (HsCmdTop a)

1066+ ) => ToHie (LHsCmdTop a) where

1067+ toHie (L span top) = concatM $ makeNode top span : case top of

1068+ HsCmdTop _ cmd ->

1069+ [ toHie cmd

1070+ ]

1071+ XCmdTop _ -> []

1072+

1073+instance ( a ~ GhcPass p

1074+ , ToHie (PScoped (LPat a))

1075+ , ToHie (BindContext (LHsBind a))

1076+ , ToHie (LHsExpr a)

1077+ , ToHie (MatchGroup a (LHsCmd a))

1078+ , ToHie (SigContext (LSig a))

1079+ , ToHie (RScoped (HsValBindsLR a a))

1080+ , Data (HsCmd a)

1081+ , Data (HsCmdTop a)

1082+ , Data (StmtLR a a (Located (HsCmd a)))

1083+ , Data (HsLocalBinds a)

1084+ , Data (StmtLR a a (Located (HsExpr a)))

1085+ ) => ToHie (LHsCmd (GhcPass p)) where

1086+ toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of

1087+ HsCmdArrApp _ a b _ _ ->

1088+ [ toHie a

1089+ , toHie b

1090+ ]

1091+ HsCmdArrForm _ a _ _ cmdtops ->

1092+ [ toHie a

1093+ , toHie cmdtops

1094+ ]

1095+ HsCmdApp _ a b ->

1096+ [ toHie a

1097+ , toHie b

1098+ ]

1099+ HsCmdLam _ mg ->

1100+ [ toHie mg

1101+ ]

1102+ HsCmdPar _ a ->

1103+ [ toHie a

1104+ ]

1105+ HsCmdCase _ expr alts ->

1106+ [ toHie expr

1107+ , toHie alts

1108+ ]

1109+ HsCmdIf _ _ a b c ->

1110+ [ toHie a

1111+ , toHie b

1112+ , toHie c

1113+ ]

1114+ HsCmdLet _ binds cmd' ->

1115+ [ toHie $ RS (mkLScope cmd') binds

1116+ , toHie cmd'

1117+ ]

1118+ HsCmdDo _ (L ispan stmts) ->

1119+ [ pure $ locOnly ispan

1120+ , toHie $ listScopes NoScope stmts

1121+ ]

1122+ HsCmdWrap _ _ _ -> []

1123+ XCmd _ -> []

1124+

1125+instance ToHie (TyClGroup GhcRn) where

1126+ toHie (TyClGroup _ classes roles instances) = concatM

1127+ [ toHie classes

1128+ , toHie roles

1129+ , toHie instances

1130+ ]

1131+ toHie (XTyClGroup _) = pure []

1132+

1133+instance ToHie (LTyClDecl GhcRn) where

1134+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1135+ FamDecl {tcdFam = fdecl} ->

1136+ [ toHie (L span fdecl)

1137+ ]

1138+ SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->

1139+ [ toHie $ C (Decl SynDec $ getRealSpan span) name

1140+ , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars

1141+ , toHie typ

1142+ ]

1143+ DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->

1144+ [ toHie $ C (Decl DataDec $ getRealSpan span) name

1145+ , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars

1146+ , toHie defn

1147+ ]

1148+ where

1149+ quant_scope = mkLScope $ dd_ctxt defn

1150+ rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc

1151+ sig_sc = maybe NoScope mkLScope $ dd_kindSig defn

1152+ con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn

1153+ deriv_sc = mkLScope $ dd_derivs defn

1154+ ClassDecl { tcdCtxt = context

1155+ , tcdLName = name

1156+ , tcdTyVars = vars

1157+ , tcdFDs = deps

1158+ , tcdSigs = sigs

1159+ , tcdMeths = meths

1160+ , tcdATs = typs

1161+ , tcdATDefs = deftyps

1162+ } ->

1163+ [ toHie $ C (Decl ClassDec $ getRealSpan span) name

1164+ , toHie context

1165+ , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars

1166+ , toHie deps

1167+ , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs

1168+ , toHie $ fmap (BC InstanceBind ModuleScope) meths

1169+ , toHie typs

1170+ , concatMapM (pure . locOnly . getLoc) deftyps

1171+ , toHie $ map (go . unLoc) deftyps

1172+ ]

1173+ where

1174+ context_scope = mkLScope context

1175+ rhs_scope = foldl1' combineScopes $ map mkScope

1176+ [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]

1177+

1178+ go :: TyFamDefltEqn GhcRn

1179+ -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)

1180+ go (FamEqn a var bndrs pat b rhs) =

1181+ FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs

1182+ go (XFamEqn NoExt) = XFamEqn NoExt

1183+ XTyClDecl _ -> []

1184+

1185+instance ToHie (LFamilyDecl GhcRn) where

1186+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1187+ FamilyDecl _ info name vars _ sig inj ->

1188+ [ toHie $ C (Decl FamDec $ getRealSpan span) name

1189+ , toHie $ TS (ResolvedScopes [rhsSpan]) vars

1190+ , toHie info

1191+ , toHie $ RS injSpan sig

1192+ , toHie inj

1193+ ]

1194+ where

1195+ rhsSpan = sigSpan `combineScopes` injSpan

1196+ sigSpan = mkScope $ getLoc sig

1197+ injSpan = maybe NoScope (mkScope . getLoc) inj

1198+ XFamilyDecl _ -> []

1199+

1200+instance ToHie (FamilyInfo GhcRn) where

1201+ toHie (ClosedTypeFamily (Just eqns)) = concatM $

1202+ [ concatMapM (pure . locOnly . getLoc) eqns

1203+ , toHie $ map go eqns

1204+ ]

1205+ where

1206+ go (L l ib) = TS (ResolvedScopes [mkScope l]) ib

1207+ toHie _ = pure []

1208+

1209+instance ToHie (RScoped (LFamilyResultSig GhcRn)) where

1210+ toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of

1211+ NoSig _ ->

1212+ []

1213+ KindSig _ k ->

1214+ [ toHie k

1215+ ]

1216+ TyVarSig _ bndr ->

1217+ [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr

1218+ ]

1219+ XFamilyResultSig _ -> []

1220+

1221+instance ToHie (Located (FunDep (Located Name))) where

1222+ toHie (L span fd@(lhs, rhs)) = concatM $

1223+ [ makeNode fd span

1224+ , toHie $ map (C Use) lhs

1225+ , toHie $ map (C Use) rhs

1226+ ]

1227+

1228+instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs)

1229+ => ToHie (TScoped (FamEqn GhcRn pats rhs)) where

1230+ toHie (TS _ f) = toHie f

1231+

1232+instance ( ToHie pats

1233+ , ToHie rhs

1234+ , HasLoc pats

1235+ , HasLoc rhs

1236+ ) => ToHie (FamEqn GhcRn pats rhs) where

1237+ toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $

1238+ [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var

1239+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1240+ , toHie pats

1241+ , toHie rhs

1242+ ]

1243+ where scope = combineScopes patsScope rhsScope

1244+ patsScope = mkScope (loc pats)

1245+ rhsScope = mkScope (loc rhs)

1246+ toHie (XFamEqn _) = pure []

1247+

1248+instance ToHie (LInjectivityAnn GhcRn) where

1249+ toHie (L span ann) = concatM $ makeNode ann span : case ann of

1250+ InjectivityAnn lhs rhs ->

1251+ [ toHie $ C Use lhs

1252+ , toHie $ map (C Use) rhs

1253+ ]

1254+

1255+instance ToHie (HsDataDefn GhcRn) where

1256+ toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM

1257+ [ toHie ctx

1258+ , toHie mkind

1259+ , toHie cons

1260+ , toHie derivs

1261+ ]

1262+ toHie (XHsDataDefn _) = pure []

1263+

1264+instance ToHie (HsDeriving GhcRn) where

1265+ toHie (L span clauses) = concatM

1266+ [ pure $ locOnly span

1267+ , toHie clauses

1268+ ]

1269+

1270+instance ToHie (LHsDerivingClause GhcRn) where

1271+ toHie (L span cl) = concatM $ makeNode cl span : case cl of

1272+ HsDerivingClause _ strat (L ispan tys) ->

1273+ [ toHie strat

1274+ , pure $ locOnly ispan

1275+ , toHie $ map (TS (ResolvedScopes [])) tys

1276+ ]

1277+ XHsDerivingClause _ -> []

1278+

1279+instance ToHie (Located (DerivStrategy GhcRn)) where

1280+ toHie (L span strat) = concatM $ makeNode strat span : case strat of

1281+ StockStrategy -> []

1282+ AnyclassStrategy -> []

1283+ NewtypeStrategy -> []

1284+ ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]

1285+

1286+instance ToHie (Located OverlapMode) where

1287+ toHie (L span _) = pure $ locOnly span

1288+

1289+instance ToHie (LConDecl GhcRn) where

1290+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1291+ ConDeclGADT { con_names = names, con_qvars = qvars

1292+ , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->

1293+ [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names

1294+ , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars

1295+ , toHie ctx

1296+ , toHie args

1297+ , toHie typ

1298+ ]

1299+ where

1300+ rhsScope = combineScopes argsScope tyScope

1301+ ctxScope = maybe NoScope mkLScope ctx

1302+ argsScope = condecl_scope args

1303+ tyScope = mkLScope typ

1304+ ConDeclH98 { con_name = name, con_ex_tvs = qvars

1305+ , con_mb_cxt = ctx, con_args = dets } ->

1306+ [ toHie $ C (Decl ConDec $ getRealSpan span) name

1307+ , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars

1308+ , toHie ctx

1309+ , toHie dets

1310+ ]

1311+ where

1312+ rhsScope = combineScopes ctxScope argsScope

1313+ ctxScope = maybe NoScope mkLScope ctx

1314+ argsScope = condecl_scope dets

1315+ XConDecl _ -> []

1316+ where condecl_scope args = case args of

1317+ PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs

1318+ InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)

1319+ RecCon x -> mkLScope x

1320+

1321+instance ToHie (Located [LConDeclField GhcRn]) where

1322+ toHie (L span decls) = concatM $

1323+ [ pure $ locOnly span

1324+ , toHie decls

1325+ ]

1326+

1327+instance ( HasLoc thing

1328+ , ToHie (TScoped thing)

1329+ ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where

1330+ toHie (TS sc (HsIB ibrn a)) = concatM $

1331+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn

1332+ , toHie $ TS sc a

1333+ ]

1334+ where span = loc a

1335+ toHie (TS _ (XHsImplicitBndrs _)) = pure []

1336+

1337+instance ( HasLoc thing

1338+ , ToHie (TScoped thing)

1339+ ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where

1340+ toHie (TS sc (HsWC names a)) = concatM $

1341+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names

1342+ , toHie $ TS sc a

1343+ ]

1344+ where span = loc a

1345+ toHie (TS _ (XHsWildCardBndrs _)) = pure []

1346+

1347+instance ToHie (SigContext (LSig GhcRn)) where

1348+ toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of

1349+ TypeSig _ names typ ->

1350+ [ toHie $ map (C TyDecl) names

1351+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1352+ ]

1353+ PatSynSig _ names typ ->

1354+ [ toHie $ map (C TyDecl) names

1355+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1356+ ]

1357+ ClassOpSig _ _ names typ ->

1358+ [ case styp of

1359+ ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names

1360+ _ -> toHie $ map (C $ TyDecl) names

1361+ , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ

1362+ ]

1363+ IdSig _ _ -> []

1364+ FixSig _ fsig ->

1365+ [ toHie $ L sp fsig

1366+ ]

1367+ InlineSig _ name _ ->

1368+ [ toHie $ (C Use) name

1369+ ]

1370+ SpecSig _ name typs _ ->

1371+ [ toHie $ (C Use) name

1372+ , toHie $ map (TS (ResolvedScopes [])) typs

1373+ ]

1374+ SpecInstSig _ _ typ ->

1375+ [ toHie $ TS (ResolvedScopes []) typ

1376+ ]

1377+ MinimalSig _ _ form ->

1378+ [ toHie form

1379+ ]

1380+ SCCFunSig _ _ name mtxt ->

1381+ [ toHie $ (C Use) name

1382+ , pure $ maybe [] (locOnly . getLoc) mtxt

1383+ ]

1384+ CompleteMatchSig _ _ (L ispan names) typ ->

1385+ [ pure $ locOnly ispan

1386+ , toHie $ map (C Use) names

1387+ , toHie $ fmap (C Use) typ

1388+ ]

1389+ XSig _ -> []

1390+

1391+instance ToHie (LHsType GhcRn) where

1392+ toHie x = toHie $ TS (ResolvedScopes []) x

1393+

1394+instance ToHie (TScoped (LHsType GhcRn)) where

1395+ toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of

1396+ HsForAllTy _ bndrs body ->

1397+ [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs

1398+ , toHie body

1399+ ]

1400+ HsQualTy _ ctx body ->

1401+ [ toHie ctx

1402+ , toHie body

1403+ ]

1404+ HsTyVar _ _ var ->

1405+ [ toHie $ C Use var

1406+ ]

1407+ HsAppTy _ a b ->

1408+ [ toHie a

1409+ , toHie b

1410+ ]

1411+ HsAppKindTy _ ty ki ->

1412+ [ toHie ty

1413+ , toHie $ TS (ResolvedScopes []) ki

1414+ ]

1415+ HsFunTy _ a b ->

1416+ [ toHie a

1417+ , toHie b

1418+ ]

1419+ HsListTy _ a ->

1420+ [ toHie a

1421+ ]

1422+ HsTupleTy _ _ tys ->

1423+ [ toHie tys

1424+ ]

1425+ HsSumTy _ tys ->

1426+ [ toHie tys

1427+ ]

1428+ HsOpTy _ a op b ->

1429+ [ toHie a

1430+ , toHie $ C Use op

1431+ , toHie b

1432+ ]

1433+ HsParTy _ a ->

1434+ [ toHie a

1435+ ]

1436+ HsIParamTy _ ip ty ->

1437+ [ toHie ip

1438+ , toHie ty

1439+ ]

1440+ HsKindSig _ a b ->

1441+ [ toHie a

1442+ , toHie b

1443+ ]

1444+ HsSpliceTy _ a ->

1445+ [ toHie $ L span a

1446+ ]

1447+ HsDocTy _ a _ ->

1448+ [ toHie a

1449+ ]

1450+ HsBangTy _ _ ty ->

1451+ [ toHie ty

1452+ ]

1453+ HsRecTy _ fields ->

1454+ [ toHie fields

1455+ ]

1456+ HsExplicitListTy _ _ tys ->

1457+ [ toHie tys

1458+ ]

1459+ HsExplicitTupleTy _ tys ->

1460+ [ toHie tys

1461+ ]

1462+ HsTyLit _ _ -> []

1463+ HsWildCardTy _ -> []

1464+ HsStarTy _ _ -> []

1465+ XHsType _ -> []

1466+

1467+instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where

1468+ toHie (HsValArg tm) = toHie tm

1469+ toHie (HsTypeArg _ ty) = toHie ty

1470+ toHie (HsArgPar sp) = pure $ locOnly sp

1471+

1472+instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where

1473+ toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1474+ UserTyVar _ var ->

1475+ [ toHie $ C (TyVarBind sc tsc) var

1476+ ]

1477+ KindedTyVar _ var kind ->

1478+ [ toHie $ C (TyVarBind sc tsc) var

1479+ , toHie kind

1480+ ]

1481+ XTyVarBndr _ -> []

1482+

1483+instance ToHie (TScoped (LHsQTyVars GhcRn)) where

1484+ toHie (TS sc (HsQTvs (HsQTvsRn implicits _) vars)) = concatM $

1485+ [ pure $ bindingsOnly bindings

1486+ , toHie $ tvScopes sc NoScope vars

1487+ ]

1488+ where

1489+ varLoc = loc vars

1490+ bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits

1491+ toHie (TS _ (XLHsQTyVars _)) = pure []

1492+

1493+instance ToHie (LHsContext GhcRn) where

1494+ toHie (L span tys) = concatM $

1495+ [ pure $ locOnly span

1496+ , toHie tys

1497+ ]

1498+

1499+instance ToHie (LConDeclField GhcRn) where

1500+ toHie (L span field) = concatM $ makeNode field span : case field of

1501+ ConDeclField _ fields typ _ ->

1502+ [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields

1503+ , toHie typ

1504+ ]

1505+ XConDeclField _ -> []

1506+

1507+instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where

1508+ toHie (From expr) = toHie expr

1509+ toHie (FromThen a b) = concatM $

1510+ [ toHie a

1511+ , toHie b

1512+ ]

1513+ toHie (FromTo a b) = concatM $

1514+ [ toHie a

1515+ , toHie b

1516+ ]

1517+ toHie (FromThenTo a b c) = concatM $

1518+ [ toHie a

1519+ , toHie b

1520+ , toHie c

1521+ ]

1522+

1523+instance ToHie (LSpliceDecl GhcRn) where

1524+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1525+ SpliceDecl _ splice _ ->

1526+ [ toHie splice

1527+ ]

1528+ XSpliceDecl _ -> []

1529+

1530+instance ToHie (HsBracket a) where

1531+ toHie _ = pure []

1532+

1533+instance ToHie PendingRnSplice where

1534+ toHie _ = pure []

1535+

1536+instance ToHie PendingTcSplice where

1537+ toHie _ = pure []

1538+

1539+instance ToHie (LBooleanFormula (Located Name)) where

1540+ toHie (L span form) = concatM $ makeNode form span : case form of

1541+ Var a ->

1542+ [ toHie $ C Use a

1543+ ]

1544+ And forms ->

1545+ [ toHie forms

1546+ ]

1547+ Or forms ->

1548+ [ toHie forms

1549+ ]

1550+ Parens f ->

1551+ [ toHie f

1552+ ]

1553+

1554+instance ToHie (Located HsIPName) where

1555+ toHie (L span e) = makeNode e span

1556+

1557+instance ( ToHie (LHsExpr a)

1558+ , Data (HsSplice a)

1559+ ) => ToHie (Located (HsSplice a)) where

1560+ toHie (L span sp) = concatM $ makeNode sp span : case sp of

1561+ HsTypedSplice _ _ _ expr ->

1562+ [ toHie expr

1563+ ]

1564+ HsUntypedSplice _ _ _ expr ->

1565+ [ toHie expr

1566+ ]

1567+ HsQuasiQuote _ _ _ ispan _ ->

1568+ [ pure $ locOnly ispan

1569+ ]

1570+ HsSpliced _ _ _ ->

1571+ []

1572+ HsSplicedT _ ->

1573+ []

1574+ XSplice _ -> []

1575+

1576+instance ToHie (LRoleAnnotDecl GhcRn) where

1577+ toHie (L span annot) = concatM $ makeNode annot span : case annot of

1578+ RoleAnnotDecl _ var roles ->

1579+ [ toHie $ C Use var

1580+ , concatMapM (pure . locOnly . getLoc) roles

1581+ ]

1582+ XRoleAnnotDecl _ -> []

1583+

1584+instance ToHie (LInstDecl GhcRn) where

1585+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1586+ ClsInstD _ d ->

1587+ [ toHie $ L span d

1588+ ]

1589+ DataFamInstD _ d ->

1590+ [ toHie $ L span d

1591+ ]

1592+ TyFamInstD _ d ->

1593+ [ toHie $ L span d

1594+ ]

1595+ XInstDecl _ -> []

1596+

1597+instance ToHie (LClsInstDecl GhcRn) where

1598+ toHie (L span decl) = concatM

1599+ [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl

1600+ , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl

1601+ , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl

1602+ , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl

1603+ , toHie $ cid_tyfam_insts decl

1604+ , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl

1605+ , toHie $ cid_datafam_insts decl

1606+ , toHie $ cid_overlap_mode decl

1607+ ]

1608+

1609+instance ToHie (LDataFamInstDecl GhcRn) where

1610+ toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1611+

1612+instance ToHie (LTyFamInstDecl GhcRn) where

1613+ toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1614+

1615+instance ToHie (Context a)

1616+ => ToHie (PatSynFieldContext (RecordPatSynField a)) where

1617+ toHie (PSC sp (RecordPatSynField a b)) = concatM $

1618+ [ toHie $ C (RecField RecFieldDecl sp) a

1619+ , toHie $ C Use b

1620+ ]

1621+

1622+instance ToHie (LDerivDecl GhcRn) where

1623+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1624+ DerivDecl _ typ strat overlap ->

1625+ [ toHie $ TS (ResolvedScopes []) typ

1626+ , toHie strat

1627+ , toHie overlap

1628+ ]

1629+ XDerivDecl _ -> []

1630+

1631+instance ToHie (LFixitySig GhcRn) where

1632+ toHie (L span sig) = concatM $ makeNode sig span : case sig of

1633+ FixitySig _ vars _ ->

1634+ [ toHie $ map (C Use) vars

1635+ ]

1636+ XFixitySig _ -> []

1637+

1638+instance ToHie (LDefaultDecl GhcRn) where

1639+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1640+ DefaultDecl _ typs ->

1641+ [ toHie typs

1642+ ]

1643+ XDefaultDecl _ -> []

1644+

1645+instance ToHie (LForeignDecl GhcRn) where

1646+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1647+ ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->

1648+ [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name

1649+ , toHie $ TS (ResolvedScopes []) sig

1650+ , toHie fi

1651+ ]

1652+ ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->

1653+ [ toHie $ C Use name

1654+ , toHie $ TS (ResolvedScopes []) sig

1655+ , toHie fe

1656+ ]

1657+ XForeignDecl _ -> []

1658+

1659+instance ToHie ForeignImport where

1660+ toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $

1661+ [ locOnly a

1662+ , locOnly b

1663+ , locOnly c

1664+ ]

1665+

1666+instance ToHie ForeignExport where

1667+ toHie (CExport (L a _) (L b _)) = pure $ concat $

1668+ [ locOnly a

1669+ , locOnly b

1670+ ]

1671+

1672+instance ToHie (LWarnDecls GhcRn) where

1673+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1674+ Warnings _ _ warnings ->

1675+ [ toHie warnings

1676+ ]

1677+ XWarnDecls _ -> []

1678+

1679+instance ToHie (LWarnDecl GhcRn) where

1680+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1681+ Warning _ vars _ ->

1682+ [ toHie $ map (C Use) vars

1683+ ]

1684+ XWarnDecl _ -> []

1685+

1686+instance ToHie (LAnnDecl GhcRn) where

1687+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1688+ HsAnnotation _ _ prov expr ->

1689+ [ toHie prov

1690+ , toHie expr

1691+ ]

1692+ XAnnDecl _ -> []

1693+

1694+instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where

1695+ toHie (ValueAnnProvenance a) = toHie $ C Use a

1696+ toHie (TypeAnnProvenance a) = toHie $ C Use a

1697+ toHie ModuleAnnProvenance = pure []

1698+

1699+instance ToHie (LRuleDecls GhcRn) where

1700+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1701+ HsRules _ _ rules ->

1702+ [ toHie rules

1703+ ]

1704+ XRuleDecls _ -> []

1705+

1706+instance ToHie (LRuleDecl GhcRn) where

1707+ toHie (L _ (XRuleDecl _)) = pure []

1708+ toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM

1709+ [ makeNode r span

1710+ , pure $ locOnly $ getLoc rname

1711+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1712+ , toHie $ map (RS $ mkScope span) bndrs

1713+ , toHie exprA

1714+ , toHie exprB

1715+ ]

1716+ where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc

1717+ bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)

1718+ exprA_sc = mkLScope exprA

1719+ exprB_sc = mkLScope exprB

1720+

1721+instance ToHie (RScoped (LRuleBndr GhcRn)) where

1722+ toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1723+ RuleBndr _ var ->

1724+ [ toHie $ C (ValBind RegularBind sc Nothing) var

1725+ ]

1726+ RuleBndrSig _ var typ ->

1727+ [ toHie $ C (ValBind RegularBind sc Nothing) var

1728+ , toHie $ TS (ResolvedScopes [sc]) typ

1729+ ]

1730+ XRuleBndr _ -> []

1731+

1732+instance ToHie (LImportDecl GhcRn) where

1733+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1734+ ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->

1735+ [ toHie $ IEC Import name

1736+ , toHie $ fmap (IEC ImportAs) as

1737+ , maybe (pure []) goIE hidden

1738+ ]

1739+ XImportDecl _ -> []

1740+ where

1741+ goIE (hiding, (L sp liens)) = concatM $

1742+ [ pure $ locOnly sp

1743+ , toHie $ map (IEC c) liens

1744+ ]

1745+ where

1746+ c = if hiding then ImportHiding else Import

1747+

1748+instance ToHie (IEContext (LIE GhcRn)) where

1749+ toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of

1750+ IEVar _ n ->

1751+ [ toHie $ IEC c n

1752+ ]

1753+ IEThingAbs _ n ->

1754+ [ toHie $ IEC c n

1755+ ]

1756+ IEThingAll _ n ->

1757+ [ toHie $ IEC c n

1758+ ]

1759+ IEThingWith _ n _ ns flds ->

1760+ [ toHie $ IEC c n

1761+ , toHie $ map (IEC c) ns

1762+ , toHie $ map (IEC c) flds

1763+ ]

1764+ IEModuleContents _ n ->

1765+ [ toHie $ IEC c n

1766+ ]

1767+ IEGroup _ _ _ -> []

1768+ IEDoc _ _ -> []

1769+ IEDocNamed _ _ -> []

1770+ XIE _ -> []

1771+

1772+instance ToHie (IEContext (LIEWrappedName Name)) where

1773+ toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of

1774+ IEName n ->

1775+ [ toHie $ C (IEThing c) n

1776+ ]

1777+ IEPattern p ->

1778+ [ toHie $ C (IEThing c) p

1779+ ]

1780+ IEType n ->

1781+ [ toHie $ C (IEThing c) n

1782+ ]

1783+

1784+instance ToHie (IEContext (Located (FieldLbl Name))) where

1785+ toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of

1786+ FieldLabel _ _ n ->

1787+ [ toHie $ C (IEThing c) $ L span n

1788+ ]

1789+

src/Development/IDE/Compat.hsnew file+19

@@ -0,0 +1,19 @@

1+{-# LANGUAGE CPP #-}

2+module Development.IDE.Compat

3+ (

4+ getProcessID

5+ ) where

7+#ifdef mingw32_HOST_OS

9+import qualified System.Win32.Process as P (getCurrentProcessId)

10+getProcessID :: IO Int

11+getProcessID = fromIntegral <$> P.getCurrentProcessId

12+

13+#else

14+

15+import qualified System.Posix.Process as P (getProcessID)

16+getProcessID :: IO Int

17+getProcessID = fromIntegral <$> P.getProcessID

18+

19+#endif

src/Development/IDE/Core/Compile.hs+306−104

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

99-- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.

1010module Development.IDE.Core.Compile

1111 ( TcModuleResult(..)

12+ , RunSimplifier(..)

1213 , compileModule

1314 , parseModule

1415 , typecheckModule

@@ -16,10 +17,18 @@ module Development.IDE.Core.Compile

1617 , addRelativeImport

1718 , mkTcModuleResult

1819 , generateByteCode

20+ , generateAndWriteHieFile

21+ , generateAndWriteHiFile

22+ , getModSummaryFromImports

23+ , loadHieFile

24+ , loadInterface

25+ , loadDepModule

26+ , loadModuleHome

1927 ) where

2028

2129import Development.IDE.Core.RuleTypes

2230import Development.IDE.Core.Preprocessor

31+import Development.IDE.Core.Shake

2332import Development.IDE.GHC.Error

2433import Development.IDE.GHC.Warnings

2534import Development.IDE.Types.Diagnostics

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

2837import qualified GHC.LanguageExtensions.Type as GHC

2938import Development.IDE.Types.Options

3039import Development.IDE.Types.Location

40+import Outputable

3141

3242#if MIN_GHC_API_VERSION(8,6,0)

3343import DynamicLoading (initializePlugins)

@@ -36,42 +46,60 @@ import DynamicLoading (initializePlugins)

3646import GHC hiding (parseModule, typecheckModule)

3747import qualified Parser

3848import Lexer

49+#if MIN_GHC_API_VERSION(8,10,0)

50+#else

3951import ErrUtils

52+#endif

4053

41−import qualified GHC

54+import Finder

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

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

4257import GhcMonad

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

4459import qualified HeaderInfo as Hdr

45−import HscMain (hscInteractive)

60+import HscMain (hscInteractive, hscSimplify)

61+import LoadIface (readIface)

62+import qualified Maybes

4663import MkIface

64+import NameCache

4765import StringBuffer as SB

66+import TcRnMonad (initIfaceLoad, tcg_th_coreplugins)

67+import TcIface (typecheckIface)

4868import TidyPgm

4969

70+import Control.Exception.Safe

5071import Control.Monad.Extra

5172import Control.Monad.Except

5273import Control.Monad.Trans.Except

53−import Data.Function

54−import Data.Ord

74+import Data.Bifunctor (first, second)

5575import qualified Data.Text as T

5676import Data.IORef

5777import Data.List.Extra

5878import Data.Maybe

59−import Data.Tuple.Extra

6079import qualified Data.Map.Strict as Map

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

6287

6388

64−-- | Given a string buffer, return a pre-processed @ParsedModule@.

89+-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.

6590parseModule

6691 :: IdeOptions

6792 -> HscEnv

93+ -> [PackageName]

6894 -> FilePath

6995 -> Maybe SB.StringBuffer

70− -> IO ([FileDiagnostic], Maybe ParsedModule)

71−parseModule IdeOptions{..} env file =

72− fmap (either (, Nothing) (second Just)) .

73− -- We need packages since imports fail to resolve otherwise.

74− runGhcEnv env . runExceptT . parseFileContents optPreprocessor file

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

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

98+ fmap (either (, Nothing) id) $

99+ evalGhcEnv env $ runExceptT $ do

100+ (contents, dflags) <- preprocessor filename mbContents

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

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

75103

76104

77105-- | Given a package identifier, what packages does it depend on

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

82110computePackageDeps env pkg = do

83111 let dflags = hsc_dflags env

84112 case lookupInstalledPackage dflags pkg of

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

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

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

87115 Just pkgInfo -> return $ Right $ depends pkgInfo

88116

89−

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

91−typecheckModule

92− :: IdeDefer

93− -> HscEnv

94− -> [TcModuleResult]

95− -> ParsedModule

96− -> IO ([FileDiagnostic], Maybe TcModuleResult)

97−typecheckModule (IdeDefer defer) packageState deps pm =

98− let demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id

99− in

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

101− runGhcEnv packageState $

102− catchSrcErrors "typecheck" $ do

103− setupEnv deps

104− let modSummary = pm_mod_summary pm

105− dflags = ms_hspp_opts modSummary

106− modSummary' <- initPlugins modSummary

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

108− GHC.typecheckModule $ enableTopLevelWarnings

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

110− tcm2 <- mkTcModuleResult tcm

111− let errorPipeline = unDefer . hideDiag dflags

112− return (map errorPipeline warnings, tcm2)

117+typecheckModule :: IdeDefer

118+ -> HscEnv

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

120+ -> ParsedModule

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

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

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

124+ runGhcEnv hsc $

125+ catchSrcErrors "typecheck" $ do

126+ -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.

127+ -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.

128+ -- Long-term we might just want to change the order returned by GetDependencies

129+ let deps = reverse depsIn

130+

131+ setupFinderCache (map fst deps)

132+

133+ let modSummary = pm_mod_summary pm

134+ dflags = ms_hspp_opts modSummary

135+

136+ mapM_ (uncurry loadDepModule . snd) deps

137+ modSummary' <- initPlugins modSummary

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

139+ GHC.typecheckModule $ enableTopLevelWarnings

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

141+ tcm2 <- mkTcModuleResult tcm

142+ let errorPipeline = unDefer . hideDiag dflags

143+ return (map errorPipeline warnings, tcm2)

144+ where

145+ demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id

113146

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

115148initPlugins modSummary = do

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

121154 return modSummary

122155#endif

123156

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+

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

125164-- provide errors.

126165compileModule

127− :: HscEnv

128− -> [TcModuleResult]

166+ :: RunSimplifier

167+ -> HscEnv

168+ -> [(ModSummary, HomeModInfo)]

129169 -> TcModuleResult

130− -> IO ([FileDiagnostic], Maybe (SafeHaskellMode, CgGuts, ModDetails))

131−compileModule packageState deps tmr =

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

171+compileModule (RunSimplifier simplify) packageState deps tmr =

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

133− runGhcEnv packageState $

173+ evalGhcEnv packageState $

134174 catchSrcErrors "compile" $ do

135− setupEnv (deps ++ [tmr])

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

136176

137177 let tm = tmrModule tmr

138178 session <- getSession

@@ -141,20 +181,30 @@ compileModule packageState deps tmr =

141181 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}

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

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

144−

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

185+ desugared_guts <-

186+ if simplify

187+ then do

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

189+ liftIO $ hscSimplify session plugins desugar

190+ else pure desugar

145191 -- give variables unique OccNames

146− (guts, details) <- liftIO $ tidyProgram session desugar

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

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

148194

149−generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO ([FileDiagnostic], Maybe Linkable)

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

150196generateByteCode hscEnv deps tmr guts =

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

152− runGhcEnv hscEnv $

198+ evalGhcEnv hscEnv $

153199 catchSrcErrors "bytecode" $ do

154− setupEnv (deps ++ [tmr])

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

155201 session <- getSession

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

157− liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)

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)

207+#endif

158208 let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr

159209 let unlinked = BCOs bytecode sptEntries

160210 let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]

@@ -176,9 +226,10 @@ demoteTypeErrorsToWarnings =

176226enableTopLevelWarnings :: ParsedModule -> ParsedModule

177227enableTopLevelWarnings =

178228 (update_pm_mod_summary . update_hspp_opts)

179− (`wopt_set` Opt_WarnMissingSignatures)

229+ ((`wopt_set` Opt_WarnMissingPatternSynonymSignatures) .

230+ (`wopt_set` Opt_WarnMissingSignatures))

180231 -- the line below would show also warnings for let bindings without signature

181− -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures))

232+ -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures)))

182233

183234update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary

184235update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}

@@ -202,9 +253,9 @@ upgradeWarningToError (nfp, sh, fd) =

202253hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)

203254hideDiag originalFlags (Reason warning, (nfp, _sh, fd))

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

205−hideDiag _originalFlags t = t

256+hideDiag _originalFlags t = t

206257

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

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

208259addRelativeImport fp modu dflags = dflags

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

210261

@@ -214,25 +265,81 @@ mkTcModuleResult

214265 -> m TcModuleResult

215266mkTcModuleResult tcm = do

216267 session <- getSession

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

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

273+#endif

218274 let mod_info = HomeModInfo iface details Nothing

219275 return $ TcModuleResult tcm mod_info

220276 where

221277 (tcGblEnv, details) = tm_internals_ tcm

222278

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+

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

224326-- best understanding (!)

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

226−setupEnv tmsIn = do

227− -- if both a .hs-boot file and a .hs file appear here, we want to make sure that the .hs file

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

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

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

327+--

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

329+-- HPT.

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

331+setupEnv tms = do

332+ setupFinderCache (map fst tms)

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

334+ modifySession $ \e ->

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

231336

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

338+-- sorted.

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

340+setupFinderCache mss = do

232341 session <- getSession

233342

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

235−

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

237344 let graph = mkModuleGraph mss

238345 setSession session { hsc_mod_graph = graph }

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

251358 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache

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

253360

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

255− mapM_ loadModuleHome tms

256−

257361

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

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

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

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

262370loadModuleHome

263− :: (GhcMonad m)

264− => TcModuleResult

265− -> m ()

266−loadModuleHome tmr = modifySession $ \e ->

267− e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }

268− where

269− ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr

270− mod_info = tmrModInfo tmr

271− mod = ms_mod_name ms

272−

371+ :: HomeModInfo

372+ -> HscEnv

373+ -> HscEnv

374+loadModuleHome mod_info e =

375+ e { hsc_HPT = addToHpt (hsc_HPT e) mod_name mod_info }

376+ where

377+ mod_name = moduleName $ mi_module $ hm_iface mod_info

378+

379+-- | Load module interface.

380+loadDepModuleIO :: ModIface -> Maybe Linkable -> HscEnv -> IO HscEnv

381+loadDepModuleIO iface linkable hsc = do

382+ details <- liftIO $ fixIO $ \details -> do

383+ let hsc' = hsc { hsc_HPT = addToHpt (hsc_HPT hsc) mod (HomeModInfo iface details linkable) }

384+ initIfaceLoad hsc' (typecheckIface iface)

385+ let mod_info = HomeModInfo iface details linkable

386+ return $ loadModuleHome mod_info hsc

387+ where

388+ mod = moduleName $ mi_module iface

273389

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'

274395

275396-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's

276397-- name and its imports.

@@ -291,30 +412,18 @@ getImportsParsed dflags (L loc parsed) = do

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

292413 ])

293414

294−

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

296416getModSummaryFromBuffer

297417 :: GhcMonad m

298418 => FilePath

299− -> SB.StringBuffer

300419 -> DynFlags

301420 -> GHC.ParsedSource

302421 -> ExceptT [FileDiagnostic] m ModSummary

303−getModSummaryFromBuffer fp contents dflags parsed = do

422+getModSummaryFromBuffer fp dflags parsed = do

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

305424

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

317− InstalledUnitId unitId = thisInstalledUnitId dflags

425+ modLoc <- liftIO $ mkHomeModLocation dflags modName fp

426+ let InstalledUnitId unitId = thisInstalledUnitId dflags

318427 return $ ModSummary

319428 { ms_mod = mkModule (fsToUnitId unitId) modName

320429 , ms_location = modLoc

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

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

327436 , ms_hspp_file = fp

328437 , ms_hspp_opts = dflags

329− , ms_hspp_buf = Just contents

438+ , ms_hspp_buf = Nothing

330439

331440 -- defaults:

332441 , ms_hsc_src = sourceType

@@ -339,27 +448,71 @@ getModSummaryFromBuffer fp contents dflags parsed = do

339448 , ms_parsed_mod = Nothing

340449 }

341450 where

342− (sourceType, derivedFile) =

343− let (stem, ext) = splitExtension fp in

344− if "-boot" `isSuffixOf` ext

345− then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")

346− else (HsSrcFile , \newExt -> stem <.> newExt)

347−

348−

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

350−-- parsed module (or errors) and any parse warnings.

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

452+

453+-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports.

454+-- Runs preprocessors as needed.

455+getModSummaryFromImports

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

457+ => FilePath

458+ -> Maybe SB.StringBuffer

459+ -> ExceptT [FileDiagnostic] m ModSummary

460+getModSummaryFromImports fp contents = do

461+ (contents, dflags) <- preprocessor fp contents

462+ (srcImports, textualImports, L _ moduleName) <-

463+ ExceptT $ liftIO $ first (diagFromErrMsgs "parser" dflags) <$> GHC.getHeaderImports dflags contents fp fp

464+

465+ -- Force bits that might keep the string buffer and DynFlags alive unnecessarily

466+ liftIO $ evaluate $ rnf srcImports

467+ liftIO $ evaluate $ rnf textualImports

468+

469+ modLoc <- liftIO $ mkHomeModLocation dflags moduleName fp

470+

471+ let mod = mkModule (thisPackage dflags) moduleName

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

473+ summary =

474+ ModSummary

475+ { ms_mod = mod

476+#if MIN_GHC_API_VERSION(8,8,0)

477+ , ms_hie_date = Nothing

478+#endif

479+ , ms_hs_date = error "Rules should not depend on ms_hs_date"

480+ -- When we are working with a virtual file we do not have a file date.

481+ -- To avoid silent issues where something is not processed because the date

482+ -- has not changed, we make sure that things blow up if they depend on the date.

483+ , ms_hsc_src = sourceType

484+ , ms_hspp_buf = Nothing

485+ , ms_hspp_file = fp

486+ , ms_hspp_opts = dflags

487+ , ms_iface_date = Nothing

488+ , ms_location = modLoc

489+ , ms_obj_date = Nothing

490+ , ms_parsed_mod = Nothing

491+ , ms_srcimps = srcImports

492+ , ms_textual_imps = textualImports

493+ }

494+ return summary

495+

496+

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

498+-- parsed module (or errors) and any parse warnings. Does not run any preprocessors

351499parseFileContents

352500 :: GhcMonad m

353501 => (GHC.ParsedSource -> IdePreprocessedSource)

502+ -> DynFlags -- ^ flags to use

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

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

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

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

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

357−parseFileContents customPreprocessor filename mbContents = do

358− (contents, dflags) <- preprocessor filename mbContents

507+parseFileContents customPreprocessor dflags comp_pkgs filename contents = do

359508 let loc = mkRealSrcLoc (mkFastString filename) 1 1

360509 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

361513 PFailed _ locErr msgErr ->

362514 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr

515+#endif

363516 POk pst rdr_module ->

364517 let hpm_annotations =

365518 (Map.fromListWith (++) $ annotations pst,

@@ -383,14 +536,63 @@ parseFileContents customPreprocessor filename mbContents = do

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

384537 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

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

539+ let parsed' = removePackageImports comp_pkgs parsed

386540 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

387− ms <- getModSummaryFromBuffer filename contents dflags parsed

541+ ms <- getModSummaryFromBuffer filename dflags parsed'

388542 let pm =

389543 ParsedModule {

390544 pm_mod_summary = ms

391− , pm_parsed_source = parsed

545+ , pm_parsed_source = parsed'

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

393547 , pm_annotations = hpm_annotations

394548 }

395549 warnings = diagFromErrMsgs "parser" dflags warns

396550 pure (warnings ++ preproc_warnings, pm)

551+

552+

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

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

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

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

557+ where

558+ imports' = map do_one_import hsmodImports

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

560+ case PackageName . sl_fs <$> ideclPkgQual of

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

562+ _ -> L l i

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

564+ do_one_import l = l

565+#endif

566+

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

568+loadHieFile f = do

569+ u <- mkSplitUniqSupply 'a'

570+ let nameCache = initNameCache u []

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

572+

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

574+-- Assumes file exists.

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

576+loadInterface

577+ :: HscEnv

578+ -> ModSummary

579+ -> [HiFileResult]

580+ -> IO (Either String ModIface)

581+loadInterface session ms deps = do

582+ let hiFile = case ms_hsc_src ms of

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

584+ _ -> ml_hi_file $ ms_location ms

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

586+ case r of

587+ Maybes.Succeeded iface -> do

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

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

590+ return $ maybeToEither (showReason reason) iface'

591+ Maybes.Failed err -> do

592+ let errMsg = showSDoc (hsc_dflags session) err

593+ return $ Left errMsg

594+

595+showReason :: RecompileRequired -> String

596+showReason MustCompile = "Stale"

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

598+showReason UpToDate = "Up to date"

src/Development/IDE/Core/Debouncer.hs+18−11

@@ -3,16 +3,18 @@

44module Development.IDE.Core.Debouncer

55 ( Debouncer

6− , newDebouncer

76 , registerEvent

7+ , newAsyncDebouncer

8+ , noopDebouncer

89 ) where

910

1011import Control.Concurrent.Extra

1112import Control.Concurrent.Async

1213import Control.Exception

1314import Control.Monad.Extra

14−import Data.Map.Strict (Map)

15−import qualified Data.Map.Strict as Map

15+import Data.Hashable

16+import Data.HashMap.Strict (HashMap)

17+import qualified Data.HashMap.Strict as Map

1618import System.Time.Extra

1719

1820-- | A debouncer can be used to avoid triggering many events

@@ -21,13 +23,14 @@ import System.Time.Extra

2123-- by delaying each event for a given time. If another event

2224-- is registered for the same key within that timeframe,

2325-- only the new event will fire.

24−newtype Debouncer k = Debouncer (Var (Map k (Async ())))

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

2530

26−-- | Create a new empty debouncer.

27−newDebouncer :: IO (Debouncer k)

28−newDebouncer = do

29− m <- newVar Map.empty

30− pure $ Debouncer m

31+-- | Debouncer used in the IDE that delays events as expected.

32+newAsyncDebouncer :: (Eq k, Hashable k) => IO (Debouncer k)

33+newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty

3134

3235-- | Register an event that will fire after the given delay if no other event

3336-- for the same key gets registered until then.

@@ -35,11 +38,15 @@ newDebouncer = do

3538-- If there is a pending event for the same key, the pending event will be killed.

3639-- Events are run unmasked so it is up to the user of `registerEvent`

3740-- to mask if required.

38−registerEvent :: Ord k => Debouncer k -> Seconds -> k -> IO () -> IO ()

39−registerEvent (Debouncer d) delay k fire = modifyVar_ d $ \m -> mask_ $ do

41+asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()

42+asyncRegisterEvent d delay k fire = modifyVar_ d $ \m -> mask_ $ do

4043 whenJust (Map.lookup k m) cancel

4144 a <- asyncWithUnmask $ \unmask -> unmask $ do

4245 sleep delay

4346 fire

4447 modifyVar_ d (pure . Map.delete k)

4548 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.hsnew file+181

@@ -0,0 +1,181 @@

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+19−68

@@ -4,32 +4,25 @@

44{-# LANGUAGE TypeFamilies #-}

66module Development.IDE.Core.FileStore(

7− getFileExists, getFileContents,

7+ getFileContents,

8+ getVirtualFile,

89 setBufferModified,

910 setSomethingModified,

1011 fileStoreRules,

1112 VFSHandle,

1213 makeVFSHandle,

13− makeLSPVFSHandle,

14− getSourceFingerprint

14+ makeLSPVFSHandle

1515 ) where

1616

17−import Foreign.Ptr

18−import Foreign.ForeignPtr

19−import Fingerprint

20−import StringBuffer

2117import Development.IDE.GHC.Orphans()

22−import Development.IDE.GHC.Util

23−

18+import Development.IDE.Core.Shake

2419import Control.Concurrent.Extra

2520import qualified Data.Map.Strict as Map

2621import Data.Maybe

2722import qualified Data.Text as T

2823import Control.Monad.Extra

29−import qualified System.Directory as Dir

3024import Development.Shake

3125import Development.Shake.Classes

32−import Development.IDE.Core.Shake

3326import Control.Exception

3427import GHC.Generics

3528import Data.Either.Extra

@@ -41,7 +34,9 @@ import qualified Data.Rope.UTF16 as Rope

4134

4235#ifdef mingw32_HOST_OS

4336import Data.Time

37+import qualified System.Directory as Dir

4438#else

39+import Foreign.Ptr

4540import Foreign.C.String

4641import Foreign.C.Types

4742import Foreign.Marshal (alloca)

@@ -88,18 +83,7 @@ makeLSPVFSHandle lspFuncs = VFSHandle

8883

8984

9085-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.

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

86+type instance RuleResult GetFileContents = (FileVersion, Maybe T.Text)

10387

10488data GetFileContents = GetFileContents

10589 deriving (Eq, Show, Generic)

@@ -107,40 +91,16 @@ instance Hashable GetFileContents

10791instance NFData GetFileContents

10892instance Binary GetFileContents

10993

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−

13594getModificationTimeRule :: VFSHandle -> Rules ()

13695getModificationTimeRule vfs =

13796 defineEarlyCutoff $ \GetModificationTime file -> do

13897 let file' = fromNormalizedFilePath file

139− let wrap time = (Just time, ([], Just $ ModificationTime time))

98+ let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s))

14099 alwaysRerun

141100 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file

142101 case mbVirtual of

143− Just (virtualFileVersion -> ver) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))

102+ Just (virtualFileVersion -> ver) ->

103+ pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))

144104 Nothing -> liftIO $ fmap wrap (getModTime file')

145105 `catch` \(e :: IOException) -> do

146106 let err | isDoesNotExistError e = "File does not exist: " ++ file'

@@ -154,11 +114,15 @@ getModificationTimeRule vfs =

154114 -- time spent checking file modifications (which happens on every change)

155115 -- from > 0.5s to ~0.15s.

156116 -- We might also want to try speeding this up on Windows at some point.

157− getModTime :: FilePath -> IO BS.ByteString

117+ -- TODO leverage DidChangeWatchedFile lsp notifications on clients that

118+ -- support them, as done for GetFileExists

119+ getModTime :: FilePath -> IO (Int,Int)

158120 getModTime f =

159121#ifdef mingw32_HOST_OS

160122 do time <- Dir.getModificationTime f

161− pure $! BS.pack $ show (toModifiedJulianDay $ utctDay time, diffTimeToPicoseconds $ utctDayTime time)

123+ let !day = fromInteger $ toModifiedJulianDay $ utctDay time

124+ !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time

125+ pure (day, dayTime)

162126#else

163127 withCString f $ \f' ->

164128 alloca $ \secPtr ->

@@ -166,16 +130,13 @@ getModificationTimeRule vfs =

166130 Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr

167131 sec <- peek secPtr

168132 nsec <- peek nsecPtr

169− pure $! BS.pack $ show sec <> "." <> show nsec

133+ pure (fromEnum sec, fromIntegral nsec)

170134

171135-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow

172136-- as doing the FFI call ourselves :(.

173137foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int

174138#endif

175139

176−getSourceFingerprint :: NormalizedFilePath -> Action Fingerprint

177−getSourceFingerprint = use_ FingerprintSource

178−

179140getFileContentsRule :: VFSHandle -> Rules ()

180141getFileContentsRule vfs =

181142 define $ \GetFileContents file -> do

@@ -183,7 +144,7 @@ getFileContentsRule vfs =

183144 time <- use_ GetModificationTime file

184145 res <- liftIO $ ideTryIOException file $ do

185146 mbVirtual <- getVirtualFile vfs $ filePathToUri' file

186− pure $ textToStringBuffer . Rope.toText . _text <$> mbVirtual

147+ pure $ Rope.toText . _text <$> mbVirtual

187148 case res of

188149 Left err -> return ([err], Nothing)

189150 Right contents -> return ([], Just (time, contents))

@@ -195,24 +156,14 @@ ideTryIOException fp act =

195156 <$> try act

196157

197158

198−getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe StringBuffer)

159+getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe T.Text)

199160getFileContents = use_ GetFileContents

200161

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−

209162fileStoreRules :: VFSHandle -> Rules ()

210163fileStoreRules vfs = do

211164 addIdeGlobal vfs

212165 getModificationTimeRule vfs

213166 getFileContentsRule vfs

214− getFileExistsRule vfs

215− fingerprintSourceRule

216167

217168

218169-- | Notify the compiler service that a particular file has been modified.

src/Development/IDE/Core/IdeConfiguration.hsnew file+71

@@ -0,0 +1,71 @@

1+{-# LANGUAGE DuplicateRecordFields #-}

2+module Development.IDE.Core.IdeConfiguration

3+ ( IdeConfiguration(..)

4+ , registerIdeConfiguration

5+ , parseConfiguration

6+ , parseWorkspaceFolder

7+ , isWorkspaceFile

8+ , modifyWorkspaceFolders

9+ )

10+where

11+

12+import Control.Concurrent.Extra

13+import Control.Monad

14+import Data.HashSet (HashSet, singleton)

15+import Data.Text (Text, isPrefixOf)

16+import Development.IDE.Core.Shake

17+import Development.IDE.Types.Location

18+import Development.Shake

19+import Language.Haskell.LSP.Types

20+import System.FilePath (isRelative)

21+

22+-- | Lsp client relevant configuration details

23+data IdeConfiguration = IdeConfiguration

24+ { workspaceFolders :: HashSet NormalizedUri

25+ }

26+ deriving (Show)

27+

28+newtype IdeConfigurationVar = IdeConfigurationVar {unIdeConfigurationRef :: Var IdeConfiguration}

29+

30+instance IsIdeGlobal IdeConfigurationVar

31+

32+registerIdeConfiguration :: ShakeExtras -> IdeConfiguration -> IO ()

33+registerIdeConfiguration extras =

34+ addIdeGlobalExtras extras . IdeConfigurationVar <=< newVar

35+

36+getIdeConfiguration :: Action IdeConfiguration

37+getIdeConfiguration =

38+ getIdeGlobalAction >>= liftIO . readVar . unIdeConfigurationRef

39+

40+parseConfiguration :: InitializeParams -> IdeConfiguration

41+parseConfiguration InitializeParams {..} =

42+ IdeConfiguration { .. }

43+ where

44+ workspaceFolders =

45+ foldMap (singleton . toNormalizedUri) _rootUri

46+ <> (foldMap . foldMap)

47+ (singleton . parseWorkspaceFolder)

48+ _workspaceFolders

49+

50+parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri

51+parseWorkspaceFolder =

52+ toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text)

53+

54+modifyWorkspaceFolders

55+ :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()

56+modifyWorkspaceFolders ide f = do

57+ IdeConfigurationVar var <- getIdeGlobalState ide

58+ IdeConfiguration ws <- readVar var

59+ writeVar var (IdeConfiguration (f ws))

60+

61+isWorkspaceFile :: NormalizedFilePath -> Action Bool

62+isWorkspaceFile file =

63+ if isRelative (fromNormalizedFilePath file)

64+ then return True

65+ else do

66+ IdeConfiguration {..} <- getIdeConfiguration

67+ let toText = getUri . fromNormalizedUri

68+ return $

69+ any

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

71+ workspaceFolders

src/Development/IDE/Core/OfInterest.hs+24−24

@@ -1,19 +1,17 @@

22-- SPDX-License-Identifier: Apache-2.0

4−

5−{-# LANGUAGE TypeFamilies #-}

4+{-# LANGUAGE TypeFamilies #-}

65{-# LANGUAGE FlexibleInstances #-}

8−-- | A Shake implementation of the compiler service, built

9−-- using the "Shaker" abstraction layer for in-memory use.

10−--

7+-- | Utilities and state for the files of interest - those which are currently

8+-- open in the editor. The useful function is 'getFilesOfInterest'.

119module Development.IDE.Core.OfInterest(

1210 ofInterestRules,

1311 getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,

1412 ) where

1513

16−import Control.Concurrent.Extra

14+import Control.Concurrent.Extra

1715import Data.Binary

1816import Data.Hashable

1917import Control.DeepSeq

@@ -21,25 +19,22 @@ import GHC.Generics

2119import Data.Typeable

2220import qualified Data.ByteString.UTF8 as BS

2321import Control.Exception

24−import Development.IDE.Types.Location

25−import Development.IDE.Types.Logger

26−import Data.Set (Set)

27−import qualified Data.Set as Set

22+import Data.HashSet (HashSet)

23+import qualified Data.HashSet as HashSet

2824import qualified Data.Text as T

2925import Data.Tuple.Extra

3026import Data.Functor

31−import Development.Shake

32−

33−import Development.IDE.Core.Shake

27+import Development.Shake

3428

29+import Development.IDE.Types.Location

30+import Development.IDE.Types.Logger

31+import Development.IDE.Core.Shake

3532

3633

37−newtype OfInterestVar = OfInterestVar (Var (Set NormalizedFilePath))

34+newtype OfInterestVar = OfInterestVar (Var (HashSet NormalizedFilePath))

3835instance IsIdeGlobal OfInterestVar

3936

40−

41−type instance RuleResult GetFilesOfInterest = Set NormalizedFilePath

42−

37+type instance RuleResult GetFilesOfInterest = HashSet NormalizedFilePath

4338

4439data GetFilesOfInterest = GetFilesOfInterest

4540 deriving (Eq, Show, Typeable, Generic)

@@ -48,16 +43,18 @@ instance NFData GetFilesOfInterest

4843instance Binary GetFilesOfInterest

4944

5045

46+-- | The rule that initialises the files of interest state.

5147ofInterestRules :: Rules ()

5248ofInterestRules = do

53− addIdeGlobal . OfInterestVar =<< liftIO (newVar Set.empty)

49+ addIdeGlobal . OfInterestVar =<< liftIO (newVar HashSet.empty)

5450 defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do

5551 alwaysRerun

5652 filesOfInterest <- getFilesOfInterestUntracked

5753 pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest))

5854

5955

60−getFilesOfInterest :: Action (Set NormalizedFilePath)

56+-- | Get the files that are open in the IDE.

57+getFilesOfInterest :: Action (HashSet NormalizedFilePath)

6158getFilesOfInterest = useNoFile_ GetFilesOfInterest

6259

6360

@@ -65,18 +62,21 @@ getFilesOfInterest = useNoFile_ GetFilesOfInterest

6562------------------------------------------------------------

6663-- Exposed API

6764

68−-- | Set the files-of-interest which will be built and kept-up-to-date.

69−setFilesOfInterest :: IdeState -> Set NormalizedFilePath -> IO ()

65+-- | Set the files-of-interest - not usually necessary or advisable.

66+-- The LSP client will keep this information up to date.

67+setFilesOfInterest :: IdeState -> HashSet NormalizedFilePath -> IO ()

7068setFilesOfInterest state files = modifyFilesOfInterest state (const files)

7169

72−getFilesOfInterestUntracked :: Action (Set NormalizedFilePath)

70+getFilesOfInterestUntracked :: Action (HashSet NormalizedFilePath)

7371getFilesOfInterestUntracked = do

7472 OfInterestVar var <- getIdeGlobalAction

7573 liftIO $ readVar var

7674

77−modifyFilesOfInterest :: IdeState -> (Set NormalizedFilePath -> Set NormalizedFilePath) -> IO ()

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

7878modifyFilesOfInterest state f = do

7979 OfInterestVar var <- getIdeGlobalState state

8080 files <- modifyVar var $ pure . dupe . f

81− logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ Set.toList files)

81+ logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashSet.toList files)

8282 void $ shakeRun state []

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

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

22-- SPDX-License-Identifier: Apache-2.0

33module Development.IDE.Core.PositionMapping

44 ( PositionMapping(..)

5+ , fromCurrentPosition

6+ , toCurrentPosition

7+ , PositionDelta(..)

8+ , addDelta

9+ , mkDelta

510 , toCurrentRange

611 , fromCurrentRange

712 , applyChange

8− , idMapping

13+ , zeroMapping

914 -- toCurrent and fromCurrent are mainly exposed for testing

1015 , toCurrent

1116 , fromCurrent

@@ -14,12 +19,25 @@ module Development.IDE.Core.PositionMapping

1419import Control.Monad

1520import qualified Data.Text as T

1621import Language.Haskell.LSP.Types

22+import Data.List

1723

18−data PositionMapping = PositionMapping

19− { toCurrentPosition :: !(Position -> Maybe Position)

20− , fromCurrentPosition :: !(Position -> Maybe Position)

24+-- The position delta is the difference between two versions

25+data PositionDelta = PositionDelta

26+ { toDelta :: !(Position -> Maybe Position)

27+ , fromDelta :: !(Position -> Maybe Position)

2128 }

2229

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+

2341toCurrentRange :: PositionMapping -> Range -> Maybe Range

2442toCurrentRange mapping (Range a b) =

2543 Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b

@@ -28,13 +46,33 @@ fromCurrentRange :: PositionMapping -> Range -> Maybe Range

2846fromCurrentRange mapping (Range a b) =

2947 Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b

3048

31−idMapping :: PositionMapping

32−idMapping = PositionMapping Just Just

49+zeroMapping :: PositionMapping

50+zeroMapping = PositionMapping idDelta

51+

52+-- | Compose two position mappings. Composes in the same way as function

53+-- composition (ie the second argument is applyed to the position first).

54+composeDelta :: PositionDelta

55+ -> PositionDelta

56+ -> PositionDelta

57+composeDelta (PositionDelta to1 from1) (PositionDelta to2 from2) =

58+ PositionDelta (to1 <=< to2)

59+ (from1 >=> from2)

60+

61+idDelta :: PositionDelta

62+idDelta = PositionDelta Just Just

63+

64+-- | Convert a set of changes into a delta from k to k + 1

65+mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta

66+mkDelta cs = foldl' applyChange idDelta cs

67+

68+-- | Add a new delta onto a Mapping k n to make a Mapping (k - 1) n

69+addDelta :: PositionDelta -> PositionMapping -> PositionMapping

70+addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm)

3371

34−applyChange :: PositionMapping -> TextDocumentContentChangeEvent -> PositionMapping

35−applyChange posMapping (TextDocumentContentChangeEvent (Just r) _ t) = PositionMapping

36− { toCurrentPosition = toCurrent r t <=< toCurrentPosition posMapping

37− , fromCurrentPosition = fromCurrentPosition posMapping <=< fromCurrent r t

72+applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta

73+applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta

74+ { toDelta = toCurrent r t <=< toDelta

75+ , fromDelta = fromDelta <=< fromCurrent r t

3876 }

3977applyChange posMapping _ = posMapping

4078

src/Development/IDE/Core/Preprocessor.hs+104−8

@@ -8,7 +8,6 @@ module Development.IDE.Core.Preprocessor

88import Development.IDE.GHC.CPP

99import Development.IDE.GHC.Orphans()

1010import Development.IDE.GHC.Compat

11−import GHC

1211import GhcMonad

1312import StringBuffer as SB

1413

@@ -19,16 +18,26 @@ import Data.Char

1918import DynFlags

2019import qualified HeaderInfo as Hdr

2120import Development.IDE.Types.Diagnostics

21+import Development.IDE.Types.Location

2222import Development.IDE.GHC.Error

23−import SysTools (Option (..), runUnlit)

23+import SysTools (Option (..), runUnlit, runPp)

2424import Control.Monad.Trans.Except

2525import qualified GHC.LanguageExtensions as LangExt

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

2736

2837

2938-- | Given a file and some contents, apply any necessary preprocessors,

3039-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.

31−preprocessor :: GhcMonad m => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)

40+preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)

3241preprocessor filename mbContents = do

3342 -- Perform unlit

3443 (isOnDisk, contents) <-

@@ -43,12 +52,79 @@ preprocessor filename mbContents = do

4352

4453 -- Perform cpp

4554 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents

46− if not $ xopt LangExt.Cpp dflags then

55+ (isOnDisk, contents, dflags) <-

56+ if not $ xopt LangExt.Cpp dflags then

57+ return (isOnDisk, contents, dflags)

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

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

72+ return (False, contents, dflags)

73+

74+ -- Perform preprocessor

75+ if not $ gopt Opt_Pp dflags then

4776 return (contents, dflags)

4877 else do

49− contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents

78+ contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents

5079 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents

5180 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+ }

52128

53129

54130isLiterate :: FilePath -> Bool

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

57133

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

59135parsePragmasIntoDynFlags

60− :: GhcMonad m

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

61137 => FilePath

62138 -> SB.StringBuffer

63139 -> m (Either [FileDiagnostic] DynFlags)

64140parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do

65− dflags0 <- getSessionDynFlags

141+ dflags0 <- getDynFlags

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

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

68148 return dflags

69149

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

95175 escape (c:cs) = c : escape cs

96176 escape [] = []

97177

98−

99178-- | Run CPP on a file

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

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

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

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

183+

103184 case contents of

104185 Nothing -> do

105186 -- Happy case, file is not modified, so run CPP on it in-place

@@ -132,3 +213,18 @@ runCpp dflags filename contents = withTempDir $ \dir -> do

132213 = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""

133214 | otherwise = x

134215 stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out

216+

217+

218+-- | Run a preprocessor on a file

219+runPreprocessor :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer

220+runPreprocessor dflags filename contents = withTempDir $ \dir -> do

221+ let out = dir </> takeFileName filename <.> "out"

222+ inp <- case contents of

223+ Nothing -> return filename

224+ Just contents -> do

225+ let inp = dir </> takeFileName filename <.> "hs"

226+ withBinaryFile inp WriteMode $ \h ->

227+ hPutStringBuffer h contents

228+ return inp

229+ runPp dflags [SysTools.Option filename, SysTools.Option inp, SysTools.FileOption "" out]

230+ SB.hGetStringBuffer out

src/Development/IDE/Core/RuleTypes.hs+51−12

@@ -15,7 +15,6 @@ import Control.DeepSeq

1515import Data.Binary

1616import Development.IDE.Import.DependencyInformation

1717import Development.IDE.GHC.Util

18−import Development.IDE.Types.Location

1918import Data.Hashable

2019import Data.Typeable

2120import qualified Data.Set as S

@@ -25,9 +24,9 @@ import GHC.Generics (Generic)

2524import GHC

2625import Module (InstalledUnitId)

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

28−import Development.IDE.GHC.Compat

2927

3028import Development.IDE.Spans.Type

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

3130

3231

3332-- NOTATION

@@ -58,11 +57,27 @@ instance Show TcModuleResult where

5857instance NFData TcModuleResult where

5958 rnf = rwhnf

6059

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+

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

6277type instance RuleResult TypeCheck = TcModuleResult

6378

6479-- | Information about what spans occur where, requires TypeCheck

65−type instance RuleResult GetSpanInfo = [SpanInfo]

80+type instance RuleResult GetSpanInfo = SpansInfo

6681

6782-- | Convert to Core, requires TypeCheck*

6883type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)

@@ -75,16 +90,24 @@ type instance RuleResult GhcSession = HscEnvEq

7590

7691-- | Resolve the imports in a module to the file path of a module

7792-- in the same package or the package id of another package.

78−type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe NormalizedFilePath)], S.Set InstalledUnitId)

93+type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId)

7994

8095-- | This rule is used to report import cycles. It depends on GetDependencyInformation.

8196-- We cannot report the cycles directly from GetDependencyInformation since

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

8398type instance RuleResult ReportImportCycles = ()

8499

85−-- | Read the given HIE file.

86−type instance RuleResult GetHieFile = HieFile

100+-- | Read the module interface file

101+type instance RuleResult GetHiFile = HiFileResult

102+

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

104+type instance RuleResult GetModIface = HiFileResult

87105

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

88111

89112data GetParsedModule = GetParsedModule

90113 deriving (Eq, Show, Typeable, Generic)

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

146169instance NFData GhcSession

147170instance Binary GhcSession

148171

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

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

151−data GetHieFile = GetHieFile FilePath

172+data GetHiFile = GetHiFile

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

174+instance Hashable GetHiFile

175+instance NFData GetHiFile

176+instance Binary GetHiFile

177+

178+data GetModIface = GetModIface

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

180+instance Hashable GetModIface

181+instance NFData GetModIface

182+instance Binary GetModIface

183+

184+data IsFileOfInterest = IsFileOfInterest

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

186+instance Hashable IsFileOfInterest

187+instance NFData IsFileOfInterest

188+instance Binary IsFileOfInterest

189+

190+data GetModSummary = GetModSummary

152191 deriving (Eq, Show, Typeable, Generic)

153−instance Hashable GetHieFile

154−instance NFData GetHieFile

155−instance Binary GetHieFile

192+instance Hashable GetModSummary

193+instance NFData GetModSummary

194+instance Binary GetModSummary

src/Development/IDE/Core/Rules.hs+424−121

@@ -1,16 +1,18 @@

22-- SPDX-License-Identifier: Apache-2.0

4−{-# LANGUAGE TypeFamilies #-}

5−{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE CPP #-}

5+{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE FlexibleInstances #-}

67{-# LANGUAGE DuplicateRecordFields #-}

8+#include "ghc-api-version.h"

810-- | A Shake implementation of the compiler service, built

911-- using the "Shaker" abstraction layer for in-memory use.

1012--

1113module Development.IDE.Core.Rules(

1214 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),

13− Priority(..),

15+ Priority(..), GhcSessionIO(..), GhcSessionFun(..),

1416 priorityTypeCheck,

1517 priorityGenerateCore,

1618 priorityFilesOfInterest,

@@ -21,51 +23,59 @@ module Development.IDE.Core.Rules(

2123 getDefinition,

2224 getDependencies,

2325 getParsedModule,

24− fileFromParsedModule,

2526 generateCore,

2627 ) where

2728

2829import Fingerprint

2930

30−import Data.Binary

31−import Control.Monad

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

32+import Data.Bifunctor (first, second)

33+import Control.Monad.Extra

3234import Control.Monad.Trans.Class

3335import Control.Monad.Trans.Maybe

3436import Development.IDE.Core.Compile

37+import Development.IDE.Core.OfInterest

3538import Development.IDE.Types.Options

3639import Development.IDE.Spans.Calculate

3740import Development.IDE.Import.DependencyInformation

3841import Development.IDE.Import.FindImports

39−import Development.IDE.Core.FileStore

42+import Development.IDE.Core.FileExists

43+import Development.IDE.Core.FileStore (getFileContents)

4044import Development.IDE.Types.Diagnostics

4145import Development.IDE.Types.Location

46+import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)

4247import Development.IDE.GHC.Util

43−import Data.Coerce

48+import Development.IDE.GHC.WithDynFlags

4449import Data.Either.Extra

4550import Data.Maybe

4651import Data.Foldable

4752import qualified Data.IntMap.Strict as IntMap

48−import qualified Data.IntSet as IntSet

53+import Data.IntMap.Strict (IntMap)

4954import Data.List

55+import Data.Ord

5056import qualified Data.Set as Set

5157import qualified Data.Text as T

5258import Development.IDE.GHC.Error

5359import Development.Shake hiding (Diagnostic)

5460import Development.IDE.Core.RuleTypes

61+import Development.IDE.Spans.Type

62+import qualified Data.ByteString.Char8 as BS

5563

56−import GHC hiding (parseModule, typecheckModule)

5764import qualified GHC.LanguageExtensions as LangExt

58−import Development.IDE.GHC.Compat

59−import UniqSupply

60−import NameCache

6165import HscTypes

62−import DynFlags (xopt)

66+import PackageConfig

67+import DynFlags (gopt_set, xopt)

6368import GHC.Generics(Generic)

6469

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

6671import Development.IDE.Core.Service

6772import Development.IDE.Core.Shake

68−import Development.Shake.Classes

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

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

75+import Data.ByteString (ByteString)

76+import Control.Concurrent.Async (concurrently)

77+

78+import Control.Monad.State

6979

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

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

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

7989useE k = MaybeT . use k

8090

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

82−useNoFileE k = useE k ""

92+useNoFileE k = useE k emptyFilePath

8393

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

8595usesE k = MaybeT . fmap sequence . uses k

8696

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

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

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

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

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

91101

92102

@@ -103,18 +113,65 @@ getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.T

103113getAtPoint file pos = fmap join $ runMaybeT $ do

104114 opts <- lift getIdeOptions

105115 spans <- useE GetSpanInfo file

106− files <- transitiveModuleDeps <$> useE GetDependencies file

107− tms <- usesE TypeCheck (file : files)

108− return $ AtPoint.atPoint opts (map tmrModule tms) spans pos

116+ return $ AtPoint.atPoint opts spans pos

109117

110118-- | Goto Definition.

111119getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)

112120getDefinition file pos = fmap join $ runMaybeT $ do

113121 opts <- lift getIdeOptions

114122 spans <- useE GetSpanInfo file

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

116− let getHieFile x = useNoFile (GetHieFile x)

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

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

124+

125+getHieFile

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

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

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

129+getHieFile file mod = do

130+ TransitiveDependencies {transitiveNamedModuleDeps} <- use_ GetDependencies file

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

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

133+ let modPath = fromNormalizedFilePath nfp

134+ (_diags, hieFile) <- getHomeHieFile nfp

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

136+ _ -> getPackageHieFile mod file

137+

138+

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

140+getHomeHieFile f = do

141+ ms <- use_ GetModSummary f

142+ let normal_hie_f = toNormalizedFilePath' hie_f

143+ hie_f = ml_hie_file $ ms_location ms

144+ mbHieTimestamp <- use GetModificationTime normal_hie_f

145+ srcTimestamp <- use_ GetModificationTime f

146+ let isUpToDate

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

148+ | otherwise = False

149+

150+ unless isUpToDate $

151+ void $ use_ TypeCheck f

152+

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

154+ return ([], hf)

155+

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

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

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

159+getPackageHieFile mod file = do

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

161+ IdeOptions {..} <- getIdeOptions

162+ let unitId = moduleUnitId mod

163+ case lookupPackageConfig unitId pkgState of

164+ Just pkgConfig -> do

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

166+ hieFile <- liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod

167+ path <- liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod

168+ case (hieFile, path) of

169+ (Just hiePath, Just modPath) ->

170+ -- deliberately loaded outside the Shake graph

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

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

173+ _ -> return Nothing

174+ _ -> return Nothing

118175

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

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

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

134191priorityFilesOfInterest = Priority (-2)

135192

136193getParsedModuleRule :: Rules ()

137−getParsedModuleRule =

138− defineEarlyCutoff $ \GetParsedModule file -> do

139− (_, contents) <- getFileContents file

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

141− opt <- getIdeOptions

142− r <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) contents

143− mbFingerprint <- traverse (const $ getSourceFingerprint file) (optShakeFiles opt)

144− pure (fingerprintToBS <$> mbFingerprint, r)

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

195+ sess <- use_ GhcSession file

196+ let hsc = hscEnv sess

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

198+ -- parsed module

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

200+ opt <- getIdeOptions

201+ (_, contents) <- getFileContents file

202+

203+ let dflags = hsc_dflags hsc

204+ mainParse = getParsedModuleDefinition hsc opt comp_pkgs file contents

205+

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

207+ if gopt Opt_Haddock dflags

208+ then

209+ liftIO mainParse

210+ else do

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

212+ haddockParse = do

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

214+ getParsedModuleDefinition hscHaddock opt comp_pkgs file contents

215+ return diagsHaddock

216+

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

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

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

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

221+ liftIO $ concurrently mainParse haddockParse

222+

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

224+

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

226+getParsedModuleDefinition packageState opt comp_pkgs file contents = do

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

228+ case res of

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

230+ Just (contents, modu) -> do

231+ mbFingerprint <- if isNothing $ optShakeFiles opt

232+ then pure Nothing

233+ else Just . fingerprintToBS <$> fingerprintFromStringBuffer contents

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

145235

146236getLocatedImportsRule :: Rules ()

147237getLocatedImportsRule =

148238 define $ \GetLocatedImports file -> do

149− pm <- use_ GetParsedModule file

150− let ms = pm_mod_summary pm

239+ ms <- use_ GetModSummary file

151240 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]

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

153− let dflags = addRelativeImport file pm $ hsc_dflags env

241+ env_eq <- 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

154245 opt <- getIdeOptions

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

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

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

157248 case diagOrImp of

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

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

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

167258 Nothing -> pure (concat diags, Nothing)

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

169260

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

170269

171270-- | Given a target file path, construct the raw dependency results by following

172271-- imports recursively.

173−rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation

174−rawDependencyInformation f = do

175− let (initialId, initialMap) = getPathId f emptyPathIdMap

176− go (IntSet.singleton $ getFilePathId initialId)

177− (RawDependencyInformation IntMap.empty initialMap)

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

273+rawDependencyInformation fs = do

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

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

276+ return (rdi { rawBootMap = bm })

178277 where

179− go fs rawDepInfo =

180− case IntSet.minView fs of

181− -- Queue is empty

182− Nothing -> pure rawDepInfo

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

184− Just (f, fs) -> do

185− let fId = FilePathId f

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

187− case importsOrErr of

188− Nothing ->

189− -- File doesn’t parse

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

191− in go fs rawDepInfo'

192− Just (modImports, pkgImports) -> do

193− let f :: PathIdMap -> (a, Maybe NormalizedFilePath) -> (PathIdMap, (a, Maybe FilePathId))

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

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

196− Just path ->

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

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

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

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

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

202− let newFiles =

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

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

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

206− go (newFiles `IntSet.union` fs) (rawDepInfo' { rawPathIdMap = pathIdMap })

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

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

280+ go f = do

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

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

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

284+ checkAlreadyProcessed f $ do

285+ al <- lift $ modSummaryToArtifactsLocation f <$> use_ GetModSummary f

286+ -- Get a fresh FilePathId for the new file

287+ fId <- getFreshFid al

288+ -- Adding an edge to the bootmap so we can make sure to

289+ -- insert boot nodes before the real files.

290+ addBootMap al fId

291+ -- Try to parse the imports of the file

292+ importsOrErr <- lift $ use GetLocatedImports f

293+ case importsOrErr of

294+ Nothing -> do

295+ -- File doesn't parse so add the module as a failure into the

296+ -- dependency information, continue processing the other

297+ -- elements in the queue

298+ modifyRawDepInfo (insertImport fId (Left ModuleParseError))

299+ return fId

300+ Just (modImports, pkgImports) -> do

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

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

303+ let (no_file, with_file) = splitImports modImports

304+ (mns, ls) = unzip with_file

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

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

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

308+ -- Associate together the ModuleName with the FilePathId

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

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

311+ -- imports.

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

313+ return fId

314+

315+

316+ checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId

317+ checkAlreadyProcessed nfp k = do

318+ (rawDepInfo, _) <- get

319+ maybe k return (lookupPathToId (rawPathIdMap rawDepInfo) nfp)

320+

321+ modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation) -> RawDepM ()

322+ modifyRawDepInfo f = modify (first f)

323+

324+ addBootMap :: ArtifactsLocation -> FilePathId -> RawDepM ()

325+ addBootMap al fId =

326+ modify (\(rd, ss) -> (rd, if isBootLocation al

327+ then IntMap.insert (getFilePathId fId) al ss

328+ else ss))

329+

330+ getFreshFid :: ArtifactsLocation -> RawDepM FilePathId

331+ getFreshFid al = do

332+ (rawDepInfo, ss) <- get

333+ let (fId, path_map) = getPathId al (rawPathIdMap rawDepInfo)

334+ -- Insert the File into the bootmap if it's a boot module

335+ let rawDepInfo' = rawDepInfo { rawPathIdMap = path_map }

336+ put (rawDepInfo', ss)

337+ return fId

338+

339+ -- Split in (package imports, local imports)

340+ splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)]

341+ -> ([Located ModuleName], [(Located ModuleName, ArtifactsLocation)])

342+ splitImports = foldr splitImportsLoop ([],[])

343+

344+ splitImportsLoop (imp, Nothing) (ns, ls) = (imp:ns, ls)

345+ splitImportsLoop (imp, Just artifact) (ns, ls) = (ns, (imp,artifact) : ls)

346+

347+ updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =

348+ if not artifactIsSource

349+ then

350+ let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix artifactModLocation)

351+ in case msource_mod_id of

352+ Just source_mod_id -> insertBootId source_mod_id (FilePathId boot_mod_id) bm

353+ Nothing -> bm

354+ else bm

355+

356+ dropBootSuffix :: ModLocation -> FilePath

357+ dropBootSuffix (ModLocation (Just hs_src) _ _) = reverse . drop (length @[] "-boot") . reverse $ hs_src

358+ dropBootSuffix _ = error "dropBootSuffix"

207359

208360getDependencyInformationRule :: Rules ()

209361getDependencyInformationRule =

210362 define $ \GetDependencyInformation file -> do

211− rawDepInfo <- rawDependencyInformation file

363+ rawDepInfo <- rawDependencyInformation [file]

212364 pure ([], Just $ processDependencyInformation rawDepInfo)

213365

214366reportImportCyclesRule :: Rules ()

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

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

237389 , _code = Nothing

238390 , _relatedInformation = Nothing

391+ , _tags = Nothing

239392 }

240393 where loc = srcSpanToLocation (getLoc imp)

241− fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)

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

242395 getModuleName file = do

243− pm <- use_ GetParsedModule file

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

396+ ms <- use_ GetModSummary file

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

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

246399

247400-- returns all transitive dependencies in topological order.

@@ -249,7 +402,7 @@ reportImportCyclesRule =

249402getDependenciesRule :: Rules ()

250403getDependenciesRule =

251404 defineEarlyCutoff $ \GetDependencies file -> do

252− depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file

405+ depInfo <- use_ GetDependencyInformation file

253406 let allFiles = reachableModules depInfo

254407 _ <- uses_ ReportImportCycles allFiles

255408 opts <- getIdeOptions

@@ -261,48 +414,101 @@ getSpanInfoRule :: Rules ()

261414getSpanInfoRule =

262415 define $ \GetSpanInfo file -> do

263416 tc <- use_ TypeCheck file

264− (fileImports, _) <- use_ GetLocatedImports file

265417 packageState <- hscEnv <$> use_ GhcSession file

266− x <- liftIO $ getSrcSpanInfos packageState fileImports tc

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

419+ let tdeps = transitiveModuleDeps deps

420+

421+-- When possible, rely on the haddocks embedded in our interface files

422+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'

423+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)

424+ let parsedDeps = []

425+#else

426+ parsedDeps <- uses_ GetParsedModule tdeps

427+#endif

428+

429+ ifaces <- uses_ GetModIface tdeps

430+ (fileImports, _) <- use_ GetLocatedImports file

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

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

267433 return ([], Just x)

268434

269435-- Typechecks a module.

270436typeCheckRule :: Rules ()

271−typeCheckRule =

272− define $ \TypeCheck file -> do

273− pm <- use_ GetParsedModule file

274− deps <- use_ GetDependencies file

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

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

277− let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph packageState

278− file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)

279− any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq

280− tms <- if any_uses_th_qq

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

282− then do

283− bytecodes <- uses_ GenerateByteCode (transitiveModuleDeps deps)

284− tmrs <- uses_ TypeCheck (transitiveModuleDeps deps)

285− pure (zipWith addByteCode bytecodes tmrs)

286− else uses_ TypeCheck (transitiveModuleDeps deps)

287− setPriority priorityTypeCheck

288− IdeOptions{ optDefer = defer} <- getIdeOptions

289− liftIO $ typecheckModule defer packageState tms pm

290− where

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

292− addByteCode :: Linkable -> TcModuleResult -> TcModuleResult

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

294−

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

296−generateCore file = do

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

438+ pm <- use_ GetParsedModule file

439+ -- do not generate interface files as this rule is called

440+ -- for files of interest on every keystroke

441+ typeCheckRuleDefinition file pm SkipGenerationOfInterfaceFiles

442+

443+data GenerateInterfaceFiles

444+ = DoGenerateInterfaceFiles

445+ | SkipGenerationOfInterfaceFiles

446+ deriving (Show)

447+

448+-- This is factored out so it can be directly called from the GetModIface

449+-- rule. Directly calling this rule means that on the initial load we can

450+-- garbage collect all the intermediate typechecked modules rather than

451+-- retain the information forever in the shake graph.

452+typeCheckRuleDefinition

453+ :: NormalizedFilePath -- ^ Path to source file

454+ -> ParsedModule

455+ -> GenerateInterfaceFiles -- ^ Should generate .hi and .hie files ?

456+ -> Action (IdeResult TcModuleResult)

457+typeCheckRuleDefinition file pm generateArtifacts = do

458+ deps <- use_ GetDependencies file

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

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

461+ let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc

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

464+ mirs <- uses_ GetModIface (transitiveModuleDeps deps)

465+ bytecodes <- if any_uses_th_qq

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

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

468+ else

469+ pure $ repeat Nothing

470+

471+ setPriority priorityTypeCheck

472+ IdeOptions { optDefer = defer } <- getIdeOptions

473+

474+ addUsageDependencies $ liftIO $ do

475+ res <- typecheckModule defer hsc (zipWith unpack mirs bytecodes) pm

476+ case res of

477+ (diags, Just (hsc,tcm)) | DoGenerateInterfaceFiles <- generateArtifacts -> do

478+ diagsHie <- generateAndWriteHieFile hsc (tmrModule tcm)

479+ diagsHi <- generateAndWriteHiFile hsc tcm

480+ return (diags <> diagsHi <> diagsHie, Just tcm)

481+ (diags, res) ->

482+ return (diags, snd <$> res)

483+ where

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

485+ uses_th_qq dflags =

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

487+

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

489+ addUsageDependencies a = do

490+ r@(_, mtc) <- a

491+ forM_ mtc $ \tc -> do

492+ let used_files = mapMaybe udep (mi_usages (hm_iface (tmrModInfo tc)))

493+ udep (UsageFile fp _h) = Just fp

494+ udep _ = Nothing

495+ -- Add a dependency on these files which are added by things like

496+ -- qAddDependentFile

497+ void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files)

498+ return r

499+

500+

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

502+generateCore runSimplifier file = do

297503 deps <- use_ GetDependencies file

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

299505 setPriority priorityGenerateCore

300506 packageState <- hscEnv <$> use_ GhcSession file

301− liftIO $ compileModule packageState tms tm

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

302508

303509generateCoreRule :: Rules ()

304510generateCoreRule =

305− define $ \GenerateCore -> generateCore

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

306512

307513generateByteCodeRule :: Rules ()

308514generateByteCodeRule =

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

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

312518 session <- hscEnv <$> use_ GhcSession file

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

314− liftIO $ generateByteCode session tms tm guts

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

315521

316522-- A local rule type to get caching. We want to use newCache, but it has

317523-- thread killed exception issues, so we lift it to a full rule.

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

323529instance NFData GhcSessionIO

324530instance Binary GhcSessionIO

325531

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

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

327533instance Show GhcSessionFun where show _ = "GhcSessionFun"

328534instance NFData GhcSessionFun where rnf !_ = ()

329535

@@ -332,20 +538,119 @@ loadGhcSession :: Rules ()

332538loadGhcSession = do

333539 defineNoFile $ \GhcSessionIO -> do

334540 opts <- getIdeOptions

335− liftIO $ GhcSessionFun <$> optGhcSession opts

541+ GhcSessionFun <$> optGhcSession opts

542+ -- This function should always be rerun because it consults a cache to

543+ -- see what HscEnv needs to be used for the file, which can change.

544+ -- However, it should also cut-off early if it's the same HscEnv as

545+ -- last time

336546 defineEarlyCutoff $ \GhcSession file -> do

337547 GhcSessionFun fun <- useNoFile_ GhcSessionIO

548+ alwaysRerun

338549 val <- fun $ fromNormalizedFilePath file

339− opts <- getIdeOptions

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

341550

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

552+ opts <- getIdeOptions

553+ let cutoffHash =

554+ case optShakeFiles opts of

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

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

557+ Just {} -> ""

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

559+ -- from last time

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

561+ return (Just cutoffHash, val)

562+

563+getHiFileRule :: Rules ()

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

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

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

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

568+

569+ ms <- use_ GetModSummary f

570+ let hiFile = toNormalizedFilePath'

571+ $ case ms_hsc_src ms of

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

573+ _ -> ml_hi_file $ ms_location ms

574+

575+ case sequence depHis of

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

577+ Just deps -> do

578+ gotHiFile <- getFileExists hiFile

579+ if not gotHiFile

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

581+ else do

582+ hiVersion <- use_ GetModificationTime hiFile

583+ modVersion <- use_ GetModificationTime f

584+ let sourceModified = modificationTime hiVersion < modificationTime modVersion

585+ if sourceModified

586+ then do

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

588+ else do

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

590+ r <- liftIO $ loadInterface session ms deps

591+ case r of

592+ Right iface -> do

593+ let result = HiFileResult ms iface

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

595+ Left err -> do

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

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

598+

599+getModSummaryRule :: Rules ()

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

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

602+ (_, mFileContent) <- getFileContents f

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

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

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

606+

607+getModIfaceRule :: Rules ()

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

609+ fileOfInterest <- use_ IsFileOfInterest f

610+ let useHiFile =

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

612+ not fileOfInterest

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

614+ case mbHiFile of

615+ Just x ->

616+ return ([], Just x)

617+ Nothing

618+ | fileOfInterest -> do

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

620+ tmr <- use TypeCheck f

621+ return ([], extract tmr)

622+ | otherwise -> do

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

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

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

626+ sess <- use_ GhcSession f

627+ let hsc = hscEnv sess

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

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

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

631+ opt <- getIdeOptions

632+ (_, contents) <- getFileContents f

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

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

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

636+ case mb_pm of

637+ Nothing -> return (diags, Nothing)

638+ Just pm -> do

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

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

641+ let !res = extract tmr

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

643+ where

644+ extract Nothing = Nothing

645+ extract (Just tmr) =

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

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

342648

343−getHieFileRule :: Rules ()

344−getHieFileRule =

345− defineNoFile $ \(GetHieFile f) -> do

346− u <- liftIO $ mkSplitUniqSupply 'a'

347− let nameCache = initNameCache u []

348− liftIO $ fmap (hie_file_result . fst) $ readHieFile nameCache f

649+isFileOfInterestRule :: Rules ()

650+isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do

651+ filesOfInterest <- getFilesOfInterest

652+ let res = f `elem` filesOfInterest

653+ return (Just (if res then "1" else ""), ([], Just res))

349654

350655-- | A rule that wires per-file rules together

351656mainRule :: Rules ()

@@ -360,9 +665,7 @@ mainRule = do

360665 generateCoreRule

361666 generateByteCodeRule

362667 loadGhcSession

363− getHieFileRule

364−

365−------------------------------------------------------------

366−

367−fileFromParsedModule :: ParsedModule -> NormalizedFilePath

368−fileFromParsedModule = toNormalizedFilePath . ms_hspp_file . pm_mod_summary

668+ getHiFileRule

669+ getModIfaceRule

670+ isFileOfInterestRule

671+ getModSummaryRule

src/Development/IDE/Core/Service.hs+10−3

@@ -23,13 +23,16 @@ import Control.Concurrent.Async

2323import Data.Maybe

2424import Development.IDE.Types.Options (IdeOptions(..))

2525import Control.Monad

26−import Development.IDE.Core.FileStore

26+import Development.IDE.Core.Debouncer

27+import Development.IDE.Core.FileStore (VFSHandle, fileStoreRules)

28+import Development.IDE.Core.FileExists (fileExistsRules)

2729import Development.IDE.Core.OfInterest

2830import Development.IDE.Types.Logger

2931import Development.Shake

3032import Data.Either.Extra

3133import qualified Language.Haskell.LSP.Messages as LSP

3234import qualified Language.Haskell.LSP.Types as LSP

35+import qualified Language.Haskell.LSP.Types.Capabilities as LSP

3336

3437import Development.IDE.Core.Shake

3538

@@ -42,18 +45,21 @@ instance IsIdeGlobal GlobalIdeOptions

4245-- Exposed API

4346

4447-- | Initialise the Compiler Service.

45−initialise :: Rules ()

48+initialise :: LSP.ClientCapabilities

49+ -> Rules ()

4650 -> IO LSP.LspId

4751 -> (LSP.FromServerMessage -> IO ())

4852 -> Logger

53+ -> Debouncer LSP.NormalizedUri

4954 -> IdeOptions

5055 -> VFSHandle

5156 -> IO IdeState

52−initialise mainRule getLspId toDiags logger options vfs =

57+initialise caps mainRule getLspId toDiags logger debouncer options vfs =

5358 shakeOpen

5459 getLspId

5560 toDiags

5661 logger

62+ debouncer

5763 (optShakeProfiling options)

5864 (optReportProgress options)

5965 shakeOptions

@@ -63,6 +69,7 @@ initialise mainRule getLspId toDiags logger options vfs =

6369 addIdeGlobal $ GlobalIdeOptions options

6470 fileStoreRules vfs

6571 ofInterestRules

72+ fileExistsRules getLspId caps vfs

6673 mainRule

6774

6875writeProfile :: IdeState -> FilePath -> IO ()

src/Development/IDE/Core/Shake.hs+190−146

@@ -19,26 +19,28 @@

1919-- always stored as real Haskell values, whereas Shake serialises all 'A' values

2020-- between runs. To deserialise a Shake value, we just consult Values.

2121module Development.IDE.Core.Shake(

22− IdeState,

22+ IdeState, shakeExtras,

23+ ShakeExtras(..), getShakeExtras, getShakeExtrasRules,

2324 IdeRule, IdeResult, GetModificationTime(..),

2425 shakeOpen, shakeShut,

2526 shakeRun,

2627 shakeProfile,

2728 use, useWithStale, useNoFile, uses, usesWithStale,

2829 use_, useNoFile_, uses_,

29− define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, fingerprintToBS,

30+ define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,

3031 getDiagnostics, unsafeClearDiagnostics,

3132 getHiddenDiagnostics,

32− IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,

33+ IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,

3334 garbageCollect,

3435 setPriority,

3536 sendEvent,

3637 ideLogger,

3738 actionLogger,

38− FileVersion(..),

39+ FileVersion(..), modificationTime,

3940 Priority(..),

4041 updatePositionMapping,

41− OnDiskRule(..)

42+ deleteValue,

43+ OnDiskRule(..),

4244 ) where

4345

4446import Development.Shake hiding (ShakeValue, doesFileExist)

@@ -47,30 +49,27 @@ import Development.Shake.Classes

4749import Development.Shake.Rule

4850import qualified Data.HashMap.Strict as HMap

4951import qualified Data.Map.Strict as Map

50−import qualified Data.Map.Merge.Strict as Map

5152import qualified Data.ByteString.Char8 as BS

52−import qualified Data.ByteString.Internal as BS

5353import Data.Dynamic

5454import Data.Maybe

5555import Data.Map.Strict (Map)

56−import Data.List.Extra

56+import Data.List.Extra (partition, takeEnd)

5757import qualified Data.Set as Set

5858import qualified Data.Text as T

59+import Data.Traversable (for)

5960import Data.Tuple.Extra

6061import Data.Unique

6162import Development.IDE.Core.Debouncer

6263import Development.IDE.Core.PositionMapping

6364import Development.IDE.Types.Logger hiding (Priority)

64−import Foreign.Ptr

65−import Foreign.Storable

66−import GHC.Fingerprint

6765import Language.Haskell.LSP.Diagnostics

6866import qualified Data.SortedList as SL

6967import Development.IDE.Types.Diagnostics

7068import Development.IDE.Types.Location

7169import Development.IDE.Types.Options

70+import Control.Concurrent.Async

7271import Control.Concurrent.Extra

73−import Control.Exception

72+import Control.Exception.Extra

7473import Control.DeepSeq

7574import System.Time.Extra

7675import Data.Typeable

@@ -95,12 +94,16 @@ data ShakeExtras = ShakeExtras

9594 ,state :: Var Values

9695 ,diagnostics :: Var DiagnosticStore

9796 ,hiddenDiagnostics :: Var DiagnosticStore

98− ,publishedDiagnostics :: Var (Map NormalizedUri [Diagnostic])

97+ ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])

9998 -- ^ This represents the set of diagnostics that we have published.

10099 -- Due to debouncing not every change might get published.

101− ,positionMapping :: Var (Map NormalizedUri (Map TextDocumentVersion PositionMapping))

100+ ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))

102101 -- ^ Map from a text document version to a PositionMapping that describes how to map

103102 -- 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

104107 }

105108

106109getShakeExtras :: Action ShakeExtras

@@ -113,22 +116,29 @@ getShakeExtrasRules = do

113116 Just x <- getShakeExtraRules @ShakeExtras

114117 return x

115118

116−

117−

118119class Typeable a => IsIdeGlobal a where

119120

120121addIdeGlobal :: IsIdeGlobal a => a -> Rules ()

121−addIdeGlobal x@(typeOf -> ty) = do

122− ShakeExtras{globals} <- getShakeExtrasRules

122+addIdeGlobal x = do

123+ extras <- getShakeExtrasRules

124+ liftIO $ addIdeGlobalExtras extras x

125+

126+addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()

127+addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =

123128 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of

124− Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty

129+ Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty

125130 Nothing -> return $! HMap.insert ty (toDyn x) mp

126131

127132

128133getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a

129134getIdeGlobalExtras ShakeExtras{globals} = do

130− Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals

131− return $ fromDyn x $ error "Serious error, corrupt globals"

135+ let typ = typeRep (Proxy :: Proxy a)

136+ x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals

137+ case x of

138+ Just x

139+ | Just x <- fromDynamic x -> pure x

140+ | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")"

141+ Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ

132142

133143getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a

134144getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras

@@ -151,7 +161,7 @@ instance Eq Key where

151161 | otherwise = False

152162

153163instance Hashable Key where

154− hashWithSalt salt (Key key) = hashWithSalt salt key

164+ hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)

155165

156166-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,

157167-- and a value is in the Maybe. For operations that throw an error you

@@ -161,9 +171,6 @@ instance Hashable Key where

161171-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh

162172-- errors but still failed.

163173--

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)

167174

168175data Value v

169176 = Succeeded TextDocumentVersion v

@@ -198,14 +205,14 @@ valueVersion = \case

198205 Failed -> Nothing

199206

200207mappingForVersion

201− :: Map NormalizedUri (Map TextDocumentVersion PositionMapping)

208+ :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))

202209 -> NormalizedFilePath

203210 -> TextDocumentVersion

204211 -> PositionMapping

205212mappingForVersion allMappings file ver =

206− fromMaybe idMapping $

213+ maybe zeroMapping snd $

207214 Map.lookup ver =<<

208− Map.lookup (filePathToUri' file) allMappings

215+ HMap.lookup (filePathToUri' file) allMappings

209216

210217type IdeRule k v =

211218 ( Shake.RuleResult k ~ v

@@ -227,15 +234,15 @@ data IdeState = IdeState

227234

228235

229236-- This is debugging code that generates a series of profiles, if the Boolean is true

230−shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO [a]

237+shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO ([a], Maybe FilePath)

231238shakeRunDatabaseProfile mbProfileDir shakeDb acts = do

232239 (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts

233− whenJust mbProfileDir $ \dir -> do

234− count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)

235− let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"

236− shakeProfileDatabase shakeDb $ dir </> file

237− return res

238− where

240+ proFile <- for mbProfileDir $ \dir -> do

241+ 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"

243+ shakeProfileDatabase shakeDb $ dir </> file

244+ return (dir </> file)

245+ return (res, proFile)

239246

240247{-# NOINLINE profileStartTime #-}

241248profileStartTime :: String

@@ -255,6 +262,16 @@ setValues state key file val = modifyVar_ state $ \vals -> do

255262 -- Force to make sure the old HashMap is not retained

256263 evaluate $ HMap.insert (file, Key key) (fmap toDyn val) vals

257264

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+

258275-- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.

259276getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))

260277getValues state key file = do

@@ -281,34 +298,40 @@ seqValue v b = case v of

281298shakeOpen :: IO LSP.LspId

282299 -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler

283300 -> Logger

301+ -> Debouncer NormalizedUri

284302 -> Maybe FilePath

285303 -> IdeReportProgress

286304 -> ShakeOptions

287305 -> Rules ()

288306 -> IO IdeState

289−shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do

307+shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) opts rules = do

308+ inProgress <- newVar HMap.empty

290309 shakeExtras <- do

291310 globals <- newVar HMap.empty

292311 state <- newVar HMap.empty

293312 diagnostics <- newVar mempty

294313 hiddenDiagnostics <- newVar mempty

295314 publishedDiagnostics <- newVar mempty

296− debouncer <- newDebouncer

297− positionMapping <- newVar Map.empty

315+ positionMapping <- newVar HMap.empty

298316 pure ShakeExtras{..}

299317 (shakeDb, shakeClose) <-

300318 shakeOpenDatabase

301319 opts

302320 { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts

303− , shakeProgress = if reportProgress then lspShakeProgress getLspId eventer else const (pure ())

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 ()

304324 }

305325 rules

306326 shakeAbort <- newMVar $ return ()

307327 shakeDb <- shakeDb

308328 return IdeState{..}

309329

310−lspShakeProgress :: IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> IO Progress -> IO ()

311−lspShakeProgress getLspId sendMsg prog = do

330+lspShakeProgress :: Hashable a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (HMap.HashMap a Int) -> IO ()

331+lspShakeProgress getLspId sendMsg inProgress = do

332+ -- first sleep a bit, so we only show progress messages if it's going to take

333+ -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)

334+ sleep 0.1

312335 lspId <- getLspId

313336 u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique

314337 sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest

@@ -336,9 +359,9 @@ lspShakeProgress getLspId sendMsg prog = do

336359 sample = 0.1

337360 loop id prev = do

338361 sleep sample

339− p <- prog

340− let done = countSkipped p + countBuilt p

341− let todo = done + countUnknown p + countTodo p

362+ current <- readVar inProgress

363+ let done = length $ filter (== 0) $ HMap.elems current

364+ let todo = HMap.size current

342365 let next = Just $ T.pack $ show done <> "/" <> show todo

343366 when (next /= prev) $

344367 sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification

@@ -364,11 +387,11 @@ shakeShut IdeState{..} = withMVar shakeAbort $ \stop -> do

364387

365388-- | This is a variant of withMVar where the first argument is run unmasked and if it throws

366389-- an exception, the previous value is restored while the second argument is executed masked.

367−withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c

390+withMVar' :: MVar a -> (a -> IO ()) -> IO (a, c) -> IO c

368391withMVar' var unmasked masked = mask $ \restore -> do

369392 a <- takeMVar var

370− b <- restore (unmasked a) `onException` putMVar var a

371− (a', c) <- masked b

393+ restore (unmasked a) `onException` putMVar var a

394+ (a', c) <- masked

372395 putMVar var a'

373396 pure c

374397

@@ -380,23 +403,33 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =

380403 (\stop -> do

381404 (stopTime,_) <- duration stop

382405 logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"

383− bar <- newBarrier

384− start <- offsetTime

385− pure (start, bar))

406+ )

386407 -- It is crucial to be masked here, otherwise we can get killed

387408 -- between spawning the new thread and updating shakeAbort.

388409 -- See https://github.com/digital-asset/ghcide/issues/79

389− (\(start, bar) -> do

390− thread <- forkFinally (shakeRunDatabaseProfile shakeProfileDir shakeDb acts) $ \res -> do

391− runTime <- start

392− let res' = case res of

393− Left e -> "exception: " <> displayException e

394− Right _ -> "completed"

395− logDebug logger $ T.pack $

396− "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ ")"

397− signalBarrier bar res

398− -- important: we send an async exception to the thread, then wait for it to die, before continuing

399− pure (killThread thread >> void (waitBarrier bar), either throwIO return =<< waitBarrier bar))

410+ (do

411+ start <- offsetTime

412+ aThread <- asyncWithUnmask $ \restore -> do

413+ res <- try (restore $ shakeRunDatabaseProfile shakeProfileDir shakeDb acts)

414+ runTime <- start

415+ let res' = case res of

416+ Left e -> "exception: " <> displayException e

417+ 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 $

425+ "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ profile ++ ")"

426+ return (fst <$> res, logMsg)

427+ let wrapUp (res, _) = do

428+ either (throwIO @SomeException) return res

429+ _ <- async $ do

430+ (_, logMsg) <- wait aThread

431+ logMsg

432+ pure (cancel aThread, wrapUp =<< wait aThread))

400433

401434getDiagnostics :: IdeState -> IO [FileDiagnostic]

402435getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do

@@ -423,9 +456,9 @@ garbageCollect keep = do

423456 return $! dupe values

424457 modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags

425458 modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags

426− modifyVar_ publishedDiagnostics $ \diags -> return $! Map.filterWithKey (\uri _ -> keep (fromUri uri)) diags

459+ modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags

427460 let versionsForFile =

428− Map.fromListWith Set.union $

461+ HMap.fromListWith Set.union $

429462 mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $

430463 HMap.toList newState

431464 modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings

@@ -443,25 +476,25 @@ useWithStale :: IdeRule k v

443476useWithStale key file = head <$> usesWithStale key [file]

444477

445478useNoFile :: IdeRule k v => k -> Action (Maybe v)

446−useNoFile key = use key ""

479+useNoFile key = use key emptyFilePath

447480

448481use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v

449482use_ key file = head <$> uses_ key [file]

450483

451484useNoFile_ :: IdeRule k v => k -> Action v

452−useNoFile_ key = use_ key ""

485+useNoFile_ key = use_ key emptyFilePath

453486

454487uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]

455488uses_ key files = do

456489 res <- uses key files

457490 case sequence res of

458− Nothing -> liftIO $ throwIO BadDependency

491+ Nothing -> liftIO $ throwIO $ BadDependency (show key)

459492 Just v -> return v

460493

461494

462495-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency

463496-- which short-circuits the rest of the action

464−data BadDependency = BadDependency deriving Show

497+data BadDependency = BadDependency String deriving Show

465498instance Exception BadDependency

466499

467500isBadDependency :: SomeException -> Bool

@@ -480,12 +513,10 @@ instance Show k => Show (Q k) where

480513

481514-- | Invariant: the 'v' must be in normal form (fully evaluated).

482515-- 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?

485−data A v = A (Value v) ShakeValue

516+newtype A v = A (Value v)

486517 deriving Show

487518

488−instance NFData (A v) where rnf (A v x) = v `seq` rnf x

519+instance NFData (A v) where rnf (A v) = v `seq` ()

489520

490521-- In the Shake database we only store one type of key/result pairs,

491522-- namely Q (question) / A (answer).

@@ -495,59 +526,70 @@ type instance RuleResult (Q k) = A (RuleResult k)

495526-- | Return up2date results. Stale results will be ignored.

496527uses :: IdeRule k v

497528 => k -> [NormalizedFilePath] -> Action [Maybe v]

498−uses key files = map (\(A value _) -> currentValue value) <$> apply (map (Q . (key,)) files)

529+uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files)

499530

500531-- | Return the last computed result which might be stale.

501532usesWithStale :: IdeRule k v

502533 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]

503534usesWithStale key files = do

504− values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)

505− mapM (uncurry lastValue) (zip files values)

535+ values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files)

536+ zipWithM lastValue files values

537+

538+

539+withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b

540+withProgress var file = actionBracket (f succ) (const $ f pred) . const

541+ -- This functions are deliberately eta-expanded to avoid space leaks.

542+ -- Do not remove the eta-expansion without profiling a session with at

543+ -- least 1000 modifications.

544+ where f shift = modifyVar_ var $ \x -> evaluate $ HMap.alter (\x -> Just $! shift (fromMaybe 0 x)) file x

545+

506546

507547defineEarlyCutoff

508548 :: IdeRule k v

509549 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))

510550 -> Rules ()

511551defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do

512− extras@ShakeExtras{state} <- getShakeExtras

513− val <- case old of

514− Just old | mode == RunDependenciesSame -> do

515− v <- liftIO $ getValues state key file

516− case v of

517− -- No changes in the dependencies and we have

518− -- an existing result.

519− Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)

520− _ -> return Nothing

521− _ -> return Nothing

522− case val of

523− Just res -> return res

524− Nothing -> do

525− (bs, (diags, res)) <- actionCatch

526− (do v <- op key file; liftIO $ evaluate $ force $ v) $

527− \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))

528− modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file

529− (bs, res) <- case res of

530− Nothing -> do

531− staleV <- liftIO $ getValues state key file

532− pure $ case staleV of

533− Nothing -> (toShakeValue ShakeResult bs, Failed)

534− Just v -> case v of

535− Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)

536− Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)

537− Failed -> (toShakeValue ShakeResult bs, Failed)

538− Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)

539− liftIO $ setValues state key file res

540− updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags

541− let eq = case (bs, fmap decodeShakeValue old) of

542− (ShakeResult a, Just (ShakeResult b)) -> a == b

543− (ShakeStale a, Just (ShakeStale b)) -> a == b

544− -- If we do not have a previous result

545− -- or we got ShakeNoCutoff we always return False.

546− _ -> False

547− return $ RunResult

548− (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)

549− (encodeShakeValue bs) $

550− A res bs

552+ extras@ShakeExtras{state, inProgress} <- getShakeExtras

553+ -- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key

554+ (if show key == "GetFileExists" then id else withProgress inProgress file) $ do

555+ val <- case old of

556+ Just old | mode == RunDependenciesSame -> do

557+ v <- liftIO $ getValues state key file

558+ case v of

559+ -- No changes in the dependencies and we have

560+ -- an existing result.

561+ Just v -> return $ Just $ RunResult ChangedNothing old $ A v

562+ _ -> return Nothing

563+ _ -> return Nothing

564+ case val of

565+ Just res -> return res

566+ Nothing -> do

567+ (bs, (diags, res)) <- actionCatch

568+ (do v <- op key file; liftIO $ evaluate $ force v) $

569+ \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))

570+ modTime <- liftIO $ (currentValue =<<) <$> getValues state GetModificationTime file

571+ (bs, res) <- case res of

572+ Nothing -> do

573+ staleV <- liftIO $ getValues state key file

574+ pure $ case staleV of

575+ Nothing -> (toShakeValue ShakeResult bs, Failed)

576+ Just v -> case v of

577+ Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)

578+ Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)

579+ Failed -> (toShakeValue ShakeResult bs, Failed)

580+ Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)

581+ liftIO $ setValues state key file res

582+ updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags

583+ let eq = case (bs, fmap decodeShakeValue old) of

584+ (ShakeResult a, Just (ShakeResult b)) -> a == b

585+ (ShakeStale a, Just (ShakeStale b)) -> a == b

586+ -- If we do not have a previous result

587+ -- or we got ShakeNoCutoff we always return False.

588+ _ -> False

589+ return $ RunResult

590+ (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)

591+ (encodeShakeValue bs) $

592+ A res

551593

552594

553595-- | Rule type, input file

@@ -615,21 +657,15 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $

615657 | otherwise = ChangedRecomputeDiff

616658 pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)

617659

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−

624660needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()

625661needOnDisk k file = do

626662 successfull <- apply1 (QDisk k file)

627− liftIO $ unless successfull $ throwIO BadDependency

663+ liftIO $ unless successfull $ throwIO $ BadDependency (show k)

628664

629665needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()

630666needOnDisks k files = do

631667 successfulls <- apply $ map (QDisk k) files

632− liftIO $ unless (and successfulls) $ throwIO BadDependency

668+ liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k)

633669

634670toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue

635671toShakeValue = maybe ShakeNoCutoff

@@ -668,7 +704,7 @@ updateFileDiagnostics ::

668704 -> [(ShowDiagnostic,Diagnostic)] -- ^ current results

669705 -> Action ()

670706updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do

671− modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp

707+ modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp

672708 let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current

673709 mask_ $ do

674710 -- Mask async exceptions to ensure that updated diagnostics are always

@@ -681,7 +717,7 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, published

681717 let newDiags = getFileDiagnostics fp newDiagsStore

682718 _ <- evaluate newDiagsStore

683719 _ <- evaluate newDiags

684− pure $! (newDiagsStore, newDiags)

720+ pure (newDiagsStore, newDiags)

685721 modifyVar_ hiddenDiagnostics $ \old -> do

686722 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)

687723 (T.pack $ show k) (map snd currentHidden) old

@@ -693,10 +729,10 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, published

693729 let delay = if null newDiags then 0.1 else 0

694730 registerEvent debouncer delay uri $ do

695731 mask_ $ modifyVar_ publishedDiagnostics $ \published -> do

696− let lastPublish = Map.findWithDefault [] uri published

732+ let lastPublish = HMap.lookupDefault [] uri published

697733 when (lastPublish /= newDiags) $

698734 eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags

699− pure $! Map.insert uri newDiags published

735+ pure $! HMap.insert uri newDiags published

700736

701737publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage

702738publishDiagnosticsNotification uri diags =

@@ -707,7 +743,7 @@ publishDiagnosticsNotification uri diags =

707743newtype Priority = Priority Double

708744

709745setPriority :: Priority -> Action ()

710−setPriority (Priority p) = deprioritize p

746+setPriority (Priority p) = reschedule p

711747

712748sendEvent :: LSP.FromServerMessage -> Action ()

713749sendEvent e = do

@@ -732,19 +768,22 @@ instance Binary GetModificationTime

732768-- | Get the modification time of a file.

733769type instance RuleResult GetModificationTime = FileVersion

734770

735−-- | We store the modification time as a ByteString since we need

736−-- a ByteString anyway for Shake and we do not care about how times

737−-- are represented.

738−data FileVersion = VFSVersion Int | ModificationTime BS.ByteString

771+data FileVersion

772+ = VFSVersion !Int

773+ | ModificationTime

774+ !Int -- ^ Large unit (platform dependent, do not make assumptions)

775+ !Int -- ^ Small unit (platform dependent, do not make assumptions)

739776 deriving (Show, Generic)

740777

741778instance NFData FileVersion

742779

743780vfsVersion :: FileVersion -> Maybe Int

744781vfsVersion (VFSVersion i) = Just i

745−vfsVersion (ModificationTime _) = Nothing

746−

782+vfsVersion ModificationTime{} = Nothing

747783

784+modificationTime :: FileVersion -> Maybe (Int, Int)

785+modificationTime VFSVersion{} = Nothing

786+modificationTime (ModificationTime large small) = Just (large, small)

748787

749788getDiagnosticsFromStore :: StoreItem -> [Diagnostic]

750789getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags

@@ -769,7 +808,7 @@ getAllDiagnostics ::

769808 DiagnosticStore ->

770809 [FileDiagnostic]

771810getAllDiagnostics =

772− concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . Map.toList

811+ concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList

773812

774813getFileDiagnostics ::

775814 NormalizedFilePath ->

@@ -777,29 +816,34 @@ getFileDiagnostics ::

777816 [LSP.Diagnostic]

778817getFileDiagnostics fp ds =

779818 maybe [] getDiagnosticsFromStore $

780− Map.lookup (filePathToUri' fp) ds

819+ HMap.lookup (filePathToUri' fp) ds

781820

782821filterDiagnostics ::

783822 (NormalizedFilePath -> Bool) ->

784823 DiagnosticStore ->

785824 DiagnosticStore

786825filterDiagnostics keep =

787− Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)

826+ HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri)

788827

789828filterVersionMap

790− :: Map NormalizedUri (Set.Set TextDocumentVersion)

791− -> Map NormalizedUri (Map TextDocumentVersion a)

792− -> Map NormalizedUri (Map TextDocumentVersion a)

829+ :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)

830+ -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)

831+ -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)

793832filterVersionMap =

794− Map.merge Map.dropMissing Map.dropMissing $

795− Map.zipWithMatched $ \_ versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep

833+ HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep

796834

797835updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()

798−updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do

836+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do

799837 modifyVar_ positionMapping $ \allMappings -> do

800838 let uri = toNormalizedUri _uri

801− let mappingForUri = Map.findWithDefault Map.empty uri allMappings

802− let updatedMapping =

803− Map.insert _version idMapping $

804− Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri

805− pure $! Map.insert uri updatedMapping allMappings

839+ let mappingForUri = HMap.lookupDefault Map.empty uri allMappings

840+ let (_, updatedMapping) =

841+ -- Very important to use mapAccum here so that the tails of

842+ -- each mapping can be shared, otherwise quadratic space is

843+ -- used which is evident in long running sessions.

844+ Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))

845+ zeroMapping

846+ (Map.insert _version (shared_change, zeroMapping) mappingForUri)

847+ pure $! HMap.insert uri updatedMapping allMappings

848+ where

849+ shared_change = mkDelta changes

src/Development/IDE/GHC/CPP.hs+34−5

@@ -19,7 +19,8 @@

1919--

2020-----------------------------------------------------------------------------

2121

22−module Development.IDE.GHC.CPP(doCpp) where

22+module Development.IDE.GHC.CPP(doCpp, addOptP)

23+where

2324

2425import Development.IDE.GHC.Compat

2526import Packages

@@ -28,9 +29,15 @@ import Module

2829import DynFlags

2930import Panic

3031import FileCleanup

31−#if MIN_GHC_API_VERSION(8,8,0)

32+#if MIN_GHC_API_VERSION(8,8,2)

33+import LlvmCodeGen (llvmVersionList)

34+#elif MIN_GHC_API_VERSION(8,8,0)

3235import LlvmCodeGen (LlvmVersion (..))

3336#endif

37+#if MIN_GHC_API_VERSION (8,10,0)

38+import Fingerprint

39+import ToolSettings

40+#endif

3441

3542import System.Directory

3643import System.FilePath

@@ -57,7 +64,11 @@ doCpp dflags raw input_fn output_fn = do

5764 let verbFlags = getVerbFlags dflags

5865

5966 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

6070 | otherwise = SysTools.runCc

71+#endif

6172 dflags (SysTools.Option "-E" : args)

6273

6374 let target_defs =

@@ -114,8 +125,6 @@ doCpp dflags raw input_fn output_fn = do

114125 ++ map SysTools.Option sse_defs

115126 ++ map SysTools.Option avx_defs

116127 ++ mb_macro_include

117− -- Define a special macro "__GHCIDE__"

118− ++ [ SysTools.Option "-D__GHCIDE__"]

119128 -- Set the language mode to assembler-with-cpp when preprocessing. This

120129 -- alleviates some of the C99 macro rules relating to whitespace and the hash

121130 -- operator, which we tend to abuse. Clang in particular is not very happy

@@ -139,7 +148,11 @@ getBackendDefs :: DynFlags -> IO [String]

139148getBackendDefs dflags | hscTarget dflags == HscLlvm = do

140149 llvmVer <- figureLlvmVersion dflags

141150 return $ case llvmVer of

142−#if MIN_GHC_API_VERSION(8,8,0)

151+#if MIN_GHC_API_VERSION(8,8,2)

152+ Just v

153+ | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ]

154+ | m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ]

155+#elif MIN_GHC_API_VERSION(8,8,0)

143156 Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]

144157 Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]

145158#else

@@ -154,6 +167,22 @@ getBackendDefs dflags | hscTarget dflags == HscLlvm = do

154167getBackendDefs _ =

155168 return []

156169

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+

157186-- ---------------------------------------------------------------------------

158187-- Macros (cribbed from Cabal)

159188

src/Development/IDE/GHC/Compat.hs+251−27

@@ -2,62 +2,106 @@

22-- SPDX-License-Identifier: Apache-2.0

44{-# LANGUAGE CPP #-}

5+{-# LANGUAGE PatternSynonyms #-}

56#include "ghc-api-version.h"

78-- | Attempt at hiding the GHC version differences we can.

89module Development.IDE.GHC.Compat(

10+ getHeaderImports,

911 HieFileResult(..),

10− HieFile(..),

12+ HieFile,

13+ hieExportNames,

14+ hie_module,

1115 mkHieFile,

1216 writeHieFile,

1317 readHieFile,

18+ supportsHieFiles,

19+ setDefaultHieDir,

20+ dontWriteHieFiles,

21+#if !MIN_GHC_API_VERSION(8,8,0)

22+ ml_hie_file,

23+#endif

1424 hPutStringBuffer,

1525 includePathsGlobal,

1626 includePathsQuote,

1727 addIncludePathsQuote,

18− ghcEnumerateExtensions

28+ getModuleHash,

29+ getPackageName,

30+ pattern DerivD,

31+ pattern ForD,

32+ pattern InstD,

33+ pattern TyClD,

34+ pattern ValD,

35+ pattern ClassOpSig,

36+ pattern IEThingAll,

37+ pattern IEThingWith,

38+ GHC.ModLocation,

39+ Module.addBootSuffix,

40+ pattern ModLocation,

41+ getConArgs,

42+

43+ module GHC

1944 ) where

2045

2146import StringBuffer

2247import DynFlags

23−import GHC.LanguageExtensions.Type

48+import FieldLabel

49+import Fingerprint (Fingerprint)

50+import qualified Module

51+import Packages

2452

25−#if MIN_GHC_API_VERSION(8,8,0)

26−import Data.List.Extra (enumerate)

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)

57+ , getConArgs

58+#endif

59+ )

60+import qualified HeaderInfo as Hdr

61+import Avail

62+import ErrUtils (ErrorMessages)

63+import FastString (FastString)

64+

65+#if MIN_GHC_API_VERSION(8,10,0)

66+import HscTypes (mi_mod_hash)

2767#endif

2868

2969#if MIN_GHC_API_VERSION(8,8,0)

30−import HieAst

70+import Control.Applicative ((<|>))

71+import Development.IDE.GHC.HieAst (mkHieFile)

3172import HieBin

3273import HieTypes

74+

75+supportsHieFiles :: Bool

76+supportsHieFiles = True

77+

78+hieExportNames :: HieFile -> [(SrcSpan, Name)]

79+hieExportNames = nameListFromAvails . hie_exports

80+

3381#else

34−import GHC

35−import GhcPlugins

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)

3693import NameCache

37−import Avail

3894import TcRnTypes

3995import System.IO

4096import Foreign.ForeignPtr

97+import MkIface

4198

4299

43−#if !MIN_GHC_API_VERSION(8,8,0)

44100hPutStringBuffer :: Handle -> StringBuffer -> IO ()

45101hPutStringBuffer hdl (StringBuffer buf len cur)

46102 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->

47103 hPutBuf hdl ptr len

48−#endif

49104

50−mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile

51−mkHieFile _ _ _ = return (HieFile () [])

52−

53−writeHieFile :: FilePath -> HieFile -> IO ()

54−writeHieFile _ _ = return ()

55−

56−readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())

57−readHieFile _ _ = return (HieFileResult (HieFile () []), ())

58−

59−data HieFile = HieFile {hie_module :: (), hie_exports :: [AvailInfo]}

60−data HieFileResult = HieFileResult { hie_file_result :: HieFile }

61105#endif

62106

63107#if !MIN_GHC_API_VERSION(8,6,0)

@@ -75,11 +119,191 @@ addIncludePathsQuote path x = x{includePaths = f $ includePaths x}

75119addIncludePathsQuote path x = x{includePaths = path : includePaths x}

76120#endif

77121

78−ghcEnumerateExtensions :: [Extension]

122+pattern DerivD :: DerivDecl p -> HsDecl p

123+pattern DerivD x <-

124+#if MIN_GHC_API_VERSION(8,6,0)

125+ GHC.DerivD _ x

126+#else

127+ GHC.DerivD x

128+#endif

129+

130+pattern ForD :: ForeignDecl p -> HsDecl p

131+pattern ForD x <-

132+#if MIN_GHC_API_VERSION(8,6,0)

133+ GHC.ForD _ x

134+#else

135+ GHC.ForD x

136+#endif

137+

138+pattern ValD :: HsBind p -> HsDecl p

139+pattern ValD x <-

140+#if MIN_GHC_API_VERSION(8,6,0)

141+ GHC.ValD _ x

142+#else

143+ GHC.ValD x

144+#endif

145+

146+pattern InstD :: InstDecl p -> HsDecl p

147+pattern InstD x <-

148+#if MIN_GHC_API_VERSION(8,6,0)

149+ GHC.InstD _ x

150+#else

151+ GHC.InstD x

152+#endif

153+

154+pattern TyClD :: TyClDecl p -> HsDecl p

155+pattern TyClD x <-

156+#if MIN_GHC_API_VERSION(8,6,0)

157+ GHC.TyClD _ x

158+#else

159+ GHC.TyClD x

160+#endif

161+

162+pattern ClassOpSig :: Bool -> [Located (IdP pass)] -> LHsSigType pass -> Sig pass

163+pattern ClassOpSig a b c <-

164+#if MIN_GHC_API_VERSION(8,6,0)

165+ GHC.ClassOpSig _ a b c

166+#else

167+ GHC.ClassOpSig a b c

168+#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 <-

79180#if MIN_GHC_API_VERSION(8,8,0)

80−ghcEnumerateExtensions = enumerate

81−#elif MIN_GHC_API_VERSION(8,6,0)

82−ghcEnumerateExtensions = [Cpp .. StarIsType]

181+ GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c ""

83182#else

84−ghcEnumerateExtensions = [Cpp .. EmptyDataDeriving]

183+ GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c

85184#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+37−4

@@ -9,12 +9,19 @@ module Development.IDE.GHC.Error

99 , diagFromStrings

1010 , diagFromGhcException

1111 , catchSrcErrors

12+ , mergeDiagnostics

1213

1314 -- * utilities working with spans

1415 , srcSpanToLocation

16+ , srcSpanToRange

1517 , srcSpanToFilename

1618 , zeroSpan

1719 , realSpan

20+ , isInsideSrcSpan

21+ , noSpan

22+

23+ -- * utilities working with severities

24+ , toDSeverity

1825 ) where

1926

2027import Development.IDE.Types.Diagnostics as D

@@ -30,11 +37,12 @@ import Panic

3037import ErrUtils

3138import SrcLoc

3239import qualified Outputable as Out

40+import Exception (ExceptionMonad)

3341

3442

3543

3644diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic

37−diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,ShowDiag,)

45+diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename loc,ShowDiag,)

3846 Diagnostic

3947 { _range = srcSpanToRange loc

4048 , _severity = Just sev

@@ -42,18 +50,39 @@ diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename

4250 , _message = msg

4351 , _code = Nothing

4452 , _relatedInformation = Nothing

53+ , _tags = Nothing

4554 }

4655

4756-- | Produce a GHC-style error from a source span and a message.

4857diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]

4958diagFromErrMsg diagSource dflags e =

50− [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $ ErrUtils.pprLocErrMsg e

59+ [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $

60+ ErrUtils.formatErrDoc dflags $ ErrUtils.errMsgDoc e

5161 | Just sev <- [toDSeverity $ errMsgSeverity e]]

5262

5363

5464diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]

5565diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList

5666

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

5786

5887-- | Convert a GHC SrcSpan to a DAML compiler Range

5988srcSpanToRange :: SrcSpan -> Range

@@ -74,7 +103,11 @@ srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real

74103srcSpanToLocation :: SrcSpan -> Location

75104srcSpanToLocation src =

76105 -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code

77− Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath $ srcSpanToFilename src) (srcSpanToRange src)

106+ 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

78111

79112-- | Convert a GHC severity to a DAML compiler Severity. Severities below

80113-- "Warning" level are dropped (returning Nothing).

@@ -117,7 +150,7 @@ realSpan = \case

117150

118151-- | Run something in a Ghc monad and catch the errors (SourceErrors and

119152-- compiler-internal exceptions like Panic or InstallationError).

120−catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)

153+catchSrcErrors :: (HasDynFlags m, ExceptionMonad m) => T.Text -> m a -> m (Either [FileDiagnostic] a)

121154catchSrcErrors fromWhere ghcM = do

122155 dflags <- getDynFlags

123156 handleGhcException (ghcExceptionToDiagnostics dflags) $

src/Development/IDE/GHC/Orphans.hs+10−3

@@ -1,8 +1,10 @@

22-- SPDX-License-Identifier: Apache-2.0

4+{-# LANGUAGE CPP #-}

45{-# LANGUAGE FlexibleInstances #-}

56{-# OPTIONS_GHC -Wno-orphans #-}

7+#include "ghc-api-version.h"

79-- | Orphan instances for GHC.

810-- Note that the 'NFData' instances may not be law abiding.

@@ -31,7 +33,7 @@ instance NFData Linkable where rnf = rwhnf

3133instance Show InstalledUnitId where

3234 show = installedUnitIdString

3335

34−instance NFData InstalledUnitId where rnf = rwhnf

36+instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS

3537

3638instance NFData SB.StringBuffer where rnf = rwhnf

3739

@@ -40,8 +42,8 @@ instance Show Module where

4042

4143instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint

4244

43−instance NFData (GenLocated SrcSpan ModuleName) where

44− rnf = rwhnf

45+instance (NFData l, NFData e) => NFData (GenLocated l e) where

46+ rnf (L l e) = rnf l `seq` rnf e

4547

4648instance Show ModSummary where

4749 show = show . ms_mod

@@ -52,6 +54,11 @@ instance Show ParsedModule where

5254instance NFData ModSummary where

5355 rnf = rwhnf

5456

57+#if !MIN_GHC_API_VERSION(8,10,0)

58+instance NFData FastString where

59+ rnf = rwhnf

60+#endif

61+

5562instance NFData ParsedModule where

5663 rnf = rwhnf

5764

src/Development/IDE/GHC/Util.hs+146−65

@@ -1,65 +1,83 @@

22-- SPDX-License-Identifier: Apache-2.0

4−{-# OPTIONS_GHC -Wno-missing-fields #-} -- to enable prettyPrint

5−{-# LANGUAGE CPP #-}

6−#include "ghc-api-version.h"

7−

8−-- | GHC utility functions. Importantly, code using our GHC should never:

9−--

10−-- * Call runGhc, use runGhcFast instead. It's faster and doesn't require config we don't have.

11−--

12−-- * Call setSessionDynFlags, use modifyDynFlags instead. It's faster and avoids loading packages.

4+-- | General utility functions, mostly focused around GHC operations.

135module Development.IDE.GHC.Util(

14− lookupPackageConfig,

6+ -- * HcsEnv and environment

7+ HscEnvEq(GhcVersionMismatch, compileTime, runTime), hscEnv, newHscEnvEq,

158 modifyDynFlags,

16− fakeDynFlags,

17− prettyPrint,

9+ evalGhcEnv,

1810 runGhcEnv,

11+ deps,

12+ -- * GHC wrappers

13+ prettyPrint,

14+ printRdrName,

15+ printName,

16+ ParseResult(..), runParser,

17+ lookupPackageConfig,

1918 textToStringBuffer,

19+ stringBufferToByteString,

2020 moduleImportPath,

21− HscEnvEq, hscEnv, newHscEnvEq,

21+ cgGutsToCoreModule,

22+ fingerprintToBS,

23+ fingerprintFromStringBuffer,

24+ -- * General utilities

2225 readFileUtf8,

2326 hDuplicateTo',

24− cgGutsToCoreModule

27+ setDefaultHieDir,

28+ dontWriteHieFiles

2529 ) where

2630

27−import Config

2831import Control.Concurrent

2932import Data.List.Extra

33+import Data.ByteString.Internal (ByteString(..))

3034import Data.Maybe

3135import Data.Typeable

32−#if MIN_GHC_API_VERSION(8,6,0)

36+import qualified Data.ByteString.Internal as BS

3337import Fingerprint

34−#endif

35−import GHC

3638import GhcMonad

37−import GhcPlugins hiding (Unique)

38−import Data.IORef

3939import Control.Exception

40+import Data.IORef

41+import Data.Version (showVersion, Version)

4042import FileCleanup

43+import Foreign.Ptr

44+import Foreign.ForeignPtr

45+import Foreign.Storable

4146import GHC.IO.BufferedIO (BufferedIO)

4247import GHC.IO.Device as IODevice

4348import GHC.IO.Encoding

4449import GHC.IO.Exception

4550import GHC.IO.Handle.Types

4651import GHC.IO.Handle.Internals

47−import Platform

4852import Data.Unique

4953import Development.Shake.Classes

5054import qualified Data.Text as T

5155import qualified Data.Text.Encoding as T

5256import qualified Data.Text.Encoding.Error as T

5357import qualified Data.ByteString as BS

58+import Lexer

5459import StringBuffer

5560import 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)

5671

72+import Development.IDE.GHC.Compat as GHC

5773import Development.IDE.Types.Location

5874

5975

6076----------------------------------------------------------------------

6177-- GHC setup

6278

79+-- | Used to modify dyn flags in preference to calling 'setSessionDynFlags',

80+-- since that function also reloads packages (which is very slow).

6381modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()

6482modifyDynFlags f = do

6583 newFlags <- f <$> getSessionDynFlags

@@ -68,6 +86,7 @@ modifyDynFlags f = do

6886 modifySession $ \h ->

6987 h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} }

7088

89+-- | Given a 'UnitId' try and find the associated 'PackageConfig' in the environment.

7190lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig

7291lookupPackageConfig unitId env =

7392 lookupPackage' False pkgConfigMap unitId

@@ -78,86 +97,134 @@ lookupPackageConfig unitId env =

7897 getPackageConfigMap $ hsc_dflags env

7998

8099

81−-- would be nice to do this more efficiently...

100+-- | Convert from the @text@ package to the @GHC@ 'StringBuffer'.

101+-- Currently implemented somewhat inefficiently (if it ever comes up in a profile).

82102textToStringBuffer :: T.Text -> StringBuffer

83103textToStringBuffer = stringToStringBuffer . T.unpack

84104

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

85115

116+-- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.

86117prettyPrint :: Outputable a => a -> String

87−prettyPrint = showSDoc fakeDynFlags . ppr

118+prettyPrint = showSDoc unsafeGlobalDynFlags . ppr

119+

120+-- | Pretty print a 'RdrName' wrapping operators in parens

121+printRdrName :: RdrName -> String

122+printRdrName name = showSDocUnsafe $ parenSymOcc rn (ppr rn)

123+ where

124+ rn = rdrNameOcc name

88125

89−runGhcEnv :: HscEnv -> Ghc a -> IO a

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)

90138runGhcEnv env act = do

91139 filesToClean <- newIORef emptyFilesToClean

92140 dirsToClean <- newIORef mempty

93141 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}

94142 ref <- newIORef env{hsc_dflags=dflags}

95− unGhc act (Session ref) `finally` do

143+ res <- unGhc act (Session ref) `finally` do

96144 cleanTempFiles dflags

97145 cleanTempDirs dflags

146+ (,res) <$> readIORef ref

98147

99−-- Fake DynFlags which are mostly undefined, but define enough to do a

100−-- little bit.

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−

123−moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath

148+-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.

149+-- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory

150+-- @\/usr\/Test@ should be on the include path to find sibling modules.

151+moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath

124152-- The call to takeDirectory is required since DAML does not require that

125153-- the file name matches the module name in the last component.

126154-- Once that has changed we can get rid of this.

127−moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm

155+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn

128156 -- This happens for single-component modules since takeDirectory "A" == "."

129157 | modDir == "." = Just pathDir

130158 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir

131159 where

132− ms = GHC.pm_mod_summary pm

133− mod' = GHC.ms_mod ms

134160 -- A for module A.B

135161 modDir =

136162 takeDirectory $

137− fromNormalizedFilePath $ toNormalizedFilePath $

138− moduleNameSlashes $ GHC.moduleName mod'

163+ fromNormalizedFilePath $ toNormalizedFilePath' $

164+ moduleNameSlashes mn

139165

140−-- | An HscEnv with equality.

141−data HscEnvEq = HscEnvEq Unique HscEnv

166+-- | An 'HscEnv' with equality. Two values are considered equal

167+-- if they are created with the same call to 'newHscEnvEq'.

168+data HscEnvEq

169+ = HscEnvEq !Unique !HscEnv

170+ [(InstalledUnitId, DynFlags)] -- In memory components for this HscEnv

171+ -- This is only used at the moment for the import dirs in

172+ -- the DynFlags

173+ | GhcVersionMismatch { compileTime :: !Version

174+ , runTime :: !Version

175+ }

142176

177+-- | Unwrap an 'HsEnvEq'.

143178hscEnv :: HscEnvEq -> HscEnv

144−hscEnv (HscEnvEq _ x) = x

179+hscEnv = either error id . hscEnv'

180+

181+hscEnv' :: HscEnvEq -> Either String HscEnv

182+hscEnv' (HscEnvEq _ x _) = Right x

183+hscEnv' GhcVersionMismatch{..} = Left $

184+ unwords

185+ ["ghcide compiled against GHC"

186+ ,showVersion compileTime

187+ ,"but currently using"

188+ ,showVersion runTime

189+ ,". This is unsupported, ghcide must be compiled with the same GHC version as the project."

190+ ]

191+

192+deps :: HscEnvEq -> [(InstalledUnitId, DynFlags)]

193+deps (HscEnvEq _ _ u) = u

194+deps GhcVersionMismatch{} = []

145195

146−newHscEnvEq :: HscEnv -> IO HscEnvEq

147−newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e

196+-- | Wrap an 'HscEnv' into an 'HscEnvEq'.

197+newHscEnvEq :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq

198+newHscEnvEq e uids = do u <- newUnique; return $ HscEnvEq u e uids

148199

149200instance Show HscEnvEq where

150− show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)

201+ show (HscEnvEq a _ _) = "HscEnvEq " ++ show (hashUnique a)

202+ show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)

151203

152204instance Eq HscEnvEq where

153− HscEnvEq a _ == HscEnvEq b _ = a == b

205+ HscEnvEq a _ _ == HscEnvEq b _ _ = a == b

206+ GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d

207+ _ == _ = False

154208

155209instance NFData HscEnvEq where

156− rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()

210+ rnf (HscEnvEq a b c) = rnf (hashUnique a) `seq` b `seq` c `seq` ()

211+ rnf GhcVersionMismatch{} = rnf runTime

157212

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.

158224readFileUtf8 :: FilePath -> IO T.Text

159225readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f

160226

227+-- | Convert from a 'CgGuts' to a 'CoreModule'.

161228cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule

162229cgGutsToCoreModule safeMode guts modDetails = CoreModule

163230 (cg_module guts)

@@ -165,8 +232,22 @@ cgGutsToCoreModule safeMode guts modDetails = CoreModule

165232 (cg_binds guts)

166233 safeMode

167234

168−-- This is a slightly modified version of hDuplicateTo in GHC.

169−-- See the inline comment for more details.

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.

250+-- Importantly, it avoids the bug listed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2318.

170251hDuplicateTo' :: Handle -> Handle -> IO ()

171252hDuplicateTo' h1@(FileHandle path m1) h2@(FileHandle _ m2) = do

172253 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do

src/Development/IDE/GHC/WithDynFlags.hsnew file+30

@@ -0,0 +1,30 @@

1+module Development.IDE.GHC.WithDynFlags

2+( WithDynFlags

3+, evalWithDynFlags

4+) where

6+import Control.Monad.Trans.Reader (ask, ReaderT(..))

7+import GHC (DynFlags)

8+import Control.Monad.IO.Class (MonadIO)

9+import Exception (ExceptionMonad(..))

10+import Control.Monad.Trans.Class (MonadTrans(..))

11+import GhcPlugins (HasDynFlags(..))

12+

13+-- | A monad transformer implementing the 'HasDynFlags' effect

14+newtype WithDynFlags m a = WithDynFlags {withDynFlags :: ReaderT DynFlags m a}

15+ deriving (Applicative, Functor, Monad, MonadIO, MonadTrans)

16+

17+evalWithDynFlags :: DynFlags -> WithDynFlags m a -> m a

18+evalWithDynFlags dflags = flip runReaderT dflags . withDynFlags

19+

20+instance Monad m => HasDynFlags (WithDynFlags m) where

21+ getDynFlags = WithDynFlags ask

22+

23+instance ExceptionMonad m => ExceptionMonad (WithDynFlags m) where

24+ gmask f = WithDynFlags $ ReaderT $ \env ->

25+ gmask $ \restore ->

26+ let restore' = lift . restore . flip runReaderT env . withDynFlags

27+ in runReaderT (withDynFlags $ f restore') env

28+

29+ gcatch (WithDynFlags act) handle = WithDynFlags $ ReaderT $ \env ->

30+ gcatch (runReaderT act env) (flip runReaderT env . withDynFlags . handle)

src/Development/IDE/Import/DependencyInformation.hs+121−34

@@ -9,26 +9,33 @@ module Development.IDE.Import.DependencyInformation

99 , ModuleParseError(..)

1010 , TransitiveDependencies(..)

1111 , FilePathId(..)

12+ , NamedModuleDep(..)

1213

1314 , PathIdMap

1415 , emptyPathIdMap

1516 , getPathId

17+ , lookupPathToId

1618 , insertImport

1719 , pathToId

1820 , idToPath

1921 , reachableModules

20−

2122 , processDependencyInformation

2223 , transitiveDeps

24+

25+ , BootIdMap

26+ , insertBootId

2327 ) where

2428

2529import Control.DeepSeq

2630import Data.Bifunctor

2731import Data.Coerce

2832import Data.List

33+import Data.Tuple.Extra hiding (first, second)

2934import Development.IDE.GHC.Orphans()

3035import Data.Either

3136import Data.Graph

37+import Data.HashMap.Strict (HashMap)

38+import qualified Data.HashMap.Strict as HMS

3239import Data.List.NonEmpty (NonEmpty(..), nonEmpty)

3340import qualified Data.List.NonEmpty as NonEmpty

3441import Data.IntMap (IntMap)

@@ -36,16 +43,14 @@ import qualified Data.IntMap.Strict as IntMap

3643import qualified Data.IntMap.Lazy as IntMapLazy

3744import Data.IntSet (IntSet)

3845import qualified Data.IntSet as IntSet

39−import Data.Map (Map)

40−import qualified Data.Map.Strict as MS

4146import Data.Maybe

4247import Data.Set (Set)

4348import qualified Data.Set as Set

44−import Data.Tuple.Extra (fst3)

4549import GHC.Generics (Generic)

4650

4751import Development.IDE.Types.Diagnostics

4852import Development.IDE.Types.Location

53+import Development.IDE.Import.FindImports (ArtifactsLocation(..))

4954

5055import GHC

5156import Module

@@ -57,69 +62,100 @@ data ModuleImports = ModuleImports

5762 -- that module on disk (if we found it)

5863 , packageImports :: !(Set InstalledUnitId)

5964 -- ^ Transitive package dependencies unioned for all imports.

60− }

65+ } deriving Show

6166

62−-- | For processing dependency information, we need lots of maps and sets

63−-- of filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet

64−-- instead and only convert at the edges

65−-- and

67+-- | For processing dependency information, we need lots of maps and sets of

68+-- filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet

69+-- instead and only convert at the edges.

6670newtype FilePathId = FilePathId { getFilePathId :: Int }

6771 deriving (Show, NFData, Eq, Ord)

6872

73+-- | Map from 'FilePathId'

74+type FilePathIdMap = IntMap

75+

76+-- | Set of 'FilePathId's

77+type FilePathIdSet = IntSet

78+

6979data PathIdMap = PathIdMap

70− { idToPathMap :: !(IntMap NormalizedFilePath)

71− , pathToIdMap :: !(Map NormalizedFilePath FilePathId)

80+ { idToPathMap :: !(FilePathIdMap ArtifactsLocation)

81+ , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)

7282 }

7383 deriving (Show, Generic)

7484

7585instance NFData PathIdMap

7686

7787emptyPathIdMap :: PathIdMap

78−emptyPathIdMap = PathIdMap IntMap.empty MS.empty

88+emptyPathIdMap = PathIdMap IntMap.empty HMS.empty

7989

80−getPathId :: NormalizedFilePath -> PathIdMap -> (FilePathId, PathIdMap)

90+getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap)

8191getPathId path m@PathIdMap{..} =

82− case MS.lookup path pathToIdMap of

92+ case HMS.lookup (artifactFilePath path) pathToIdMap of

8393 Nothing ->

84− let !newId = FilePathId $ MS.size pathToIdMap

94+ let !newId = FilePathId $ HMS.size pathToIdMap

8595 in (newId, insertPathId path newId m)

8696 Just id -> (id, m)

8797

88−insertPathId :: NormalizedFilePath -> FilePathId -> PathIdMap -> PathIdMap

98+insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap

8999insertPathId path id PathIdMap{..} =

90− PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (MS.insert path id pathToIdMap)

100+ PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert (artifactFilePath path) id pathToIdMap)

91101

92102insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation

93103insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }

94104

95105pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId

96−pathToId PathIdMap{pathToIdMap} path = pathToIdMap MS.! path

106+pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path

107+

108+lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId

109+lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap

97110

98111idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath

99−idToPath PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id

112+idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId

113+

114+idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation

115+idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id

116+

117+type BootIdMap = FilePathIdMap FilePathId

118+

119+insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap

120+insertBootId k = IntMap.insert (getFilePathId k)

100121

101122-- | Unprocessed results that we find by following imports recursively.

102123data RawDependencyInformation = RawDependencyInformation

103− { rawImports :: !(IntMap (Either ModuleParseError ModuleImports))

124+ { rawImports :: !(FilePathIdMap (Either ModuleParseError ModuleImports))

104125 , rawPathIdMap :: !PathIdMap

105− }

106−

107−pkgDependencies :: RawDependencyInformation -> IntMap (Set InstalledUnitId)

126+ -- The rawBootMap maps the FilePathId of a hs-boot file to its

127+ -- corresponding hs file. It is used when topologically sorting as we

128+ -- need to add edges between .hs-boot and .hs so that the .hs files

129+ -- appear later in the sort.

130+ , rawBootMap :: !BootIdMap

131+ } deriving Show

132+

133+pkgDependencies :: RawDependencyInformation -> FilePathIdMap (Set InstalledUnitId)

108134pkgDependencies RawDependencyInformation{..} =

109135 IntMap.map (either (const Set.empty) packageImports) rawImports

110136

111137data DependencyInformation =

112138 DependencyInformation

113− { depErrorNodes :: !(IntMap (NonEmpty NodeError))

139+ { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError))

114140 -- ^ Nodes that cannot be processed correctly.

115− , depModuleDeps :: !(IntMap IntSet)

141+ , depModuleNames :: !(FilePathIdMap ShowableModuleName)

142+ , depModuleDeps :: !(FilePathIdMap FilePathIdSet)

116143 -- ^ For a non-error node, this contains the set of module immediate dependencies

117144 -- in the same package.

118− , depPkgDeps :: !(IntMap (Set InstalledUnitId))

145+ , depPkgDeps :: !(FilePathIdMap (Set InstalledUnitId))

119146 -- ^ For a non-error node, this contains the set of immediate pkg deps.

120147 , depPathIdMap :: !PathIdMap

148+ -- ^ Map from FilePath to FilePathId

149+ , depBootMap :: !BootIdMap

150+ -- ^ Map from hs-boot file to the corresponding hs file

121151 } deriving (Show, Generic)

122152

153+newtype ShowableModuleName =

154+ ShowableModuleName {showableModuleName :: ModuleName}

155+ deriving NFData

156+

157+instance Show ShowableModuleName where show = moduleNameString . showableModuleName

158+

123159reachableModules :: DependencyInformation -> [NormalizedFilePath]

124160reachableModules DependencyInformation{..} =

125161 map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps

@@ -186,23 +222,32 @@ processDependencyInformation rawDepInfo@RawDependencyInformation{..} =

186222 DependencyInformation

187223 { depErrorNodes = IntMap.fromList errorNodes

188224 , depModuleDeps = moduleDeps

225+ , depModuleNames = IntMap.fromList $ coerce moduleNames

189226 , depPkgDeps = pkgDependencies rawDepInfo

190227 , depPathIdMap = rawPathIdMap

228+ , depBootMap = rawBootMap

191229 }

192230 where resultGraph = buildResultGraph rawImports

193231 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph

232+ moduleNames :: [(FilePathId, ModuleName)]

233+ moduleNames =

234+ [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports]

194235 successEdges :: [(FilePathId, FilePathId, [FilePathId])]

195236 successEdges =

196− map (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports)) successNodes

237+ map

238+ (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports))

239+ successNodes

197240 moduleDeps =

198− IntMap.fromList $ map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs)) successEdges

241+ IntMap.fromList $

242+ map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs))

243+ successEdges

199244

200245-- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:

201246-- 1. Mark each node that is part of an import cycle as an error node.

202247-- 2. Mark each node that has a parse error as an error node.

203248-- 3. Mark each node whose immediate children could not be located as an error.

204249-- 4. Recursively propagate errors to parents if they are not already error nodes.

205−buildResultGraph :: IntMap (Either ModuleParseError ModuleImports) -> IntMap NodeResult

250+buildResultGraph :: FilePathIdMap (Either ModuleParseError ModuleImports) -> FilePathIdMap NodeResult

206251buildResultGraph g = propagatedErrors

207252 where

208253 sccs = stronglyConnComp (graphEdges g)

@@ -249,7 +294,7 @@ buildResultGraph g = propagatedErrors

249294 Right ModuleImports{moduleImports} ->

250295 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports

251296

252−graphEdges :: IntMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]

297+graphEdges :: FilePathIdMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]

253298graphEdges g =

254299 map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g

255300 where deps :: Either e ModuleImports -> [FilePathId]

@@ -261,29 +306,71 @@ partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest

261306partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest

262307partitionSCC [] = ([], [])

263308

309+

264310transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies

265311transitiveDeps DependencyInformation{..} file = do

266312 let !fileId = pathToId depPathIdMap file

267313 reachableVs <-

314+ -- Delete the starting node

268315 IntSet.delete (getFilePathId fileId) .

269316 IntSet.fromList . map (fst3 . fromVertex) .

270317 reachable g <$> toVertex (getFilePathId fileId)

271− let transitiveModuleDepIds = filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs

318+ let transitiveModuleDepIds =

319+ filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs

272320 let transitivePkgDeps =

273321 Set.toList $ Set.unions $

274322 map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $

275323 getFilePathId fileId : transitiveModuleDepIds

276− let transitiveModuleDeps = map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds

324+ let transitiveModuleDeps =

325+ map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds

326+ let transitiveNamedModuleDeps =

327+ [ NamedModuleDep (idToPath depPathIdMap (FilePathId fid)) mn artifactModLocation

328+ | (fid, ShowableModuleName mn) <- IntMap.toList depModuleNames

329+ , let ArtifactsLocation{artifactModLocation} = idToPathMap depPathIdMap IntMap.! fid

330+ ]

277331 pure TransitiveDependencies {..}

278− where (g, fromVertex, toVertex) = graphFromEdges (map (\(f, fs) -> (f, f, IntSet.toList fs)) $ IntMap.toList depModuleDeps)

279− vs = topSort g

332+ where

333+ (g, fromVertex, toVertex) = graphFromEdges edges

334+ edges = map (\(f, fs) -> (f, f, IntSet.toList fs ++ boot_edge f)) $ IntMap.toList depModuleDeps

335+

336+ -- Need to add an edge between the .hs and .hs-boot file if it exists

337+ -- so the .hs file gets loaded after the .hs-boot file and the right

338+ -- stuff ends up in the HPT. If you don't have this check then GHC will

339+ -- fail to work with ghcide.

340+ boot_edge f = [getFilePathId f' | Just f' <- [IntMap.lookup f depBootMap]]

341+

342+ vs = topSort g

280343

281344data TransitiveDependencies = TransitiveDependencies

282345 { transitiveModuleDeps :: [NormalizedFilePath]

283346 -- ^ Transitive module dependencies in topological order.

284347 -- The module itself is not included.

348+ , transitiveNamedModuleDeps :: [NamedModuleDep]

349+ -- ^ Transitive module dependencies in topological order.

350+ -- The module itself is not included.

285351 , transitivePkgDeps :: [InstalledUnitId]

286352 -- ^ Transitive pkg dependencies in unspecified order.

287353 } deriving (Eq, Show, Generic)

288354

289355instance NFData TransitiveDependencies

356+

357+data NamedModuleDep = NamedModuleDep {

358+ nmdFilePath :: !NormalizedFilePath,

359+ nmdModuleName :: !ModuleName,

360+ nmdModLocation :: !ModLocation

361+ }

362+ deriving Generic

363+

364+instance Eq NamedModuleDep where

365+ a == b = nmdFilePath a == nmdFilePath b

366+

367+instance NFData NamedModuleDep where

368+ rnf NamedModuleDep{..} =

369+ rnf nmdFilePath `seq`

370+ rnf nmdModuleName `seq`

371+ -- 'ModLocation' lacks an 'NFData' instance

372+ rwhnf nmdModLocation

373+

374+instance Show NamedModuleDep where

375+ show NamedModuleDep{..} = show nmdFilePath

376+

src/Development/IDE/Import/FindImports.hs+63−17

@@ -7,16 +7,19 @@

77module Development.IDE.Import.FindImports

88 ( locateModule

99 , Import(..)

10+ , ArtifactsLocation(..)

11+ , modSummaryToArtifactsLocation

12+ , isBootLocation

13+ , mkImportDirs

1014 ) where

1115

1216import Development.IDE.GHC.Error as ErrUtils

1317import Development.IDE.GHC.Orphans()

1418import Development.IDE.Types.Diagnostics

1519import Development.IDE.Types.Location

20+import Development.IDE.GHC.Compat

1621-- GHC imports

17−import DynFlags

1822import FastString

19−import GHC

2023import qualified Module as M

2124import Packages

2225import Outputable (showSDoc, ppr, pprPanic)

@@ -27,64 +30,107 @@ import Control.DeepSeq

2730import Control.Monad.Extra

2831import Control.Monad.IO.Class

2932import System.FilePath

33+import DriverPhases

34+import Data.Maybe

3035

3136data Import

32− = FileImport !NormalizedFilePath

37+ = FileImport !ArtifactsLocation

3338 | PackageImport !M.InstalledUnitId

3439 deriving (Show)

3540

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+

3654instance NFData Import where

3755 rnf (FileImport x) = rnf x

3856 rnf (PackageImport x) = rnf x

3957

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+

4064

4165-- | locate a module in the file system. Where we go from *daml to Haskell

4266locateModuleFile :: MonadIO m

43− => DynFlags

67+ => [[FilePath]]

4468 -> [String]

4569 -> (NormalizedFilePath -> m Bool)

4670 -> Bool

4771 -> ModuleName

4872 -> m (Maybe NormalizedFilePath)

49−locateModuleFile dflags exts doesExist isSource modName = do

50− let candidates =

51− [ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)

52− | prefix <- importPaths dflags, ext <- exts]

53− findM doesExist candidates

73+locateModuleFile import_dirss exts doesExist isSource modName = do

74+ let candidates import_dirs =

75+ [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)

76+ | prefix <- import_dirs , ext <- exts]

77+ findM doesExist (concatMap candidates import_dirss)

5478 where

5579 maybeBoot ext

5680 | isSource = ext ++ "-boot"

5781 | otherwise = ext

5882

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+

5990-- | locate a module in either the file system or the package database. Where we go from *daml to

6091-- Haskell

6192locateModule

6293 :: MonadIO m

6394 => DynFlags

95+ -> [(M.InstalledUnitId, DynFlags)] -- Sets import directories to look in

6496 -> [String]

6597 -> (NormalizedFilePath -> m Bool)

6698 -> Located ModuleName

6799 -> Maybe FastString

68100 -> Bool

69101 -> m (Either [FileDiagnostic] Import)

70−locateModule dflags exts doesExist modName mbPkgName isSource = do

102+locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do

71103 case mbPkgName of

72104 -- "this" means that we should only look in the current package

73105 Just "this" -> do

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

106+ lookupLocal [importPaths dflags]

78107 -- if a package name is given we only go look for a package

79− Just _pkgName -> lookupInPackageDB dflags

108+ Just pkgName

109+ | Just dirs <- lookup (PackageName pkgName) import_paths

110+ -> lookupLocal [dirs]

111+ | otherwise -> lookupInPackageDB dflags

80112 Nothing -> do

81113 -- first try to find the module as a file. If we can't find it try to find it in the package

82114 -- database.

83− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName

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

84119 case mbFile of

85120 Nothing -> lookupInPackageDB dflags

86− Just file -> return $ Right $ FileImport file

121+ Just file -> toModLocation file

87122 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+

88134 lookupInPackageDB dfs =

89135 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of

90136 LookupFound _m pkgConfig -> return $ Right $ PackageImport $ unitId pkgConfig

src/Development/IDE/LSP/CodeAction.hsdeleted−305

@@ -1,305 +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.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−

34−-- | Generate code actions.

35−codeAction

36− :: LSP.LspFuncs ()

37− -> IdeState

38− -> CodeActionParams

39− -> IO (List CAResult)

40−codeAction lsp _ CodeActionParams{_textDocument=TextDocumentIdentifier uri,_context=CodeActionContext{_diagnostics=List xs}} = do

41− -- disable logging as its quite verbose

42− -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg

43− contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri

44− let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents

45− pure $ List

46− [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing

47− | x <- xs, (title, tedit) <- suggestAction text x

48− , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

49− ]

50−

51−-- | Generate code lenses.

52−codeLens

53− :: LSP.LspFuncs ()

54− -> IdeState

55− -> CodeLensParams

56− -> IO (List CodeLens)

57−codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do

58− case uriToFilePath' uri of

59− Just (toNormalizedFilePath -> filePath) -> do

60− _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath

61− diag <- getDiagnostics ideState

62− hDiag <- getHiddenDiagnostics ideState

63− pure $ List

64− [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing

65− | (dFile, _, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag ++ hDiag

66− , dFile == filePath

67− , (title, tedit) <- suggestSignature False dDiag

68− , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

69− ]

70− Nothing -> pure $ List []

71−

72−-- | Execute the "typesignature.add" command.

73−executeAddSignatureCommand

74− :: LSP.LspFuncs ()

75− -> IdeState

76− -> ExecuteCommandParams

77− -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

78−executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}

79− | _command == "typesignature.add"

80− , Just (List [edit]) <- _arguments

81− , Success wedit <- fromJSON edit

82− = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))

83− | otherwise

84− = return (Null, Nothing)

85−

86−suggestAction :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

87−suggestAction contents diag@Diagnostic{_range=_range@Range{..},..}

88−

89−-- File.hs:16:1: warning:

90−-- The import of `Data.List' is redundant

91−-- except perhaps to import instances from `Data.List'

92−-- To import instances alone, use: import Data.List()

93− | "The import of " `T.isInfixOf` _message

94− || "The qualified import of " `T.isInfixOf` _message

95− , " is redundant" `T.isInfixOf` _message

96− = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]

97−

98−-- File.hs:52:41: error:

99−-- * Variable not in scope:

100−-- suggestAcion :: Maybe T.Text -> Range -> Range

101−-- * Perhaps you meant ‘suggestAction’ (line 83)

102−-- File.hs:94:37: error:

103−-- Not in scope: ‘T.isPrfixOf’

104−-- Perhaps you meant one of these:

105−-- ‘T.isPrefixOf’ (imported from Data.Text),

106−-- ‘T.isInfixOf’ (imported from Data.Text),

107−-- ‘T.isSuffixOf’ (imported from Data.Text)

108−-- Module ‘Data.Text’ does not export ‘isPrfixOf’.

109− | renameSuggestions@(_:_) <- extractRenamableTerms _message

110− = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]

111−

112−-- Foo.hs:3:8: error:

113−-- * Found type wildcard `_' standing for `p -> p1 -> p'

114−

115− | "Found type wildcard" `T.isInfixOf` _message

116− , " standing for " `T.isInfixOf` _message

117− , typeSignature <- extractWildCardTypeSignature _message

118− = [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]

119−

120−-- File.hs:22:8: error:

121−-- Illegal lambda-case (use -XLambdaCase)

122−-- File.hs:22:6: error:

123−-- Illegal view pattern: x -> foo

124−-- Use ViewPatterns to enable view patterns

125−-- File.hs:26:8: error:

126−-- Illegal `..' in record pattern

127−-- Use RecordWildCards to permit this

128−-- File.hs:53:28: error:

129−-- Illegal tuple section: use TupleSections

130−-- File.hs:238:29: error:

131−-- * Can't make a derived instance of `Data FSATrace':

132−-- You need DeriveDataTypeable to derive an instance for this class

133−-- * In the data declaration for `FSATrace'

134−-- C:\Neil\shake\src\Development\Shake\Command.hs:515:31: error:

135−-- * Illegal equational constraint a ~ ()

136−-- (Use GADTs or TypeFamilies to permit this)

137−-- * In the context: a ~ ()

138−-- While checking an instance declaration

139−-- In the instance declaration for `Unit (m a)'

140− | exts@(_:_) <- filter (`Set.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message

141− = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts]

142−

143−-- src/Development/IDE/Core/Compile.hs:58:1: error:

144−-- Could not find module ‘Data.Cha’

145−-- Perhaps you meant Data.Char (from base-4.12.0.0)

146− | "Could not find module" `T.isInfixOf` _message

147− , "Perhaps you meant" `T.isInfixOf` _message = let

148− findSuggestedModules = map (head . T.words) . drop 2 . T.lines

149− proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])

150− in map proposeModule $ nubOrd $ findSuggestedModules _message

151−

152−-- ...Development/IDE/LSP/CodeAction.hs:103:9: warning:

153−-- * Found hole: _ :: Int -> String

154−-- * In the expression: _

155−-- In the expression: _ a

156−-- In an equation for ‘foo’: foo a = _ a

157−-- * Relevant bindings include

158−-- a :: Int

159−-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:5)

160−-- foo :: Int -> String

161−-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)

162−-- Valid hole fits include

163−-- foo :: Int -> String

164−-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)

165−-- show :: forall a. Show a => a -> String

166−-- with show @Int

167−-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37

168−-- (and originally defined in ‘GHC.Show’))

169−-- mempty :: forall a. Monoid a => a

170−-- with mempty @(Int -> String)

171−-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37

172−-- (and originally defined in ‘GHC.Base’)) (lsp-ui)

173−

174− | topOfHoleFitsMarker `T.isInfixOf` _message = let

175− findSuggestedHoleFits :: T.Text -> [T.Text]

176− findSuggestedHoleFits = extractFitNames . selectLinesWithFits . dropPreceding . T.lines

177− proposeHoleFit name = ("replace hole `" <> holeName <> "` with " <> name, [TextEdit _range name])

178− holeName = T.strip $ last $ T.splitOn ":" $ head . T.splitOn "::" $ head $ filter ("Found hole" `T.isInfixOf`) $ T.lines _message

179− dropPreceding = dropWhile (not . (topOfHoleFitsMarker `T.isInfixOf`))

180− selectLinesWithFits = filter ("::" `T.isInfixOf`)

181− extractFitNames = map (T.strip . head . T.splitOn " :: ")

182− in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message

183−

184− | tlb@[_] <- suggestSignature True diag = tlb

185−

186−suggestAction _ _ = []

187−

188−suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]

189−suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}

190− | "Top-level binding with no type signature" `T.isInfixOf` _message = let

191− filterNewlines = T.concat . T.lines

192− unifySpaces = T.unwords . T.words

193− signature = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message

194− startOfLine = Position (_line _start) 0

195− beforeLine = Range startOfLine startOfLine

196− title = if isQuickFix then "add signature: " <> signature else signature

197− action = TextEdit beforeLine $ signature <> "\n"

198− in [(title, [action])]

199−suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}

200− | "Polymorphic local binding with no type signature" `T.isInfixOf` _message = let

201− filterNewlines = T.concat . T.lines

202− unifySpaces = T.unwords . T.words

203− signature = removeInitialForAll

204− $ T.takeWhile (\x -> x/='*' && x/='•')

205− $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message

206− startOfLine = Position (_line _start) (_character _start)

207− beforeLine = Range startOfLine startOfLine

208− title = if isQuickFix then "add signature: " <> signature else signature

209− action = TextEdit beforeLine $ signature <> "\n" <> T.replicate (_character _start) " "

210− in [(title, [action])]

211− where removeInitialForAll :: T.Text -> T.Text

212− removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))

213− | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))

214− | otherwise = nm <> ty

215−suggestSignature _ _ = []

216−

217−topOfHoleFitsMarker :: T.Text

218−topOfHoleFitsMarker =

219−#if MIN_GHC_API_VERSION(8,6,0)

220− "Valid hole fits include"

221−#else

222− "Valid substitutions include"

223−#endif

224−

225−mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit

226−mkRenameEdit contents range name =

227− if fromMaybe False maybeIsInfixFunction

228− then TextEdit range ("`" <> name <> "`")

229− else TextEdit range name

230− where

231− maybeIsInfixFunction = do

232− curr <- textInRange range <$> contents

233− pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr

234−

235−extractWildCardTypeSignature :: T.Text -> T.Text

236−extractWildCardTypeSignature =

237− -- inferring when parens are actually needed around the type signature would

238− -- require understanding both the precedence of the context of the _ and of

239− -- the signature itself. Inserting them unconditionally is ugly but safe.

240− ("(" `T.append`) . (`T.append` ")") .

241− T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') .

242− snd . T.breakOnEnd "standing for "

243−

244−extractRenamableTerms :: T.Text -> [T.Text]

245−extractRenamableTerms msg

246− -- Account for both "Variable not in scope" and "Not in scope"

247− | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg

248− | otherwise = []

249− where

250− extractSuggestions = map getEnclosed

251− . concatMap singleSuggestions

252− . filter isKnownSymbol

253− . T.lines

254− singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited

255− isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t

256− getEnclosed = T.dropWhile (== '‘')

257− . T.dropWhileEnd (== '’')

258− . T.dropAround (\c -> c /= '‘' && c /= '’')

259−

260−-- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace

261−-- between the end of the range and the next newline), extend the range to take up the whole line.

262−extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range

263−extendToWholeLineIfPossible contents range@Range{..} =

264− let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents

265− extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line

266− in if extend then Range _start (Position (_line _end + 1) 0) else range

267−

268−-- | All the GHC extensions

269−ghcExtensions :: Set.HashSet T.Text

270−ghcExtensions = Set.fromList $ map (T.pack . show) ghcEnumerateExtensions

271−

272−splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)

273−splitTextAtPosition (Position row col) x

274− | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x

275− , (preCol, postCol) <- T.splitAt col mid

276− = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)

277− | otherwise = (x, T.empty)

278−

279−textInRange :: Range -> T.Text -> T.Text

280−textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =

281− case compare startRow endRow of

282− LT ->

283− let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine

284− (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of

285− [] -> ("", [])

286− firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)

287− maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines

288− in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)

289− EQ ->

290− let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)

291− in T.take (endCol - startCol) (T.drop startCol line)

292− GT -> ""

293− where

294− linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)

295−

296−setHandlersCodeAction :: PartialHandlers

297−setHandlersCodeAction = PartialHandlers $ \WithMessage{..} x -> return x{

298− LSP.codeActionHandler = withResponse RspCodeAction codeAction

299− }

300−

301−setHandlersCodeLens :: PartialHandlers

302−setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{

303− LSP.codeLensHandler = withResponse RspCodeLens codeLens,

304− LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand

305− }

src/Development/IDE/LSP/HoverDefinition.hs+9−6

@@ -6,6 +6,9 @@

66module Development.IDE.LSP.HoverDefinition

77 ( setHandlersHover

88 , setHandlersDefinition

9+ -- * For haskell-language-server

10+ , hover

11+ , gotoDefinition

912 ) where

1013

1114import Development.IDE.Core.Rules

@@ -20,8 +23,8 @@ import Language.Haskell.LSP.Types

2023

2124import qualified Data.Text as T

2225

23−gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO LocationResponseParams

24−hover :: IdeState -> TextDocumentPositionParams -> IO (Maybe Hover)

26+gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)

27+hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))

2528gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc

2629hover = request "Hover" getAtPoint Nothing foundHover

2730

@@ -29,7 +32,7 @@ foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover

2932foundHover (mbRange, contents) =

3033 Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange

3134

32−setHandlersDefinition, setHandlersHover :: PartialHandlers

35+setHandlersDefinition, setHandlersHover :: PartialHandlers c

3336setHandlersDefinition = PartialHandlers $ \WithMessage{..} x ->

3437 return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition}

3538setHandlersHover = PartialHandlers $ \WithMessage{..} x ->

@@ -43,16 +46,16 @@ request

4346 -> (a -> b)

4447 -> IdeState

4548 -> TextDocumentPositionParams

46− -> IO b

49+ -> IO (Either ResponseError b)

4750request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do

4851 mbResult <- case uriToFilePath' uri of

4952 Just path -> logAndRunRequest label getResults ide pos path

5053 Nothing -> pure Nothing

51− pure $ maybe notFound found mbResult

54+ pure $ Right $ maybe notFound found mbResult

5255

5356logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b

5457logAndRunRequest label getResults ide pos path = do

55− let filePath = toNormalizedFilePath path

58+ let filePath = toNormalizedFilePath' path

5659 logInfo (ideLogger ide) $

5760 label <> " request at position " <> T.pack (showPosition pos) <>

5861 " in file: " <> T.pack path

src/Development/IDE/LSP/LanguageServer.hs+56−29

@@ -28,21 +28,25 @@ import GHC.IO.Handle (hDuplicate)

2828import System.IO

2929import Control.Monad.Extra

3030

31+import Development.IDE.Core.IdeConfiguration

32+import Development.IDE.Core.Shake

3133import Development.IDE.LSP.HoverDefinition

32−import Development.IDE.LSP.CodeAction

3334import Development.IDE.LSP.Notifications

34−import Development.IDE.Core.Service

35+import Development.IDE.LSP.Outline

3536import Development.IDE.Types.Logger

3637import Development.IDE.Core.FileStore

3738import Language.Haskell.LSP.Core (LspFuncs(..))

3839import Language.Haskell.LSP.Messages

3940

4041runLanguageServer

41− :: LSP.Options

42− -> PartialHandlers

42+ :: forall config. (Show config)

43+ => LSP.Options

44+ -> PartialHandlers config

45+ -> (InitializeRequest -> Either T.Text config)

46+ -> (DidChangeConfigurationNotification -> Either T.Text config)

4347 -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)

4448 -> IO ()

45−runLanguageServer options userHandlers getIdeState = do

49+runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do

4650 -- Move stdout to another file descriptor and duplicate stderr

4751 -- to stdout. This guards against stray prints from corrupting the JSON-RPC

4852 -- message stream.

@@ -59,7 +63,7 @@ runLanguageServer options userHandlers getIdeState = do

5963

6064 -- Send everything over a channel, since you need to wait until after initialise before

6165 -- LspFuncs is available

62− clientMsgChan :: Chan Message <- newChan

66+ clientMsgChan :: Chan (Message config) <- newChan

6367

6468 -- These barriers are signaled when the threads reading from these chans exit.

6569 -- This should not happen but if it does, we will make sure that the whole server

@@ -78,6 +82,7 @@ runLanguageServer options userHandlers getIdeState = do

7882 let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do

7983 atomically $ modifyTVar pendingRequests (Set.insert _id)

8084 writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f

85+ let withInitialize f = Just $ \r -> writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x)

8186 let cancelRequest reqId = atomically $ do

8287 queued <- readTVar pendingRequests

8388 -- We want to avoid that the list of cancelled requests

@@ -94,19 +99,20 @@ runLanguageServer options userHandlers getIdeState = do

9499 cancelled <- readTVar cancelledRequests

95100 unless (reqId `Set.member` cancelled) retry

96101 let PartialHandlers parts =

102+ initializeRequestHandler <>

97103 setHandlersIgnore <> -- least important

98104 setHandlersDefinition <> setHandlersHover <>

99− setHandlersCodeAction <> setHandlersCodeLens <> -- useful features someone may override

105+ setHandlersOutline <>

100106 userHandlers <>

101107 setHandlersNotifications <> -- absolutely critical, join them with user notifications

102108 cancelHandler cancelRequest

103109 -- Cancel requests are special since they need to be handled

104110 -- out of order to be useful. Existing handlers are run afterwards.

105− handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def

111+ handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def

106112

107113 let initializeCallbacks = LSP.InitializeCallbacks

108− { LSP.onInitialConfiguration = const $ Right ()

109− , LSP.onConfigurationChange = const $ Right ()

114+ { LSP.onInitialConfiguration = onInitialConfig

115+ , LSP.onConfigurationChange = onConfigChange

110116 , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan

111117 }

112118

@@ -121,9 +127,11 @@ runLanguageServer options userHandlers getIdeState = do

121127 , void $ waitBarrier clientMsgBarrier

122128 ]

123129 where

124− handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs () -> IO (Maybe err)

130+ handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan (Message config) -> LSP.LspFuncs config -> IO (Maybe err)

125131 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do

132+

126133 ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities

134+

127135 _ <- flip forkFinally (const exitClientMsg) $ forever $ do

128136 msg <- readChan clientMsgChan

129137 case msg of

@@ -134,17 +142,25 @@ runLanguageServer options userHandlers getIdeState = do

134142 "Message: " ++ show x ++ "\n" ++

135143 "Exception: " ++ show e

136144 Response x@RequestMessage{_id, _params} wrap act ->

137− checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

138− \res -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing

145+ checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

146+ \case

147+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)

148+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)

139149 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->

140150 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

141151 \(res, newReq) -> do

142− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing

143− case newReq of

144− Nothing -> return ()

145− Just (rm, newReqParams) -> do

152+ case res of

153+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)

154+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)

155+ whenJust newReq $ \(rm, newReqParams) -> do

146156 reqId <- getNextReqId

147157 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

148164 pure Nothing

149165

150166 checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =

@@ -159,28 +175,39 @@ runLanguageServer options userHandlers getIdeState = do

159175 Left () -> do

160176 logDebug (ideLogger ide) $ T.pack $

161177 "Cancelled request " <> show _id

162− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $

163− Just $ ResponseError RequestCancelled "" Nothing

178+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left

179+ $ ResponseError RequestCancelled "" Nothing

164180 Right res -> k res

165181 ) $ \(e :: SomeException) -> do

166182 logError (ideLogger ide) $ T.pack $

167183 "Unexpected exception on request, please report!\n" ++

168184 "Message: " ++ show msg ++ "\n" ++

169185 "Exception: " ++ show e

170− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $

171− Just $ ResponseError InternalError (T.pack $ show e) Nothing

186+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left

187+ $ ResponseError InternalError (T.pack $ show e) Nothing

172188

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)

173200

174201-- | Things that get sent to us, but we don't deal with.

175202-- Set them to avoid a warning in VS Code output.

176−setHandlersIgnore :: PartialHandlers

203+setHandlersIgnore :: PartialHandlers config

177204setHandlersIgnore = PartialHandlers $ \_ x -> return x

178205 {LSP.initializedHandler = none

179206 ,LSP.responseHandler = none

180207 }

181208 where none = Just $ const $ return ()

182209

183−cancelHandler :: (LspId -> IO ()) -> PartialHandlers

210+cancelHandler :: (LspId -> IO ()) -> PartialHandlers config

184211cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x

185212 {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do

186213 cancelRequest _id

@@ -190,18 +217,18 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x

190217

191218-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety

192219-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)

193−data Message

194− = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO resp)

220+data Message c

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))

195222 -- | Used for cases in which we need to send not only a response,

196223 -- but also an additional request to the client.

197224 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.

198− | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams)))

199− | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ())

200−

225+ | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))

226+ | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())

227+ -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler.

228+ | InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())

201229

202230modifyOptions :: LSP.Options -> LSP.Options

203231modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS

204− , LSP.executeCommandCommands = Just ["typesignature.add"]

205232 }

206233 where

207234 tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}

src/Development/IDE/LSP/Notifications.hs+39−13

@@ -2,32 +2,37 @@

22-- SPDX-License-Identifier: Apache-2.0

44{-# LANGUAGE DuplicateRecordFields #-}

5−{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE RankNTypes #-}

77module Development.IDE.LSP.Notifications

88 ( setHandlersNotifications

99 ) where

1010

11−import Language.Haskell.LSP.Types

1211import Development.IDE.LSP.Server

13−import qualified Language.Haskell.LSP.Core as LSP

14−import qualified Language.Haskell.LSP.Types as LSP

12+import qualified Language.Haskell.LSP.Core as LSP

13+import Language.Haskell.LSP.Types

14+import qualified Language.Haskell.LSP.Types as LSP

1515

16−import Development.IDE.Types.Logger

17−import Development.IDE.Core.Service

18−import Development.IDE.Types.Location

16+import Development.IDE.Core.IdeConfiguration

17+import Development.IDE.Core.Service

18+import Development.IDE.Types.Location

19+import Development.IDE.Types.Logger

1920

20−import Control.Monad.Extra

21−import qualified Data.Set as S

21+import Control.Monad.Extra

22+import Data.Foldable as F

23+import Data.Maybe

24+import qualified Data.HashSet as S

25+import qualified Data.Text as Text

2226

23−import Development.IDE.Core.FileStore

24−import Development.IDE.Core.OfInterest

27+import Development.IDE.Core.FileStore (setSomethingModified)

28+import Development.IDE.Core.FileExists (modifyFileExists)

29+import Development.IDE.Core.OfInterest

2530

2631

2732whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()

28−whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath

33+whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'

2934

30−setHandlersNotifications :: PartialHandlers

35+setHandlersNotifications :: PartialHandlers c

3136setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x

3237 {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $

3338 \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do

@@ -52,4 +57,25 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x

5257 whenUriFile _uri $ \file -> do

5358 modifyFilesOfInterest ide (S.delete file)

5459 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))

5581 }

src/Development/IDE/LSP/Outline.hsnew file+234

@@ -0,0 +1,234 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DuplicateRecordFields #-}

3+#include "ghc-api-version.h"

5+module Development.IDE.LSP.Outline

6+ ( setHandlersOutline

7+ -- * For haskell-language-server

8+ , moduleOutline

9+ )

10+where

11+

12+import qualified Language.Haskell.LSP.Core as LSP

13+import Language.Haskell.LSP.Messages

14+import Language.Haskell.LSP.Types

15+import Data.Functor

16+import Data.Generics

17+import Data.Maybe

18+import Data.Text ( Text

19+ , pack

20+ )

21+import qualified Data.Text as T

22+import Development.IDE.Core.Rules

23+import Development.IDE.Core.Shake

24+import Development.IDE.GHC.Compat

25+import Development.IDE.GHC.Error ( srcSpanToRange )

26+import Development.IDE.LSP.Server

27+import Development.IDE.Types.Location

28+import Outputable ( Outputable

29+ , ppr

30+ , showSDocUnsafe

31+ )

32+

33+setHandlersOutline :: PartialHandlers c

34+setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x

35+ { LSP.documentSymbolHandler = withResponse RspDocumentSymbols moduleOutline

36+ }

37+

38+moduleOutline

39+ :: LSP.LspFuncs c -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)

40+moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }

41+ = case uriToFilePath uri of

42+ Just (toNormalizedFilePath' -> fp) -> do

43+ mb_decls <- runAction ideState $ use GetParsedModule fp

44+ pure $ Right $ case mb_decls of

45+ Nothing -> DSDocumentSymbols (List [])

46+ Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } }

47+ -> let

48+ declSymbols = mapMaybe documentSymbolForDecl hsmodDecls

49+ moduleSymbol = hsmodName <&> \(L l m) ->

50+ (defDocumentSymbol l :: DocumentSymbol)

51+ { _name = pprText m

52+ , _kind = SkFile

53+ , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0

54+ }

55+ importSymbols = maybe [] pure $

56+ documentSymbolForImportSummary

57+ (mapMaybe documentSymbolForImport hsmodImports)

58+ allSymbols = case moduleSymbol of

59+ Nothing -> importSymbols <> declSymbols

60+ Just x ->

61+ [ x { _children = Just (List (importSymbols <> declSymbols))

62+ }

63+ ]

64+ in

65+ DSDocumentSymbols (List allSymbols)

66+

67+

68+ Nothing -> pure $ Right $ DSDocumentSymbols (List [])

69+

70+documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol

71+documentSymbolForDecl (L l (TyClD FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))

72+ = Just (defDocumentSymbol l :: DocumentSymbol)

73+ { _name = showRdrName n

74+ <> (case pprText fdTyVars of

75+ "" -> ""

76+ t -> " " <> t

77+ )

78+ , _detail = Just $ pprText fdInfo

79+ , _kind = SkClass

80+ }

81+documentSymbolForDecl (L l (TyClD ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars }))

82+ = Just (defDocumentSymbol l :: DocumentSymbol)

83+ { _name = showRdrName name

84+ <> (case pprText tcdTyVars of

85+ "" -> ""

86+ t -> " " <> t

87+ )

88+ , _kind = SkClass

89+ , _detail = Just "class"

90+ , _children =

91+ Just $ List

92+ [ (defDocumentSymbol l :: DocumentSymbol)

93+ { _name = showRdrName n

94+ , _kind = SkMethod

95+ , _selectionRange = srcSpanToRange l'

96+ }

97+ | L l (ClassOpSig False names _) <- tcdSigs

98+ , L l' n <- names

99+ ]

100+ }

101+documentSymbolForDecl (L l (TyClD DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } }))

102+ = Just (defDocumentSymbol l :: DocumentSymbol)

103+ { _name = showRdrName name

104+ , _kind = SkStruct

105+ , _children =

106+ Just $ List

107+ [ (defDocumentSymbol l :: DocumentSymbol)

108+ { _name = showRdrName n

109+ , _kind = SkConstructor

110+ , _selectionRange = srcSpanToRange l'

111+ , _children = conArgRecordFields (getConArgs x)

112+ }

113+ | L l x <- dd_cons

114+ , L l' n <- getConNames x

115+ ]

116+ }

117+ where

118+ -- | Extract the record fields of a constructor

119+ conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List

120+ [ (defDocumentSymbol l :: DocumentSymbol)

121+ { _name = showRdrName n

122+ , _kind = SkField

123+ }

124+ | L _ cdf <- lcdfs

125+ , L l n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf

126+ ]

127+ conArgRecordFields _ = Nothing

128+documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just

129+ (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n

130+ , _kind = SkTypeParameter

131+ , _selectionRange = srcSpanToRange l'

132+ }

133+documentSymbolForDecl (L l (InstD ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))

134+ = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty

135+ , _kind = SkInterface

136+ }

137+documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))

138+ = Just (defDocumentSymbol l :: DocumentSymbol)

139+ { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

140+ (map pprText feqn_pats)

141+ , _kind = SkInterface

142+ }

143+documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))

144+ = Just (defDocumentSymbol l :: DocumentSymbol)

145+ { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

146+ (map pprText feqn_pats)

147+ , _kind = SkInterface

148+ }

149+documentSymbolForDecl (L l (DerivD DerivDecl { deriv_type })) =

150+ gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) ->

151+ (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs)

152+ name

153+ , _kind = SkInterface

154+ }

155+documentSymbolForDecl (L l (ValD FunBind{fun_id = L _ name})) = Just

156+ (defDocumentSymbol l :: DocumentSymbol)

157+ { _name = showRdrName name

158+ , _kind = SkFunction

159+ }

160+documentSymbolForDecl (L l (ValD PatBind{pat_lhs})) = Just

161+ (defDocumentSymbol l :: DocumentSymbol)

162+ { _name = pprText pat_lhs

163+ , _kind = SkFunction

164+ }

165+

166+documentSymbolForDecl (L l (ForD x)) = Just

167+ (defDocumentSymbol l :: DocumentSymbol)

168+ { _name = case x of

169+ ForeignImport{} -> name

170+ ForeignExport{} -> name

171+#if MIN_GHC_API_VERSION(8,6,0)

172+ XForeignDecl{} -> "?"

173+#endif

174+ , _kind = SkObject

175+ , _detail = case x of

176+ ForeignImport{} -> Just "import"

177+ ForeignExport{} -> Just "export"

178+#if MIN_GHC_API_VERSION(8,6,0)

179+ XForeignDecl{} -> Nothing

180+#endif

181+ }

182+ where name = showRdrName $ unLoc $ fd_name x

183+

184+documentSymbolForDecl _ = Nothing

185+

186+-- | Wrap the Document imports into a hierarchical outline for

187+-- a better overview of symbols in scope.

188+-- If there are no imports, then no hierarchy will be created.

189+documentSymbolForImportSummary :: [DocumentSymbol] -> Maybe DocumentSymbol

190+documentSymbolForImportSummary [] = Nothing

191+documentSymbolForImportSummary importSymbols =

192+ let

193+ -- safe because if we have no ranges then we don't take this branch

194+ mergeRanges xs = Range (minimum $ map _start xs) (maximum $ map _end xs)

195+ importRange = mergeRanges $ map (_range :: DocumentSymbol -> Range) importSymbols

196+ in

197+ Just (defDocumentSymbol empty :: DocumentSymbol)

198+ { _name = "imports"

199+ , _kind = SkModule

200+ , _children = Just (List importSymbols)

201+ , _range = importRange

202+ , _selectionRange = importRange

203+ }

204+

205+documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol

206+documentSymbolForImport (L l ImportDecl { ideclName, ideclQualified }) = Just

207+ (defDocumentSymbol l :: DocumentSymbol)

208+ { _name = "import " <> pprText ideclName

209+ , _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

214+#endif

215+ }

216+#if MIN_GHC_API_VERSION(8,6,0)

217+documentSymbolForImport (L _ XImportDecl {}) = Nothing

218+#endif

219+

220+defDocumentSymbol :: SrcSpan -> DocumentSymbol

221+defDocumentSymbol l = DocumentSymbol { .. } where

222+ _detail = Nothing

223+ _deprecated = Nothing

224+ _name = ""

225+ _kind = SkUnknown 0

226+ _range = srcSpanToRange l

227+ _selectionRange = srcSpanToRange l

228+ _children = Nothing

229+

230+showRdrName :: RdrName -> Text

231+showRdrName = pprText

232+

233+pprText :: Outputable a => a -> Text

234+pprText = pack . showSDocUnsafe . ppr

src/Development/IDE/LSP/Server.hs+11−10

@@ -16,31 +16,32 @@ import qualified Language.Haskell.LSP.Core as LSP

1616import qualified Language.Haskell.LSP.Messages as LSP

1717import Development.IDE.Core.Service

1818

19−

20−data WithMessage = WithMessage

19+data WithMessage c = WithMessage

2120 {withResponse :: forall m req resp . (Show m, Show req) =>

2221 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

23− (LSP.LspFuncs () -> IdeState -> req -> IO resp) -> -- actual work

22+ (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work

2423 Maybe (LSP.Handler (RequestMessage m req resp))

2524 ,withNotification :: forall m req . (Show m, Show req) =>

2625 Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler

27− (LSP.LspFuncs () -> IdeState -> req -> IO ()) -> -- actual work

26+ (LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work

2827 Maybe (LSP.Handler (NotificationMessage m req))

29− ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.

28+ ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody .

3029 (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>

3130 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

3231 (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req

33− (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work

32+ (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work

3433 Maybe (LSP.Handler (RequestMessage m req resp))

34+ , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())

35+ -> Maybe (LSP.Handler InitializeRequest)

3536 }

3637

37−newtype PartialHandlers = PartialHandlers (WithMessage -> LSP.Handlers -> IO LSP.Handlers)

38+newtype PartialHandlers c = PartialHandlers (WithMessage c -> LSP.Handlers -> IO LSP.Handlers)

3839

39−instance Default PartialHandlers where

40+instance Default (PartialHandlers c) where

4041 def = PartialHandlers $ \_ x -> pure x

4142

42−instance Semigroup PartialHandlers where

43+instance Semigroup (PartialHandlers c) where

4344 PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w

4445

45−instance Monoid PartialHandlers where

46+instance Monoid (PartialHandlers c) where

4647 mempty = def

src/Development/IDE/Plugin.hsnew file+60

@@ -0,0 +1,60 @@

2+module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules,makeLspCommandId,getPid) where

4+import Data.Default

5+import qualified Data.Text as T

6+import Development.Shake

7+import Development.IDE.LSP.Server

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.hsnew file+570

@@ -0,0 +1,570 @@

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.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.hsnew file+112

@@ -0,0 +1,112 @@

1+-- | Position indexed streams of characters

2+module Development.IDE.Plugin.CodeAction.PositionIndexed

3+ ( PositionIndexed

4+ , PositionIndexedString

5+ , indexedByPosition

6+ , indexedByPositionStartingFrom

7+ , extendAllToIncludeCommaIfPossible

8+ , mergeRanges

9+ )

10+where

11+

12+import Data.Char

13+import Data.List

14+import Language.Haskell.LSP.Types

15+

16+type PositionIndexed a = [(Position, a)]

17+

18+type PositionIndexedString = PositionIndexed Char

19+

20+-- | Add position indexing to a String.

21+--

22+-- > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡

23+-- > [ ((0,0),'h')

24+-- > , ((0,1),'e')

25+-- > , ((0,2),'y')

26+-- > , ((0,3),'\n')

27+-- > , ((1,0),' ')

28+-- > , ((1,1),'h')

29+-- > , ((1,2),'o')

30+-- > ]

31+indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString

32+indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where

33+ f (_, []) = Nothing

34+ f (p@(Position l _), '\n' : rest) =

35+ Just ((p, '\n'), (Position (l + 1) 0, rest))

36+ f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest))

37+

38+-- | Add position indexing to a String.

39+--

40+-- > indexedByPosition = indexedByPositionStartingFrom (Position 0 0)

41+indexedByPosition :: String -> PositionIndexedString

42+indexedByPosition = indexedByPositionStartingFrom (Position 0 0)

43+

44+-- | Returns a tuple (before, contents, after) if the range is present.

45+-- The range is present only if both its start and end positions are present

46+unconsRange

47+ :: Range

48+ -> PositionIndexed a

49+ -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a)

50+unconsRange Range {..} indexedString

51+ | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString

52+ , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest

53+ = Just (before, mid, after)

54+ | otherwise

55+ = Nothing

56+

57+-- | Strips out all the positions included in the range.

58+-- Returns 'Nothing' if the start or end of the range are not included in the input.

59+stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a)

60+stripRange r s = case unconsRange r s of

61+ Just (b, _, a) -> Just (b ++ a)

62+ Nothing -> Nothing

63+

64+-- | Returns the smallest possible set of disjoint ranges that is equivalent to the input.

65+-- Assumes input ranges are sorted on the start positions.

66+mergeRanges :: [Range] -> [Range]

67+mergeRanges (r : r' : rest)

68+ |

69+ -- r' is contained in r

70+ _end r > _end r' = mergeRanges (r : rest)

71+ |

72+ -- r and r' are overlapping

73+ _end r > _start r' = mergeRanges (r { _end = _end r' } : rest)

74+

75+ | otherwise = r : mergeRanges (r' : rest)

76+mergeRanges other = other

77+

78+-- | Returns a sorted list of ranges with extended selections including preceding or trailing commas

79+--

80+-- @

81+-- a, |b|, c ===> a|, b|, c

82+-- a, b, |c| ===> a, b|, c|

83+-- a, |b|, |c| ===> a|, b||, c|

84+-- @

85+extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]

86+extendAllToIncludeCommaIfPossible indexedString =

87+ mergeRanges . go indexedString . sortOn _start

88+ where

89+ go _ [] = []

90+ go input (r : rr)

91+ | r' : _ <- extendToIncludeCommaIfPossible input r

92+ , Just input' <- stripRange r' input

93+ = r' : go input' rr

94+ | otherwise

95+ = go input rr

96+

97+extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]

98+extendToIncludeCommaIfPossible indexedString range

99+ | Just (before, _, after) <- unconsRange range indexedString

100+ , after' <- dropWhile (isSpace . snd) after

101+ , before' <- dropWhile (isSpace . snd) (reverse before)

102+ =

103+ -- a, |b|, c ===> a|, b|, c

104+ [ range { _start = start' } | (start', ',') : _ <- [before'] ]

105+ ++

106+ -- a, |b|, c ===> a, |b, |c

107+ [ range { _end = end' }

108+ | (_, ',') : rest <- [after']

109+ , let (end', _) : _ = dropWhile (isSpace . snd) rest

110+ ]

111+ | otherwise

112+ = [range]

src/Development/IDE/Plugin/CodeAction/RuleTypes.hsnew file+61

@@ -0,0 +1,61 @@

1+{-# LANGUAGE TypeFamilies #-}

2+module Development.IDE.Plugin.CodeAction.RuleTypes

3+ (PackageExports(..), PackageExportsMap

4+ ,IdentInfo(..)

5+ ,mkIdentInfos

6+ ) where

8+import Avail (AvailInfo(..))

9+import Data.Hashable (Hashable)

10+import Control.DeepSeq (NFData)

11+import Data.Binary (Binary)

12+import Data.Text (pack, Text)

13+import Development.IDE.GHC.Util

14+import Development.Shake (RuleResult)

15+import Data.HashMap.Strict (HashMap)

16+import Data.Typeable (Typeable)

17+import GHC.Generics (Generic)

18+import Name

19+import FieldLabel (flSelector)

20+

21+type Identifier = Text

22+type ModuleName = Text

23+

24+data IdentInfo = IdentInfo

25+ { name :: !Identifier

26+ , rendered :: Text

27+ , parent :: !(Maybe Text)

28+ , isDatacon :: !Bool

29+ }

30+ deriving (Eq, Generic, Show)

31+

32+instance NFData IdentInfo

33+

34+mkIdentInfos :: AvailInfo -> [IdentInfo]

35+mkIdentInfos (Avail n) =

36+ [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)]

37+mkIdentInfos (AvailTC parent (n:nn) flds)

38+ -- Following the GHC convention that parent == n if parent is exported

39+ | n == parent

40+ = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) True

41+ | n <- nn ++ map flSelector flds

42+ ] ++

43+ [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing False]

44+ where

45+ parentP = pack $ prettyPrint parent

46+

47+mkIdentInfos (AvailTC _ nn flds)

48+ = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing True

49+ | n <- nn ++ map flSelector flds

50+ ]

51+

52+-- Rule type for caching Package Exports

53+type instance RuleResult PackageExports = PackageExportsMap

54+type PackageExportsMap = HashMap Identifier [(IdentInfo,ModuleName)]

55+

56+newtype PackageExports = PackageExports HscEnvEq

57+ deriving (Eq, Show, Typeable, Generic)

58+

59+instance Hashable PackageExports

60+instance NFData PackageExports

61+instance Binary PackageExports

src/Development/IDE/Plugin/CodeAction/Rules.hsnew file+61

@@ -0,0 +1,61 @@

1+module Development.IDE.Plugin.CodeAction.Rules

2+ ( rulePackageExports

3+ )

4+where

6+import Data.HashMap.Strict ( fromListWith )

7+import Data.Text ( Text

8+ , pack

9+ )

10+import Data.Traversable ( forM )

11+import Development.IDE.Core.Rules

12+import Development.IDE.GHC.Util

13+import Development.IDE.Plugin.CodeAction.RuleTypes

14+import Development.Shake

15+import GHC ( DynFlags(pkgState) )

16+import HscTypes ( IfaceExport

17+ , hsc_dflags

18+ , mi_exports

19+ )

20+import LoadIface

21+import Maybes

22+import Module ( Module(..)

23+ , ModuleName

24+ , moduleNameString

25+ )

26+import Packages ( explicitPackages

27+ , exposedModules

28+ , packageConfigId

29+ )

30+import TcRnMonad ( WhereFrom(ImportByUser)

31+ , initIfaceLoad

32+ )

33+

34+rulePackageExports :: Rules ()

35+rulePackageExports = defineNoFile $ \(PackageExports session) -> do

36+ let env = hscEnv session

37+ pkgst = pkgState (hsc_dflags env)

38+ depends = explicitPackages pkgst

39+ targets =

40+ [ (pkg, mn)

41+ | d <- depends

42+ , Just pkg <- [lookupPackageConfig d env]

43+ , (mn, _) <- exposedModules pkg

44+ ]

45+

46+ results <- forM targets $ \(pkg, mn) -> do

47+ modIface <- liftIO $ initIfaceLoad env $ loadInterface

48+ ""

49+ (Module (packageConfigId pkg) mn)

50+ (ImportByUser False)

51+ case modIface of

52+ Failed _err -> return mempty

53+ Succeeded mi -> do

54+ let avails = mi_exports mi

55+ return $ concatMap (unpackAvail mn) avails

56+ return $ fromListWith (++) $ concat results

57+

58+unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])]

59+unpackAvail mod =

60+ map (\id@IdentInfo {..} -> (name, [(id, pack $ moduleNameString mod)]))

61+ . mkIdentInfos

src/Development/IDE/Plugin/Completions.hsnew file+103

@@ -0,0 +1,103 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE TypeFamilies #-}

3+#include "ghc-api-version.h"

5+module Development.IDE.Plugin.Completions(plugin) where

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/Plugin/Completions/Logic.hsnew file+530

@@ -0,0 +1,530 @@

1+{-# LANGUAGE CPP #-}

2+#include "ghc-api-version.h"

3+-- Mostly taken from "haskell-ide-engine"

4+module Development.IDE.Plugin.Completions.Logic (

5+ CachedCompletions

6+, cacheDataProducer

7+, WithSnippets(..)

8+,getCompletions

9+) where

10+

11+import Control.Applicative

12+import Data.Char (isSpace, isUpper)

13+import Data.Generics

14+import Data.List.Extra as List hiding (stripPrefix)

15+import qualified Data.Map as Map

16+import Data.Maybe (fromMaybe, mapMaybe)

17+import qualified Data.Text as T

18+import qualified Text.Fuzzy as Fuzzy

19+

20+import GHC

21+import HscTypes

22+import Name

23+import RdrName

24+import TcRnTypes

25+import Type

26+import Var

27+import Packages

28+import DynFlags

29+#if MIN_GHC_API_VERSION(8,10,0)

30+import Predicate (isDictTy)

31+import GHC.Platform

32+import Pair

33+import Coercion

34+#endif

35+

36+import Language.Haskell.LSP.Types

37+import Language.Haskell.LSP.Types.Capabilities

38+import qualified Language.Haskell.LSP.VFS as VFS

39+import Development.IDE.Plugin.Completions.Types

40+import Development.IDE.Spans.Documentation

41+import Development.IDE.GHC.Error

42+import Development.IDE.Types.Options

43+import Development.IDE.Spans.Common

44+import Development.IDE.GHC.Util

45+

46+-- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs

47+

48+-- | A context of a declaration in the program

49+-- e.g. is the declaration a type declaration or a value declaration

50+-- Used for determining which code completions to show

51+-- TODO: expand this with more contexts like classes or instances for

52+-- smarter code completion

53+data Context = TypeContext

54+ | ValueContext

55+ | ModuleContext String -- ^ module context with module name

56+ | ImportContext String -- ^ import context with module name

57+ | ImportListContext String -- ^ import list context with module name

58+ | ImportHidingContext String -- ^ import hiding context with module name

59+ | ExportContext -- ^ List of exported identifiers from the current module

60+ deriving (Show, Eq)

61+

62+-- | Generates a map of where the context is a type and where the context is a value

63+-- i.e. where are the value decls and the type decls

64+getCContext :: Position -> ParsedModule -> Maybe Context

65+getCContext pos pm

66+ | Just (L r modName) <- moduleHeader

67+ , pos `isInsideSrcSpan` r

68+ = Just (ModuleContext (moduleNameString modName))

69+

70+ | Just (L r _) <- exportList

71+ , pos `isInsideSrcSpan` r

72+ = Just ExportContext

73+

74+ | Just ctx <- something (Nothing `mkQ` go `extQ` goInline) decl

75+ = Just ctx

76+

77+ | Just ctx <- something (Nothing `mkQ` importGo) imports

78+ = Just ctx

79+

80+ | otherwise

81+ = Nothing

82+

83+ where decl = hsmodDecls $ unLoc $ pm_parsed_source pm

84+ moduleHeader = hsmodName $ unLoc $ pm_parsed_source pm

85+ exportList = hsmodExports $ unLoc $ pm_parsed_source pm

86+ imports = hsmodImports $ unLoc $ pm_parsed_source pm

87+

88+ go :: LHsDecl GhcPs -> Maybe Context

89+ go (L r SigD {})

90+ | pos `isInsideSrcSpan` r = Just TypeContext

91+ | otherwise = Nothing

92+ go (L r GHC.ValD {})

93+ | pos `isInsideSrcSpan` r = Just ValueContext

94+ | otherwise = Nothing

95+ go _ = Nothing

96+

97+ goInline :: GHC.LHsType GhcPs -> Maybe Context

98+ goInline (GHC.L r _)

99+ | pos `isInsideSrcSpan` r = Just TypeContext

100+ goInline _ = Nothing

101+

102+ importGo :: GHC.LImportDecl GhcPs -> Maybe Context

103+ importGo (L r impDecl)

104+ | pos `isInsideSrcSpan` r

105+ = importInline importModuleName (ideclHiding impDecl)

106+ <|> Just (ImportContext importModuleName)

107+

108+ | otherwise = Nothing

109+ where importModuleName = moduleNameString $ unLoc $ ideclName impDecl

110+

111+ importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context

112+ importInline modName (Just (True, L r _))

113+ | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName

114+ | otherwise = Nothing

115+ importInline modName (Just (False, L r _))

116+ | pos `isInsideSrcSpan` r = Just $ ImportListContext modName

117+ | otherwise = Nothing

118+ importInline _ _ = Nothing

119+

120+occNameToComKind :: Maybe T.Text -> OccName -> CompletionItemKind

121+occNameToComKind ty oc

122+ | isVarOcc oc = case occNameString oc of

123+ i:_ | isUpper i -> CiConstructor

124+ _ -> CiFunction

125+ | isTcOcc oc = case ty of

126+ Just t

127+ | "Constraint" `T.isSuffixOf` t

128+ -> CiClass

129+ _ -> CiStruct

130+ | isDataOcc oc = CiConstructor

131+ | otherwise = CiVariable

132+

133+mkCompl :: IdeOptions -> CompItem -> CompletionItem

134+mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} =

135+ CompletionItem label kind (List []) ((colon <>) <$> typeText)

136+ (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')

137+ Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)

138+ Nothing Nothing Nothing Nothing Nothing

139+ where kind = Just $ occNameToComKind typeText $ occName origName

140+ insertText = case isInfix of

141+ Nothing -> case getArgText <$> thingType of

142+ Nothing -> label

143+ Just argText -> label <> " " <> argText

144+ Just LeftSide -> label <> "`"

145+

146+ Just Surrounded -> label

147+ typeText

148+ | Just t <- thingType = Just . stripForall $ T.pack (showGhc t)

149+ | otherwise = Nothing

150+ docs' = ("*Defined in '" <> importedFrom <> "'*\n") : spanDocToMarkdown docs

151+ colon = if optNewColonConvention then ": " else ":: "

152+

153+stripForall :: T.Text -> T.Text

154+stripForall t

155+ | T.isPrefixOf "forall" t =

156+ -- We drop 2 to remove the '.' and the space after it

157+ T.drop 2 (T.dropWhile (/= '.') t)

158+ | otherwise = t

159+

160+getArgText :: Type -> T.Text

161+getArgText typ = argText

162+ where

163+ argTypes = getArgs typ

164+ argText :: T.Text

165+ argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes

166+ snippet :: Int -> Type -> T.Text

167+ snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"

168+ getArgs :: Type -> [Type]

169+ getArgs t

170+ | isPredTy t = []

171+ | isDictTy t = []

172+ | isForAllTy t = getArgs $ snd (splitForAllTys t)

173+ | isFunTy t =

174+ let (args, ret) = splitFunTys t

175+ in if isForAllTy ret

176+ then getArgs ret

177+ else Prelude.filter (not . isDictTy) args

178+ | isPiTy t = getArgs $ snd (splitPiTys t)

179+#if MIN_GHC_API_VERSION(8,10,0)

180+ | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t

181+ = getArgs t

182+#else

183+ | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t)

184+#endif

185+ | otherwise = []

186+

187+mkModCompl :: T.Text -> CompletionItem

188+mkModCompl label =

189+ CompletionItem label (Just CiModule) (List []) Nothing

190+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing

191+ Nothing Nothing Nothing Nothing Nothing

192+

193+mkImportCompl :: T.Text -> T.Text -> CompletionItem

194+mkImportCompl enteredQual label =

195+ CompletionItem m (Just CiModule) (List []) (Just label)

196+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing

197+ Nothing Nothing Nothing Nothing Nothing

198+ where

199+ m = fromMaybe "" (T.stripPrefix enteredQual label)

200+

201+mkExtCompl :: T.Text -> CompletionItem

202+mkExtCompl label =

203+ CompletionItem label (Just CiKeyword) (List []) Nothing

204+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing

205+ Nothing Nothing Nothing Nothing Nothing

206+

207+mkPragmaCompl :: T.Text -> T.Text -> CompletionItem

208+mkPragmaCompl label insertText =

209+ CompletionItem label (Just CiKeyword) (List []) Nothing

210+ Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)

211+ Nothing Nothing Nothing Nothing Nothing

212+

213+cacheDataProducer :: HscEnv -> TypecheckedModule -> [ParsedModule] -> IO CachedCompletions

214+cacheDataProducer packageState tm deps = do

215+ let parsedMod = tm_parsed_module tm

216+ dflags = hsc_dflags packageState

217+ curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod

218+ Just (_,limports,_,_) = tm_renamed_source tm

219+

220+ iDeclToModName :: ImportDecl name -> ModuleName

221+ iDeclToModName = unLoc . ideclName

222+

223+ showModName :: ModuleName -> T.Text

224+ showModName = T.pack . moduleNameString

225+

226+ asNamespace :: ImportDecl name -> ModuleName

227+ asNamespace imp = maybe (iDeclToModName imp) GHC.unLoc (ideclAs imp)

228+ -- Full canonical names of imported modules

229+ importDeclerations = map unLoc limports

230+

231+ -- The list of all importable Modules from all packages

232+ moduleNames = map showModName (listVisibleModuleNames dflags)

233+

234+ -- The given namespaces for the imported modules (ie. full name, or alias if used)

235+ allModNamesAsNS = map (showModName . asNamespace) importDeclerations

236+

237+ typeEnv = tcg_type_env $ fst $ tm_internals_ tm

238+ rdrEnv = tcg_rdr_env $ fst $ tm_internals_ tm

239+ rdrElts = globalRdrEnvElts rdrEnv

240+

241+ foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b

242+ foldMapM f xs = foldr step return xs mempty where

243+ step x r z = f x >>= \y -> r $! z `mappend` y

244+

245+ getCompls :: [GlobalRdrElt] -> IO ([CompItem],QualCompls)

246+ getCompls = foldMapM getComplsForOne

247+

248+ getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls)

249+ getComplsForOne (GRE n _ True _) =

250+ case lookupTypeEnv typeEnv n of

251+ Just tt -> case safeTyThingId tt of

252+ Just var -> (\x -> ([x],mempty)) <$> varToCompl var

253+ Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n

254+ Nothing -> (\x -> ([x],mempty)) <$> toCompItem curMod n

255+ getComplsForOne (GRE n _ False prov) =

256+ flip foldMapM (map is_decl prov) $ \spec -> do

257+ compItem <- toCompItem (is_mod spec) n

258+ let unqual

259+ | is_qual spec = []

260+ | otherwise = [compItem]

261+ qual

262+ | is_qual spec = Map.singleton asMod [compItem]

263+ | otherwise = Map.fromList [(asMod,[compItem]),(origMod,[compItem])]

264+ asMod = showModName (is_as spec)

265+ origMod = showModName (is_mod spec)

266+ return (unqual,QualCompls qual)

267+

268+ varToCompl :: Var -> IO CompItem

269+ varToCompl var = do

270+ let typ = Just $ varType var

271+ name = Var.varName var

272+ label = T.pack $ showGhc name

273+ docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) name

274+ return $ CI name (showModName curMod) typ label Nothing docs

275+

276+ toCompItem :: ModuleName -> Name -> IO CompItem

277+ toCompItem mn n = do

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

289+

290+ (unquals,quals) <- getCompls rdrElts

291+

292+ return $ CC

293+ { allModNamesAsNS = allModNamesAsNS

294+ , unqualCompls = unquals

295+ , qualCompls = quals

296+ , importableModules = moduleNames

297+ }

298+

299+newtype WithSnippets = WithSnippets Bool

300+

301+toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem

302+toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x

303+ | with && supported = x

304+ | otherwise = x { _insertTextFormat = Just PlainText

305+ , _insertText = Nothing

306+ }

307+ where supported = Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)

308+

309+-- | Returns the cached completions for the given module and position.

310+getCompletions :: IdeOptions -> CachedCompletions -> ParsedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]

311+getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }

312+ pm prefixInfo caps withSnippets = do

313+ let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo

314+ enteredQual = if T.null prefixModule then "" else prefixModule <> "."

315+ fullPrefix = enteredQual <> prefixText

316+

317+ {- correct the position by moving 'foo :: Int -> String -> '

318+ ^

319+ to 'foo :: Int -> String -> '

320+ ^

321+ -}

322+ pos =

323+ let Position l c = VFS.cursorPos prefixInfo

324+ typeStuff = [isSpace, (`elem` (">-." :: String))]

325+ stripTypeStuff = T.dropWhileEnd (\x -> any (\f -> f x) typeStuff)

326+ -- if oldPos points to

327+ -- foo -> bar -> baz

328+ -- ^

329+ -- Then only take the line up to there, discard '-> bar -> baz'

330+ partialLine = T.take c fullLine

331+ -- drop characters used when writing incomplete type sigs

332+ -- like '-> '

333+ d = T.length fullLine - T.length (stripTypeStuff partialLine)

334+ in Position l (c - d)

335+

336+ filtModNameCompls =

337+ map mkModCompl

338+ $ mapMaybe (T.stripPrefix enteredQual)

339+ $ Fuzzy.simpleFilter fullPrefix allModNamesAsNS

340+

341+ filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False

342+ where

343+ isTypeCompl = isTcOcc . occName . origName

344+ -- completions specific to the current context

345+ ctxCompls' = case getCContext pos pm of

346+ Nothing -> compls

347+ Just TypeContext -> filter isTypeCompl compls

348+ Just ValueContext -> filter (not . isTypeCompl) compls

349+ Just _ -> filter (not . isTypeCompl) compls

350+ -- Add whether the text to insert has backticks

351+ ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'

352+

353+ infixCompls :: Maybe Backtick

354+ infixCompls = isUsedAsInfix fullLine prefixModule prefixText (VFS.cursorPos prefixInfo)

355+

356+ compls = if T.null prefixModule

357+ then unqualCompls

358+ else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls

359+

360+ filtListWith f list =

361+ [ f label

362+ | label <- Fuzzy.simpleFilter fullPrefix list

363+ , enteredQual `T.isPrefixOf` label

364+ ]

365+

366+ filtListWithSnippet f list suffix =

367+ [ toggleSnippets caps withSnippets (f label (snippet <> suffix))

368+ | (snippet, label) <- list

369+ , Fuzzy.test fullPrefix label

370+ ]

371+

372+ filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules

373+ filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas

374+ filtOptsCompls = filtListWith mkExtCompl

375+ filtKeywordCompls

376+ | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)

377+ | otherwise = []

378+

379+ stripLeading :: Char -> String -> String

380+ stripLeading _ [] = []

381+ stripLeading c (s:ss)

382+ | s == c = ss

383+ | otherwise = s:ss

384+

385+ result

386+ | "import " `T.isPrefixOf` fullLine

387+ = filtImportCompls

388+ | "{-# language" `T.isPrefixOf` T.toLower fullLine

389+ = filtOptsCompls languagesAndExts

390+ | "{-# options_ghc" `T.isPrefixOf` T.toLower fullLine

391+ = filtOptsCompls (map (T.pack . stripLeading '-') $ flagsForCompletion False)

392+ | "{-# " `T.isPrefixOf` fullLine

393+ = filtPragmaCompls (pragmaSuffix fullLine)

394+ | otherwise

395+ = filtModNameCompls ++ map (toggleSnippets caps withSnippets

396+ . mkCompl ideOpts . stripAutoGenerated) filtCompls

397+ ++ filtKeywordCompls

398+

399+ return result

400+

401+-- The supported languages and extensions

402+languagesAndExts :: [T.Text]

403+#if MIN_GHC_API_VERSION(8,10,0)

404+languagesAndExts = map T.pack $ DynFlags.supportedLanguagesAndExtensions ( PlatformMini ArchUnknown OSUnknown )

405+#else

406+languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions

407+#endif

408+

409+-- ---------------------------------------------------------------------

410+-- helper functions for pragmas

411+-- ---------------------------------------------------------------------

412+

413+validPragmas :: [(T.Text, T.Text)]

414+validPragmas =

415+ [ ("LANGUAGE ${1:extension}" , "LANGUAGE")

416+ , ("OPTIONS_GHC -${1:option}" , "OPTIONS_GHC")

417+ , ("INLINE ${1:function}" , "INLINE")

418+ , ("NOINLINE ${1:function}" , "NOINLINE")

419+ , ("INLINABLE ${1:function}" , "INLINABLE")

420+ , ("WARNING ${1:message}" , "WARNING")

421+ , ("DEPRECATED ${1:message}" , "DEPRECATED")

422+ , ("ANN ${1:annotation}" , "ANN")

423+ , ("RULES" , "RULES")

424+ , ("SPECIALIZE ${1:function}" , "SPECIALIZE")

425+ , ("SPECIALIZE INLINE ${1:function}", "SPECIALIZE INLINE")

426+ ]

427+

428+pragmaSuffix :: T.Text -> T.Text

429+pragmaSuffix fullLine

430+ | "}" `T.isSuffixOf` fullLine = mempty

431+ | otherwise = " #-}"

432+

433+-- ---------------------------------------------------------------------

434+-- helper functions for infix backticks

435+-- ---------------------------------------------------------------------

436+

437+hasTrailingBacktick :: T.Text -> Position -> Bool

438+hasTrailingBacktick line Position { _character }

439+ | T.length line > _character = (line `T.index` _character) == '`'

440+ | otherwise = False

441+

442+isUsedAsInfix :: T.Text -> T.Text -> T.Text -> Position -> Maybe Backtick

443+isUsedAsInfix line prefixMod prefixText pos

444+ | hasClosingBacktick && hasOpeningBacktick = Just Surrounded

445+ | hasOpeningBacktick = Just LeftSide

446+ | otherwise = Nothing

447+ where

448+ hasOpeningBacktick = openingBacktick line prefixMod prefixText pos

449+ hasClosingBacktick = hasTrailingBacktick line pos

450+

451+openingBacktick :: T.Text -> T.Text -> T.Text -> Position -> Bool

452+openingBacktick line prefixModule prefixText Position { _character }

453+ | backtickIndex < 0 = False

454+ | otherwise = (line `T.index` backtickIndex) == '`'

455+ where

456+ backtickIndex :: Int

457+ backtickIndex =

458+ let

459+ prefixLength = T.length prefixText

460+ moduleLength = if prefixModule == ""

461+ then 0

462+ else T.length prefixModule + 1 {- Because of "." -}

463+ in

464+ -- Points to the first letter of either the module or prefix text

465+ _character - (prefixLength + moduleLength) - 1

466+

467+

468+-- ---------------------------------------------------------------------

469+

470+-- | Under certain circumstance GHC generates some extra stuff that we

471+-- don't want in the autocompleted symbols

472+stripAutoGenerated :: CompItem -> CompItem

473+stripAutoGenerated ci =

474+ ci {label = stripPrefix (label ci)}

475+ {- When e.g. DuplicateRecordFields is enabled, compiler generates

476+ names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors

477+ https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation

478+ -}

479+

480+-- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace.

481+

482+stripPrefix :: T.Text -> T.Text

483+stripPrefix name = T.takeWhile (/=':') $ go prefixes

484+ where

485+ go [] = name

486+ go (p:ps)

487+ | T.isPrefixOf p name = T.drop (T.length p) name

488+ | otherwise = go ps

489+

490+-- | Prefixes that can occur in a GHC OccName

491+prefixes :: [T.Text]

492+prefixes =

493+ [

494+ -- long ones

495+ "$con2tag_"

496+ , "$tag2con_"

497+ , "$maxtag_"

498+

499+ -- four chars

500+ , "$sel:"

501+ , "$tc'"

502+

503+ -- three chars

504+ , "$dm"

505+ , "$co"

506+ , "$tc"

507+ , "$cp"

508+ , "$fx"

509+

510+ -- two chars

511+ , "$W"

512+ , "$w"

513+ , "$m"

514+ , "$b"

515+ , "$c"

516+ , "$d"

517+ , "$i"

518+ , "$s"

519+ , "$f"

520+ , "$r"

521+ , "C:"

522+ , "N:"

523+ , "D:"

524+ , "$p"

525+ , "$L"

526+ , "$f"

527+ , "$t"

528+ , "$c"

529+ , "$m"

530+ ]

src/Development/IDE/Plugin/Completions/Types.hsnew file+58

@@ -0,0 +1,58 @@

1+module Development.IDE.Plugin.Completions.Types (

2+ module Development.IDE.Plugin.Completions.Types

3+) where

5+import Control.DeepSeq

6+import qualified Data.Map as Map

7+import qualified Data.Text as T

8+import GHC

10+import Development.IDE.Spans.Common

11+

12+-- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs

13+

14+data Backtick = Surrounded | LeftSide deriving Show

15+data CompItem = CI

16+ { origName :: Name -- ^ Original name, such as Maybe, //, or find.

17+ , importedFrom :: T.Text -- ^ From where this item is imported from.

18+ , thingType :: Maybe Type -- ^ Available type information.

19+ , label :: T.Text -- ^ Label to display to the user.

20+ , isInfix :: Maybe Backtick -- ^ Did the completion happen

21+ -- in the context of an infix notation.

22+ , docs :: SpanDoc -- ^ Available documentation.

23+ }

24+instance Show CompItem where

25+ show CI { .. } = "CompItem { origName = \"" ++ showGhc origName ++ "\""

26+ ++ ", importedFrom = " ++ show importedFrom

27+ ++ ", thingType = " ++ show (fmap showGhc thingType)

28+ ++ ", label = " ++ show label

29+ ++ ", isInfix = " ++ show isInfix

30+ ++ ", docs = " ++ show docs

31+ ++ " } "

32+instance Eq CompItem where

33+ ci1 == ci2 = origName ci1 == origName ci2

34+instance Ord CompItem where

35+ compare ci1 ci2 = origName ci1 `compare` origName ci2

36+

37+-- Associates a module's qualifier with its members

38+newtype QualCompls

39+ = QualCompls { getQualCompls :: Map.Map T.Text [CompItem] }

40+ deriving Show

41+instance Semigroup QualCompls where

42+ (QualCompls a) <> (QualCompls b) = QualCompls $ Map.unionWith (++) a b

43+instance Monoid QualCompls where

44+ mempty = QualCompls Map.empty

45+ mappend = (Prelude.<>)

46+

47+-- | End result of the completions

48+data CachedCompletions = CC

49+ { allModNamesAsNS :: [T.Text] -- ^ All module names in scope.

50+ -- Prelude is a single module

51+ , unqualCompls :: [CompItem] -- ^ All Possible completion items

52+ , qualCompls :: QualCompls -- ^ Completion items associated to

53+ -- to a specific module name.

54+ , importableModules :: [T.Text] -- ^ All modules that may be imported.

55+ } deriving Show

56+

57+instance NFData CachedCompletions where

58+ rnf = rwhnf

src/Development/IDE/Spans/AtPoint.hs+61−45

@@ -8,26 +8,24 @@ module Development.IDE.Spans.AtPoint (

88 , gotoDefinition

99 ) where

1010

11−import Development.IDE.Spans.Documentation

1211import Development.IDE.GHC.Error

1312import Development.IDE.GHC.Orphans()

1413import Development.IDE.Types.Location

1514

1615-- DAML compiler and infrastructure

17−import Development.Shake

18−import Development.IDE.GHC.Util

1916import Development.IDE.GHC.Compat

2017import Development.IDE.Types.Options

21−import Development.IDE.Spans.Type as SpanInfo

18+import Development.IDE.Spans.Type as SpanInfo

19+import Development.IDE.Spans.Common (spanDocToMarkdown)

2220

2321-- GHC API imports

24−import Avail

25−import GHC

2622import DynFlags

2723import FastString

2824import Name

2925import Outputable hiding ((<>))

3026import SrcLoc

27+import Type

28+import VarSet

3129

3230import Control.Monad.Extra

3331import Control.Monad.Trans.Maybe

@@ -39,52 +37,62 @@ import qualified Data.Text as T

3937-- | Locate the definition of the name at a given position.

4038gotoDefinition

4139 :: MonadIO m

42− => (FilePath -> m (Maybe HieFile))

40+ => (Module -> m (Maybe (HieFile, FilePath)))

4341 -> IdeOptions

44− -> HscEnv

4542 -> [SpanInfo]

4643 -> Position

4744 -> m (Maybe Location)

48−gotoDefinition getHieFile ideOpts pkgState srcSpans pos =

49− listToMaybe <$> locationsAtPoint getHieFile ideOpts pkgState pos srcSpans

45+gotoDefinition getHieFile ideOpts srcSpans pos =

46+ listToMaybe <$> locationsAtPoint getHieFile ideOpts pos srcSpans

5047

5148-- | Synopsis for the name at a given position.

5249atPoint

5350 :: IdeOptions

54− -> [TypecheckedModule]

55− -> [SpanInfo]

51+ -> SpansInfo

5652 -> Position

5753 -> Maybe (Maybe Range, [T.Text])

58−atPoint IdeOptions{..} tcs pos srcSpans = do

59− firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint srcSpans pos

60− return (Just (range firstSpan), hoverInfo firstSpan)

54+atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do

55+ firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans

56+ let constraintsAtPoint = mapMaybe spaninfoType (spansAtPoint pos cntsSpans)

57+ return (Just (range firstSpan), hoverInfo firstSpan constraintsAtPoint)

6158 where

6259 -- Hover info for types, classes, type variables

63− hoverInfo SpanInfo{spaninfoType = Nothing , ..} =

64− documentation <> (wrapLanguageSyntax <$> name <> kind) <> location

60+ hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs , ..} _ =

61+ (wrapLanguageSyntax <$> name) <> location <> spanDocToMarkdown docs

6562 where

66− documentation = findDocumentation mbName

6763 name = [maybe shouldNotHappen showName mbName]

6864 location = [maybe shouldNotHappen definedAt mbName]

69− kind = [] -- TODO

7065 shouldNotHappen = "ghcide: did not expect a type level component without a name"

7166 mbName = getNameM spaninfoSource

7267

7368 -- Hover info for values/data

74− hoverInfo SpanInfo{spaninfoType = (Just typ), ..} =

75− documentation <> (wrapLanguageSyntax <$> nameOrSource <> typeAnnotation) <> location

69+ hoverInfo SpanInfo{spaninfoType = (Just typ), spaninfoDocs = docs , ..} cnts =

70+ (wrapLanguageSyntax <$> nameOrSource) <> location <> spanDocToMarkdown docs

7671 where

7772 mbName = getNameM spaninfoSource

78− documentation = findDocumentation mbName

79− typeAnnotation = [colon <> showName typ]

80− nameOrSource = [maybe literalSource qualifyNameIfPossible mbName]

81− literalSource = "" -- TODO: literals: display (length-limited) source

73+ expr = case spaninfoSource of

74+ Named n -> qualifyNameIfPossible n

75+ Lit l -> crop $ T.pack l

76+ _ -> ""

77+ nameOrSource = [expr <> "\n" <> typeAnnotation]

8278 qualifyNameIfPossible name' = modulePrefix <> showName name'

8379 where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')

8480 location = [maybe "" definedAt mbName]

8581

86− findDocumentation = maybe [] (getDocumentation tcs)

87− definedAt name = "**Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "**\n"

82+ thisFVs = tyCoVarsOfType typ

83+ constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts

84+ constraintsT = T.intercalate ", " (map showName constraintsOverFVs)

85+

86+ typeAnnotation = case constraintsOverFVs of

87+ [] -> colon <> showName typ

88+ [_] -> colon <> constraintsT <> "\n=> " <> showName typ

89+ _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ

90+

91+ 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

8896

8997 range SpanInfo{..} = Range

9098 (Position spaninfoStartLine spaninfoStartCol)

@@ -107,34 +115,38 @@ atPoint IdeOptions{..} tcs pos srcSpans = do

107115 Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]

108116 Nothing -> False

109117

110−locationsAtPoint :: forall m . MonadIO m => (FilePath -> m (Maybe HieFile)) -> IdeOptions -> HscEnv -> Position -> [SpanInfo] -> m [Location]

111−locationsAtPoint getHieFile IdeOptions{..} pkgState pos =

118+locationsAtPoint

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 =

112127 fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos

113128 where getSpan :: SpanSource -> m (Maybe SrcSpan)

114129 getSpan NoSource = pure Nothing

115130 getSpan (SpanS sp) = pure $ Just sp

131+ getSpan (Lit _) = pure Nothing

116132 getSpan (Named name) = case nameSrcSpan name of

117133 sp@(RealSrcSpan _) -> pure $ Just sp

118134 sp@(UnhelpfulSpan _) -> runMaybeT $ do

119135 guard (sp /= wiredInSrcSpan)

120− -- This case usually arises when the definition is in an external package.

136+ -- This case usually arises when the definition is in an external package (DAML only).

121137 -- In this case the interface files contain garbage source spans

122138 -- so we instead read the .hie files to get useful source spans.

123− let mod = nameModule name

124− let unitId = moduleUnitId mod

125− pkgConfig <- MaybeT $ pure $ lookupPackageConfig unitId pkgState

126− hiePath <- MaybeT $ liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod

127− hieFile <- MaybeT $ getHieFile hiePath

128− avail <- MaybeT $ pure $ listToMaybe (filterAvails (eqName name) $ hie_exports hieFile)

129− srcPath <- MaybeT $ liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod

139+ mod <- MaybeT $ return $ nameModule_maybe name

140+ (hieFile, srcPath) <- MaybeT $ getHieFile mod

141+ avail <- MaybeT $ pure $ find (eqName name . snd) $ hieExportNames hieFile

130142 -- The location will point to the source file used during compilation.

131143 -- This file might no longer exists and even if it does the path will be relative

132144 -- to the compilation directory which we don’t know.

133− let span = setFileName srcPath $ nameSrcSpan $ availName avail

145+ let span = setFileName srcPath $ fst avail

134146 pure span

135147 -- We ignore uniques and source spans and only compare the name and the module.

136148 eqName :: Name -> Name -> Bool

137− eqName n n' = nameOccName n == nameOccName n' && nameModule n == nameModule n'

149+ eqName n n' = nameOccName n == nameOccName n' && nameModule_maybe n == nameModule_maybe n'

138150 setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })

139151 setFileName _ span@(UnhelpfulSpan _) = span

140152

@@ -143,12 +155,16 @@ spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo]

143155spansAtPoint pos = filter atp where

144156 line = _line pos

145157 cha = _character pos

146− atp SpanInfo{..} = spaninfoStartLine <= line

147− && spaninfoEndLine >= line

148− && spaninfoStartCol <= cha

149− -- The end col points to the column after the

150− -- last character so we use > instead of >=

151− && spaninfoEndCol > cha

158+ atp SpanInfo{..} =

159+ startsBeforePosition && endsAfterPosition

160+ where

161+ startLineCmp = compare spaninfoStartLine line

162+ endLineCmp = compare spaninfoEndLine line

163+

164+ startsBeforePosition = startLineCmp == LT || (startLineCmp == EQ && spaninfoStartCol <= cha)

165+ -- The end col points to the column after the

166+ -- last character so we use > instead of >=

167+ endsAfterPosition = endLineCmp == GT || (endLineCmp == EQ && spaninfoEndCol > cha)

152168

153169showName :: Outputable a => a -> T.Text

154170showName = T.pack . prettyprint

src/Development/IDE/Spans/Calculate.hs+149−65

@@ -9,29 +9,35 @@

1010-- | Get information on modules, identifiers, etc.

1111

12−module Development.IDE.Spans.Calculate(getSrcSpanInfos,listifyAllSpans) where

12+module Development.IDE.Spans.Calculate(getSrcSpanInfos) where

1313

1414import ConLike

1515import Control.Monad

1616import qualified CoreUtils

17−import Data.Data

18−import qualified Data.Generics

1917import Data.List

2018import Data.Maybe

2119import DataCon

2220import Desugar

2321import GHC

2422import GhcMonad

23+import HscTypes

2524import FastString (mkFastString)

25+import OccName

2626import Development.IDE.Types.Location

2727import Development.IDE.Spans.Type

28+#ifdef GHC_LIB

2829import Development.IDE.GHC.Error (zeroSpan)

30+#else

31+import Development.IDE.GHC.Error (zeroSpan, catchSrcErrors)

32+#endif

2933import Prelude hiding (mod)

3034import TcHsSyn

3135import Var

3236import Development.IDE.Core.Compile

37+import qualified Development.IDE.GHC.Compat as Compat

3338import Development.IDE.GHC.Util

34−

39+import Development.IDE.Spans.Common

40+import Development.IDE.Spans.Documentation

3541

3642-- A lot of things gained an extra X argument in GHC 8.6, which we mostly ignore

3743-- this U ignores that arg in 8.6, but is hidden in 8.4

@@ -44,42 +50,67 @@ import Development.IDE.GHC.Util

4450-- | Get source span info, used for e.g. AtPoint and Goto Definition.

4551getSrcSpanInfos

4652 :: HscEnv

47− -> [(Located ModuleName, Maybe NormalizedFilePath)]

53+ -> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order

4854 -> TcModuleResult

49− -> IO [SpanInfo]

50−getSrcSpanInfos env imports tc =

51− runGhcEnv env

52− . getSpanInfo imports

53− $ tmrModule tc

55+ -> [ParsedModule] -- ^ Dependencies parsed, optional

56+ -> [ModIface] -- ^ Dependencies module interfaces, required

57+ -> IO SpansInfo

58+getSrcSpanInfos env imports tc parsedDeps deps =

59+ evalGhcEnv env $

60+ getSpanInfo imports (tmrModule tc) parsedDeps deps

5461

5562-- | Get ALL source spans in the module.

5663getSpanInfo :: GhcMonad m

5764 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports

5865 -> TypecheckedModule

59− -> m [SpanInfo]

60−getSpanInfo mods tcm =

61− do let tcs = tm_typechecked_source tcm

66+ -> [ParsedModule]

67+ -> [ModIface]

68+ -> m SpansInfo

69+getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps deps =

70+ do let tcs = tm_typechecked_source

6271 bs = listifyAllSpans tcs :: [LHsBind GhcTc]

6372 es = listifyAllSpans tcs :: [LHsExpr GhcTc]

6473 ps = listifyAllSpans' tcs :: [Pat GhcTc]

65− ts = listifyAllSpans $ tm_renamed_source tcm :: [LHsType GhcRn]

66− bts <- mapM (getTypeLHsBind tcm) bs -- binds

67− ets <- mapM (getTypeLHsExpr tcm) es -- expressions

68− pts <- mapM (getTypeLPat tcm) ps -- patterns

69− tts <- mapM (getLHsType tcm) ts -- types

74+ ts = listifyAllSpans tm_renamed_source :: [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

84+ ets <- mapM (getTypeLHsExpr allModules) es -- expressions

85+ pts <- mapM (getTypeLPat allModules) ps -- patterns

86+ tts <- mapM (getLHsType allModules) ts -- types

7087 let imports = importInfo mods

7188 let exports = getExports tcm

72− let exprs = exports ++ imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)

73− return (mapMaybe toSpanInfo (sortBy cmp exprs))

74− where cmp (_,a,_) (_,b,_)

89+ let exprs = addEmptyInfo exports ++ addEmptyInfo imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)

90+ let constraints = map constraintToInfo (concatMap getConstraintsLHsBind bs)

91+ return $ SpansInfo (mapMaybe toSpanInfo (sortBy cmp exprs))

92+ (mapMaybe toSpanInfo (sortBy cmp constraints))

93+ where cmp (_,a,_,_) (_,b,_,_)

7594 | a `isSubspanOf` b = LT

7695 | b `isSubspanOf` a = GT

7796 | otherwise = compare (srcSpanStart a) (srcSpanStart b)

7897

79−getExports :: TypecheckedModule -> [(SpanSource, SrcSpan, Maybe Type)]

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)]

80111getExports m

81112 | Just (_, _, Just exports, _) <- renamedSource m =

82− [ (Named $ unLoc n, getLoc n, Nothing)

113+ [ (Named $ unLoc n, getLoc n)

83114 | (e, _) <- exports

84115 , n <- ieLNames $ unLoc e

85116 ]

@@ -95,44 +126,96 @@ ieLNames _ = []

95126

96127-- | Get the name and type of a binding.

97128getTypeLHsBind :: (GhcMonad m)

98− => TypecheckedModule

129+ => [ParsedModule]

130+ -> OccEnv (HsBind GhcPs)

99131 -> LHsBind GhcTc

100− -> m [(SpanSource, SrcSpan, Maybe Type)]

101−getTypeLHsBind _ (L _spn FunBind{ fun_id = pid

102− , fun_matches = MG{mg_alts=(L _ matches)}}) =

103− return [(Named (getName (unLoc pid)), getLoc match, Just (varType (unLoc pid))) | match <- matches ]

104−getTypeLHsBind _ _ = return []

132+ -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]

133+getTypeLHsBind deps funBinds (L _spn FunBind{fun_id = pid})

134+ | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) = do

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] ]

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 []

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 _ = []

105151

106152-- | Get the name and type of an expression.

107153getTypeLHsExpr :: (GhcMonad m)

108− => TypecheckedModule

154+ => [ParsedModule]

109155 -> LHsExpr GhcTc

110− -> m (Maybe (SpanSource, SrcSpan, Maybe Type))

111−getTypeLHsExpr _ e = do

156+ -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))

157+getTypeLHsExpr deps e = do

112158 hs_env <- getSession

113159 (_, mbe) <- liftIO (deSugarExpr hs_env e)

114− return $

115− case mbe of

116− Just expr ->

117− Just (getSpanSource (unLoc e), getLoc e, Just (CoreUtils.exprType expr))

118− Nothing -> Nothing

160+ case mbe of

161+ Just expr -> do

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)

167+ Nothing -> return Nothing

119168 where

120169 getSpanSource :: HsExpr GhcTc -> SpanSource

170+ getSpanSource xpr | isLit xpr = Lit (showGhc xpr)

121171 getSpanSource (HsVar U (L _ i)) = Named (getName i)

122172 getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)

123173 getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name)

124174 getSpanSource (HsWrap U _ xpr) = getSpanSource xpr

125175 getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr)

126− getSpanSource _ = NoSource

176+ 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

127207

128208-- | Get the name and type of a pattern.

129209getTypeLPat :: (GhcMonad m)

130− => TypecheckedModule

210+ => [ParsedModule]

131211 -> Pat GhcTc

132− -> m (Maybe (SpanSource, SrcSpan, Maybe Type))

133−getTypeLPat _ pat =

134− let (src, spn) = getSpanSource pat in

135− return $ Just (src, spn, Just (hsPatType pat))

212+ -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))

213+getTypeLPat deps pat = do

214+ let (src, spn) = getSpanSource pat

215+ docs <- case src of

216+ Named n -> getDocumentationTryGhc deps n

217+ _ -> return emptySpanDoc

218+ return $ Just (src, spn, Just (hsPatType pat), docs)

136219 where

137220 getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan)

138221 getSpanSource (VarPat U (L spn vid)) = (Named (getName vid), spn)

@@ -142,40 +225,40 @@ getTypeLPat _ pat =

142225

143226getLHsType

144227 :: GhcMonad m

145− => TypecheckedModule

228+ => [ParsedModule]

146229 -> LHsType GhcRn

147− -> m [(SpanSource, SrcSpan, Maybe Type)]

148−getLHsType _ (L spn (HsTyVar U _ v)) = pure [(Named $ unLoc v, spn, Nothing)]

230+ -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]

231+getLHsType deps (L spn (HsTyVar U _ v)) = do

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)]

149245getLHsType _ _ = pure []

150246

151247importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]

152− -> [(SpanSource, SrcSpan, Maybe Type)]

248+ -> [(SpanSource, SrcSpan)]

153249importInfo = mapMaybe (uncurry wrk) where

154− wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan, Maybe Type)

250+ wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan)

155251 wrk modName = \case

156252 Nothing -> Nothing

157− Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName, Nothing)

253+ Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName)

158254

159255 -- TODO make this point to the module name

160256 fpToSpanSource :: FilePath -> SpanSource

161257 fpToSpanSource fp = SpanS $ RealSrcSpan $ zeroSpan $ mkFastString fp

162258

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−

176259-- | Pretty print the types into a 'SpanInfo'.

177−toSpanInfo :: (SpanSource, SrcSpan, Maybe Type) -> Maybe SpanInfo

178−toSpanInfo (name,mspan,typ) =

260+toSpanInfo :: (SpanSource, SrcSpan, Maybe Type, SpanDoc) -> Maybe SpanInfo

261+toSpanInfo (name,mspan,typ,docs) =

179262 case mspan of

180263 RealSrcSpan spn ->

181264 -- GHC’s line and column numbers are 1-based while LSP’s line and column

@@ -185,5 +268,6 @@ toSpanInfo (name,mspan,typ) =

185268 (srcSpanEndLine spn - 1)

186269 (srcSpanEndCol spn - 1)

187270 typ

188− name)

271+ name

272+ docs)

189273 _ -> Nothing

src/Development/IDE/Spans/Common.hsnew file+162

@@ -0,0 +1,162 @@

1+{-# LANGUAGE CPP #-}

2+#include "ghc-api-version.h"

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+40−17

@@ -1,8 +1,12 @@

22-- SPDX-License-Identifier: Apache-2.0

4+{-# LANGUAGE CPP #-}

5+#include "ghc-api-version.h"

47module Development.IDE.Spans.Documentation (

58 getDocumentation

9+ , getDocumentationTryGhc

610 ) where

711

812import Control.Monad

@@ -10,15 +14,33 @@ import Data.List.Extra

1014import qualified Data.Map as M

1115import Data.Maybe

1216import qualified Data.Text as T

17+import Development.IDE.GHC.Compat

1318import Development.IDE.GHC.Error

14−import Development.IDE.Spans.Calculate

19+import Development.IDE.Spans.Common

1520import FastString

16−import GHC

1721import SrcLoc

1822

1923

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+

2042getDocumentation

21− :: [TypecheckedModule] -- ^ All of the possible modules it could be defined in.

43+ :: [ParsedModule] -- ^ All of the possible modules it could be defined in.

2244 -> Name -- ^ The name you want documentation for.

2345 -> [T.Text]

2446-- This finds any documentation between the name you want

@@ -28,17 +50,18 @@ getDocumentation

2850-- may be edge cases where it is very wrong).

2951-- TODO : Build a version of GHC exactprint to extract this information

3052-- more accurately.

31−getDocumentation tcs targetName = fromMaybe [] $ do

53+getDocumentation sources targetName = fromMaybe [] $ do

3254 -- Find the module the target is defined in.

3355 targetNameSpan <- realSpan $ nameSrcSpan targetName

3456 tc <-

35− listToMaybe

36− $ filter ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)

37− $ reverse tcs -- TODO : Is reversing the list here really neccessary?

38− -- Names bound by the module (we want to exclude non-"top-level"

39− -- bindings but unfortunately we get all here).

40− let bs = mapMaybe name_of_bind

41− (listifyAllSpans (tm_typechecked_source tc) :: [LHsBind GhcTc])

57+ find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)

58+ $ reverse sources -- TODO : Is reversing the list here really neccessary?

59+

60+ -- Top level names bound by the module

61+ let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc

62+ , L _ (ValD hsbind) <- hsmodDecls

63+ , Just n <- [name_of_bind hsbind]

64+ ]

4265 -- Sort the names' source spans.

4366 let sortedSpans = sortedNameSpans bs

4467 -- Now go ahead and extract the docs.

@@ -60,16 +83,16 @@ getDocumentation tcs targetName = fromMaybe [] $ do

6083 where

6184 -- Get the name bound by a binding. We only concern ourselves with

6285 -- @FunBind@ (which covers functions and variables).

63− name_of_bind :: LHsBind GhcTc -> Maybe Name

64− name_of_bind (L _ FunBind {fun_id}) = Just (getName (unLoc fun_id))

86+ name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)

87+ name_of_bind FunBind {fun_id} = Just fun_id

6588 name_of_bind _ = Nothing

6689 -- Get source spans from names, discard unhelpful spans, remove

6790 -- duplicates and sort.

68− sortedNameSpans :: [Name] -> [RealSrcSpan]

69− sortedNameSpans ls = nubSort (mapMaybe (realSpan . nameSrcSpan) ls)

91+ sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]

92+ sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)

7093 isBetween target before after = before <= target && target <= after

71− ann = snd . pm_annotations . tm_parsed_module

72− annotationFileName :: TypecheckedModule -> Maybe FastString

94+ ann = snd . pm_annotations

95+ annotationFileName :: ParsedModule -> Maybe FastString

7396 annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann

7497 realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]

7598 realSpans =

src/Development/IDE/Spans/Type.hs+19−4

@@ -6,7 +6,8 @@

66-- | Types used separate to GHCi vanilla.

88module Development.IDE.Spans.Type(

9− SpanInfo(..)

9+ SpansInfo(..)

10+ , SpanInfo(..)

1011 , SpanSource(..)

1112 , getNameM

1213 ) where

@@ -15,6 +16,15 @@ import GHC

1516import Control.DeepSeq

1617import OccName

1718import 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

1828

1929-- | Type of some span of source code. Most of these fields are

2030-- unboxed but Haddock doesn't show that.

@@ -34,11 +44,14 @@ data SpanInfo =

3444 -- any. This can be useful for accessing a variety of

3545 -- information about the identifier such as module,

3646 -- locality, definition location, etc.

47+ ,spaninfoDocs :: !SpanDoc

48+ -- ^ Documentation for the element

3749 }

3850instance Show SpanInfo where

39− show (SpanInfo sl sc el ec t n) =

51+ show (SpanInfo sl sc el ec t n docs) =

4052 unwords ["(SpanInfo", show sl, show sc, show el, show ec

41− , show $ maybe "NoType" prettyPrint t, "(" <> show n <> "))"]

53+ , show $ maybe "NoType" prettyPrint t, "(" <> show n <> "))"

54+ , "docs(" <> show docs <> ")"]

4255

4356instance NFData SpanInfo where

4457 rnf = rwhnf

@@ -47,6 +60,7 @@ instance NFData SpanInfo where

4760-- we don't always get a name out so sometimes manually annotating source is more appropriate

4861data SpanSource = Named Name

4962 | SpanS SrcSpan

63+ | Lit String

5064 | NoSource

5165 deriving (Eq)

5266

@@ -54,9 +68,10 @@ instance Show SpanSource where

5468 show = \case

5569 Named n -> "Named " ++ occNameString (occName n)

5670 SpanS sp -> "Span " ++ show sp

71+ Lit lit -> "Lit " ++ lit

5772 NoSource -> "NoSource"

5873

5974getNameM :: SpanSource -> Maybe Name

6075getNameM = \case

6176 Named name -> Just name

62− _ -> Nothing

77+ _ -> Nothing

src/Development/IDE/Types/Diagnostics.hs+19−5

@@ -6,10 +6,12 @@ module Development.IDE.Types.Diagnostics (

66 LSP.Diagnostic(..),

77 ShowDiagnostic(..),

88 FileDiagnostic,

9+ IdeResult,

910 LSP.DiagnosticSeverity(..),

1011 DiagnosticStore,

1112 List(..),

1213 ideErrorText,

14+ ideErrorWithSource,

1315 showDiagnostics,

1416 showDiagnosticsColored,

1517 ) where

@@ -18,7 +20,7 @@ import Control.DeepSeq

1820import Data.Maybe as Maybe

1921import qualified Data.Text as T

2022import Data.Text.Prettyprint.Doc

21−import Language.Haskell.LSP.Types as LSP (

23+import Language.Haskell.LSP.Types as LSP (DiagnosticSource,

2224 DiagnosticSeverity(..)

2325 , Diagnostic(..)

2426 , List(..)

@@ -30,15 +32,27 @@ import Data.Text.Prettyprint.Doc.Render.Terminal (Color(..), color)

3032

3133import Development.IDE.Types.Location

3234

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)

3338

3439ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic

35−ideErrorText fp msg = (fp, ShowDiag, LSP.Diagnostic {

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 {

3649 _range = noRange,

37− _severity = Just LSP.DsError,

50+ _severity = sev,

3851 _code = Nothing,

39− _source = Just "compiler",

52+ _source = source,

4053 _message = msg,

41− _relatedInformation = Nothing

54+ _relatedInformation = Nothing,

55+ _tags = Nothing

4256 })

4357

4458-- | Defines whether a particular diagnostic should be reported

src/Development/IDE/Types/Location.hs+67−39

@@ -10,67 +10,59 @@ module Development.IDE.Types.Location

1010 , Position(..)

1111 , showPosition

1212 , Range(..)

13− , Uri(..)

14− , NormalizedUri

13+ , LSP.Uri(..)

14+ , LSP.NormalizedUri

1515 , LSP.toNormalizedUri

1616 , LSP.fromNormalizedUri

17− , NormalizedFilePath

17+ , LSP.NormalizedFilePath

1818 , fromUri

19− , toNormalizedFilePath

20− , fromNormalizedFilePath

21− , filePathToUri

19+ , emptyFilePath

20+ , emptyPathUri

21+ , toNormalizedFilePath'

22+ , LSP.fromNormalizedFilePath

2223 , filePathToUri'

2324 , uriToFilePath'

25+ , readSrcSpan

2426 ) where

2527

28+import Control.Applicative

2629import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..))

27−import Control.DeepSeq

28−import Data.Binary

29−import Data.Maybe as Maybe

30−import Data.Hashable

30+import Control.Monad

31+import Data.Hashable (Hashable(hash))

3132import Data.String

32−import System.FilePath

33+import FastString

3334import qualified Language.Haskell.LSP.Types as LSP

34−import Language.Haskell.LSP.Types as LSP (

35− filePathToUri

36− , NormalizedUri(..)

37− , Uri(..)

38− , toNormalizedUri

39− , fromNormalizedUri

40− )

35+import SrcLoc as GHC

36+import Text.ParserCombinators.ReadP as ReadP

37+import Data.Maybe (fromMaybe)

4138

42−

43−-- | Newtype wrapper around FilePath that always has normalized slashes.

44−newtype NormalizedFilePath = NormalizedFilePath FilePath

45− deriving (Eq, Ord, Show, Hashable, NFData, Binary)

46−

47−instance IsString NormalizedFilePath where

48− fromString = toNormalizedFilePath

49−

50−toNormalizedFilePath :: FilePath -> NormalizedFilePath

39+toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath

5140-- We want to keep empty paths instead of normalising them to "."

52−toNormalizedFilePath "" = NormalizedFilePath ""

53−toNormalizedFilePath fp = NormalizedFilePath $ normalise fp

41+toNormalizedFilePath' "" = emptyFilePath

42+toNormalizedFilePath' fp = LSP.toNormalizedFilePath fp

5443

55−fromNormalizedFilePath :: NormalizedFilePath -> FilePath

56−fromNormalizedFilePath (NormalizedFilePath fp) = fp

44+emptyFilePath :: LSP.NormalizedFilePath

45+emptyFilePath = LSP.NormalizedFilePath emptyPathUri ""

5746

5847-- | We use an empty string as a filepath when we don’t have a file.

5948-- However, haskell-lsp doesn’t support that in uriToFilePath and given

6049-- that it is not a valid filepath it does not make sense to upstream a fix.

6150-- So we have our own wrapper here that supports empty filepaths.

62−uriToFilePath' :: Uri -> Maybe FilePath

51+uriToFilePath' :: LSP.Uri -> Maybe FilePath

6352uriToFilePath' uri

64− | uri == filePathToUri "" = Just ""

53+ | uri == LSP.fromNormalizedUri emptyPathUri = Just ""

6554 | otherwise = LSP.uriToFilePath uri

6655

67−filePathToUri' :: NormalizedFilePath -> NormalizedUri

68−filePathToUri' = toNormalizedUri . filePathToUri . fromNormalizedFilePath

56+emptyPathUri :: LSP.NormalizedUri

57+emptyPathUri =

58+ let s = "file://"

59+ in LSP.NormalizedUri (hash s) s

6960

61+filePathToUri' :: LSP.NormalizedFilePath -> LSP.NormalizedUri

62+filePathToUri' = LSP.normalizedFilePathToUri

7063

71−fromUri :: LSP.NormalizedUri -> NormalizedFilePath

72−fromUri = toNormalizedFilePath . fromMaybe noFilePath . uriToFilePath' . fromNormalizedUri

73−

64+fromUri :: LSP.NormalizedUri -> LSP.NormalizedFilePath

65+fromUri = fromMaybe (toNormalizedFilePath' noFilePath) . LSP.uriToNormalizedFilePath

7466

7567noFilePath :: FilePath

7668noFilePath = "<unknown>"

@@ -79,6 +71,42 @@ noFilePath = "<unknown>"

7971noRange :: Range

8072noRange = Range (Position 0 0) (Position 100000 0)

8173

82−

8374showPosition :: Position -> String

8475showPosition 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+35−8

@@ -12,25 +12,25 @@ module Development.IDE.Types.Options

1212 , clientSupportsProgress

1313 , IdePkgLocationOptions(..)

1414 , defaultIdeOptions

15+ , IdeResult

1516 ) where

1617

17−import Data.Maybe

1818import Development.Shake

1919import Development.IDE.GHC.Util

2020import GHC hiding (parseModule, typecheckModule)

2121import GhcPlugins as GHC hiding (fst3, (<>))

2222import qualified Language.Haskell.LSP.Types.Capabilities as LSP

23+import qualified Data.Text as T

24+import Development.IDE.Types.Diagnostics

2325

2426data IdeOptions = IdeOptions

2527 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource

2628 -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings

2729 -- and a list of errors, along with a new parse tree.

28− , optGhcSession :: IO (FilePath -> Action HscEnvEq)

30+ , optGhcSession :: Action (FilePath -> Action (IdeResult HscEnvEq))

2931 -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.

30− -- The 'IO' will be called once, then the resulting function will be applied once per file.

32+ -- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.

3133 -- 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.

3434 , optPkgLocationOpts :: IdePkgLocationOptions

3535 -- ^ How to locate source and @.hie@ files given a module name.

3636 , optExtensions :: [String]

@@ -43,12 +43,17 @@ data IdeOptions = IdeOptions

4343 -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds.

4444 , optShakeProfiling :: Maybe FilePath

4545 -- ^ 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

4648 , optReportProgress :: IdeReportProgress

4749 -- ^ Whether to report progress during long operations.

4850 , optLanguageSyntax :: String

4951 -- ^ the ```language to use

5052 , optNewColonConvention :: Bool

5153 -- ^ 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.

5257 , optDefer :: IdeDefer

5358 -- ^ Whether to defer type errors, typed holes and out of scope

5459 -- variables. Deferral allows the IDE to continue to provide

@@ -70,10 +75,10 @@ newtype IdeReportProgress = IdeReportProgress Bool

7075newtype IdeDefer = IdeDefer Bool

7176

7277clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress

73−clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $

74− LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)

78+clientSupportsProgress caps = IdeReportProgress $ Just True ==

79+ (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))

7580

76−defaultIdeOptions :: IO (FilePath -> Action HscEnvEq) -> IdeOptions

81+defaultIdeOptions :: Action (FilePath -> Action (IdeResult HscEnvEq)) -> IdeOptions

7782defaultIdeOptions session = IdeOptions

7883 {optPreprocessor = IdePreprocessedSource [] []

7984 ,optGhcSession = session

@@ -85,7 +90,9 @@ defaultIdeOptions session = IdeOptions

8590 ,optReportProgress = IdeReportProgress False

8691 ,optLanguageSyntax = "haskell"

8792 ,optNewColonConvention = False

93+ ,optKeywords = haskellKeywords

8894 ,optDefer = IdeDefer True

95+ ,optTesting = False

8996 }

9097

9198

@@ -103,3 +110,23 @@ data IdePkgLocationOptions = IdePkgLocationOptions

103110defaultIdePkgLocationOptions :: IdePkgLocationOptions

104111defaultIdePkgLocationOptions = IdePkgLocationOptions f f

105112 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+10−4

@@ -2,12 +2,18 @@ resolver: nightly-2019-09-16

22packages:

33- .

44extra-deps:

5−- haskell-lsp-0.19.0.0

6−- haskell-lsp-types-0.19.0.0

7−- lsp-test-0.9.0.0

8−- hie-bios-0.3.0

5+- haskell-lsp-0.22.0.0

6+- haskell-lsp-types-0.22.0.0

7+- lsp-test-0.10.3.0

8+- hie-bios-0.5.0

99- ghc-lib-parser-8.8.1

1010- ghc-lib-8.8.1

11+- fuzzy-0.1.0.0

12+- shake-0.18.5

13+- regex-base-0.94.0.0

14+- regex-tdfa-1.3.1.0

15+- haddock-library-1.8.0

16+- ghc-check-0.3.0.1

1117nix:

1218 packages: [zlib]

1319flags:

stack.yaml+14−5

@@ -1,10 +1,19 @@

1−resolver: nightly-2019-09-16

1+resolver: nightly-2019-09-21

22packages:

33- .

44extra-deps:

5−- haskell-lsp-0.19.0.0

6−- haskell-lsp-types-0.19.0.0

7−- lsp-test-0.9.0.0

8−- hie-bios-0.3.0

5+- haskell-lsp-0.22.0.0

6+- haskell-lsp-types-0.22.0.0

7+- lsp-test-0.11.0.1

8+- hie-bios-0.5.0

9+- fuzzy-0.1.0.0

10+- regex-pcre-builtin-0.95.1.1.8.43

11+- regex-base-0.94.0.0

12+- regex-tdfa-1.3.1.0

13+- shake-0.18.5

14+- parser-combinators-1.2.1

15+- haddock-library-1.8.0

16+- tasty-rerun-1.1.17

17+- ghc-check-0.3.0.1

918nix:

1019 packages: [zlib]

stack810.yamlnew file+18

@@ -0,0 +1,18 @@

1+resolver: nightly-2020-02-13

2+compiler: ghc-8.10.1

3+allow-newer: true

4+packages:

5+- .

6+extra-deps:

7+- haskell-lsp-0.22.0.0

8+- haskell-lsp-types-0.22.0.0

9+- lsp-test-0.11.0.1

10+- ghc-check-0.3.0.1

11+- hie-bios-0.5.0

12+

13+# for ghc-8.10

14+- Cabal-3.2.0.0

15+- lens-4.19.1

16+

17+nix:

18+ packages: [zlib]

stack84.yaml+23−6

@@ -3,14 +3,31 @@ packages:

33- .

55extra-deps:

6−- haskell-lsp-0.19.0.0

7−- haskell-lsp-types-0.19.0.0

8−- lsp-test-0.9.0.0

6+- aeson-1.4.6.0

7+- base-orphans-0.8.2

8+- haskell-lsp-0.22.0.0

9+- haskell-lsp-types-0.22.0.0

10+- lsp-test-0.11.0.1

911- rope-utf16-splay-0.3.1.0

10−- shake-0.18.3

1112- filepattern-0.1.1

1213- js-dgtable-0.5.2

13−- hie-bios-0.3.0

14+- hie-bios-0.5.0

15+- fuzzy-0.1.0.0

16+- shake-0.18.5

17+- time-compat-1.9.2.2

18+- regex-base-0.94.0.0

19+- regex-tdfa-1.3.1.0

20+- parser-combinators-1.2.1

21+- haddock-library-1.8.0

22+- unordered-containers-0.2.10.0

23+- file-embed-0.0.11.2

24+- heaps-0.3.6.1

25+- ghc-check-0.3.0.1

26+# For tasty-retun

27+- ansi-terminal-0.10.3

28+- ansi-wl-pprint-0.6.9

29+- tasty-1.2.3

30+- tasty-rerun-1.1.17

31+

1432nix:

1533 packages: [zlib]

16−allow-newer: true

stack88.yaml+6−6

@@ -1,11 +1,11 @@

1−resolver: nightly-2019-12-06

1+resolver: nightly-2020-02-13

22packages:

33- .

44extra-deps:

5−- haskell-lsp-0.19.0.0

6−- haskell-lsp-types-0.19.0.0

7−- lsp-test-0.9.0.0

8−- hie-bios-0.3.0

9−allow-newer: true

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

1010nix:

1111 packages: [zlib]

test/data/hover/Bar.hsnew file+3

@@ -0,0 +1,3 @@

1+module Bar (Bar(..)) where

3+data Bar = Bar

test/data/hover/Foo.hsnew file+5

@@ -0,0 +1,5 @@

1+module Foo (Bar, foo) where

3+import Bar

5+foo = Bar

test/data/GotoHover.hs → test/data/hover/GotoHover.hsrenamed+21−6

@@ -1,16 +1,20 @@

1+{-# LANGUAGE OverloadedStrings #-}

12{- HLINT ignore -}

23module Testing ( module Testing ) where

34import Data.Text (Text, pack)

5+import Foo (Bar, foo)

48data TypeConstructor = DataConstructor

59 { fff :: Text

610 , ggg :: Int }

711aaa :: TypeConstructor

812aaa = DataConstructor

9− { fff = ""

10− , ggg = 0

13+ { fff = "dfgy"

14+ , ggg = 832

1115 }

1216bbb :: TypeConstructor

13−bbb = DataConstructor "" 0

17+bbb = DataConstructor "mjgp" 2994

1418ccc :: (Text, Int)

1519ccc = (fff bbb, ggg aaa)

1620ddd :: Num a => a -> a -> a

@@ -31,12 +35,23 @@ doBind = do unwrapped <- Just ()

3135 return unwrapped

3236

3337listCompBind :: [Char]

34−listCompBind = [ succ c | c <- "abc" ]

38+listCompBind = [ succ c | c <- "ptfx" ]

3539

3640multipleClause :: Bool -> Char

37−multipleClause True = 't'

41+multipleClause True = 't'

3842multipleClause False = 'f'

3943

4044-- | Recognizable docs: kpqz

4145documented :: Monad m => Either Int (m a)

42−documented = Left 3

46+documented = Left 7518

47+

48+listOfInt = [ 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/multi/a/A.hsnew file+3

@@ -0,0 +1,3 @@

1+module A(foo) where

3+foo = ()

test/data/multi/a/a.cabalnew file+9

@@ -0,0 +1,9 @@

1+name: a

2+version: 1.0.0

3+build-type: Simple

4+cabal-version: >= 1.2

6+library

7+ build-depends: base

8+ exposed-modules: A

9+ hs-source-dirs: .

test/data/multi/b/B.hsnew file+3

@@ -0,0 +1,3 @@

1+module B(module B) where

2+import A

3+qux = foo

test/data/multi/b/b.cabalnew file+9

@@ -0,0 +1,9 @@

1+name: b

2+version: 1.0.0

3+build-type: Simple

4+cabal-version: >= 1.2

6+library

7+ build-depends: base, a

8+ exposed-modules: B

9+ hs-source-dirs: .

test/data/multi/cabal.projectnew file+1

@@ -0,0 +1 @@

1+packages: a b

test/data/multi/hie.yamlnew file+6

@@ -0,0 +1,6 @@

1+cradle:

2+ cabal:

3+ - path: "./a"

4+ component: "lib:a"

5+ - path: "./b"

6+ component: "lib:b"

test/exe/Main.hs+1697−199

@@ -1,49 +1,83 @@

22-- SPDX-License-Identifier: Apache-2.0

4+{-# LANGUAGE AllowAmbiguousTypes #-}

45{-# LANGUAGE DuplicateRecordFields #-}

6+{-# LANGUAGE PatternSynonyms #-}

57{-# LANGUAGE CPP #-}

68#include "ghc-api-version.h"

810module Main (main) where

911

1012import Control.Applicative.Combinators

13+import Control.Exception (bracket, catch)

14+import qualified Control.Lens as Lens

1115import Control.Monad

1216import Control.Monad.IO.Class (liftIO)

13−import Data.Char (toLower)

17+import Data.Aeson (FromJSON, Value)

1418import 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)

1523import Development.IDE.GHC.Util

1624import qualified Data.Text as T

25+import Data.Typeable

26+import Development.IDE.Spans.Common

1727import Development.IDE.Test

1828import Development.IDE.Test.Runfiles

29+import Development.IDE.Types.Location

30+import Development.Shake (getDirectoryFilesIO)

1931import Language.Haskell.LSP.Test

32+import Language.Haskell.LSP.Messages

2033import Language.Haskell.LSP.Types

2134import Language.Haskell.LSP.Types.Capabilities

22−import System.Environment.Blank (setEnv)

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)

2339import System.FilePath

2440import System.IO.Extra

2541import System.Directory

42+import Test.QuickCheck

43+import Test.QuickCheck.Instances ()

2644import Test.Tasty

27−import Test.Tasty.HUnit

2845import Test.Tasty.ExpectedFailure

46+import Test.Tasty.Ingredients.Rerun

47+import Test.Tasty.HUnit

48+import Test.Tasty.QuickCheck

2949import Data.Maybe

3050

3151main :: IO ()

32−main = defaultMain $ testGroup "HIE"

33− [ testSession "open close" $ do

34− doc <- openDoc' "Testing.hs" "haskell" ""

35− void (message :: Session WorkDoneProgressCreateRequest)

36− void (message :: Session WorkDoneProgressBeginNotification)

37− closeDoc doc

38− void (message :: Session WorkDoneProgressEndNotification)

39− , initializeResponseTests

40− , diagnosticTests

41− , codeActionTests

42− , codeLensesTests

43− , findDefinitionAndHoverTests

44− , pluginTests

45− , thTests

46− ]

52+main = do

53+ -- We mess with env vars so run single-threaded.

54+ setEnv "TASTY_NUM_THREADS" "1" True

55+ defaultMainWithRerun $ testGroup "HIE"

56+ [ testSession "open close" $ do

57+ doc <- createDoc "Testing.hs" "haskell" ""

58+ void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)

59+ void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)

60+ closeDoc doc

61+ void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)

62+ , initializeResponseTests

63+ , completionTests

64+ , cppTests

65+ , diagnosticTests

66+ , codeActionTests

67+ , codeLensesTests

68+ , outlineTests

69+ , findDefinitionAndHoverTests

70+ , pluginTests

71+ , preprocessorTests

72+ , thTests

73+ , safeTests

74+ , unitTests

75+ , haddockTests

76+ , positionMappingTests

77+ , watchedFilesTests

78+ , cradleTests

79+ , dependentFileTest

80+ ]

4781

4882initializeResponseTests :: TestTree

4983initializeResponseTests = withResource acquire release tests where

@@ -58,14 +92,14 @@ initializeResponseTests = withResource acquire release tests where

5892 testGroup "initialize response capabilities"

5993 [ chk " text doc sync" _textDocumentSync tds

6094 , chk " hover" _hoverProvider (Just True)

61− , chk "NO completion" _completionProvider Nothing

95+ , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing)

6296 , chk "NO signature help" _signatureHelpProvider Nothing

6397 , chk " goto definition" _definitionProvider (Just True)

6498 , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)

6599 , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic False)

66100 , chk "NO find references" _referencesProvider Nothing

67101 , chk "NO doc highlight" _documentHighlightProvider Nothing

68− , chk "NO doc symbol" _documentSymbolProvider Nothing

102+ , chk " doc symbol" _documentSymbolProvider (Just True)

69103 , chk "NO workspace symbol" _workspaceSymbolProvider Nothing

70104 , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True

71105 , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing

@@ -78,8 +112,8 @@ initializeResponseTests = withResource acquire release tests where

78112 , chk "NO doc link" _documentLinkProvider Nothing

79113 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)

80114 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)

81− , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

82− , chk "NO workspace" _workspace nothingWorkspace

115+ , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

116+ , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))

83117 , chk "NO experimental" _experimental Nothing

84118 ] where

85119

@@ -90,14 +124,21 @@ initializeResponseTests = withResource acquire release tests where

90124 , _willSaveWaitUntil = Nothing

91125 , _save = Just (SaveOptions {_includeText = Nothing})}))

92126

93− nothingWorkspace = Just (WorkspaceOptions {_workspaceFolders = Nothing})

94−

95127 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree

96128 chk title getActual expected =

97129 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir

98130

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+

99140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner

100− innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c

141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c

101142 innerCaps _ = error "this test only expects inner capabilities"

102143

103144 acquire :: IO InitializeResponse

@@ -111,7 +152,7 @@ diagnosticTests :: TestTree

111152diagnosticTests = testGroup "diagnostics"

112153 [ testSessionWait "fix syntax error" $ do

113154 let content = T.unlines [ "module Testing wher" ]

114− doc <- openDoc' "Testing.hs" "haskell" content

155+ doc <- createDoc "Testing.hs" "haskell" content

115156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]

116157 let change = TextDocumentContentChangeEvent

117158 { _range = Just (Range (Position 0 15) (Position 0 19))

@@ -122,9 +163,9 @@ diagnosticTests = testGroup "diagnostics"

122163 expectDiagnostics [("Testing.hs", [])]

123164 , testSessionWait "introduce syntax error" $ do

124165 let content = T.unlines [ "module Testing where" ]

125− doc <- openDoc' "Testing.hs" "haskell" content

126− void (message :: Session WorkDoneProgressCreateRequest)

127− void (message :: Session WorkDoneProgressBeginNotification)

166+ doc <- createDoc "Testing.hs" "haskell" content

167+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)

168+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)

128169 let change = TextDocumentContentChangeEvent

129170 { _range = Just (Range (Position 0 15) (Position 0 18))

130171 , _rangeLength = Nothing

@@ -140,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"

140181 , "bar :: Int -> Int -> Int"

141182 , "bar a b = cd + b"

142183 ]

143− _ <- openDoc' "Testing.hs" "haskell" content

184+ _ <- createDoc "Testing.hs" "haskell" content

144185 expectDiagnostics

145186 [ ( "Testing.hs"

146187 , [ (DsError, (2, 14), "Variable not in scope: ab")

@@ -154,7 +195,7 @@ diagnosticTests = testGroup "diagnostics"

154195 , "foo :: Int -> String -> Int"

155196 , "foo a b = a + b"

156197 ]

157− _ <- openDoc' "Testing.hs" "haskell" content

198+ _ <- createDoc "Testing.hs" "haskell" content

158199 expectDiagnostics

159200 [ ( "Testing.hs"

160201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]

@@ -166,7 +207,7 @@ diagnosticTests = testGroup "diagnostics"

166207 , "foo :: Int -> String"

167208 , "foo a = _ a"

168209 ]

169− _ <- openDoc' "Testing.hs" "haskell" content

210+ _ <- createDoc "Testing.hs" "haskell" content

170211 expectDiagnostics

171212 [ ( "Testing.hs"

172213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]

@@ -188,24 +229,23 @@ diagnosticTests = testGroup "diagnostics"

188229 [ ("A.hs", [(DsError, (2,4), aMessage)])

189230 , ("B.hs", [(DsError, (3,4), bMessage)])]

190231 deferralTest title binding msg = testSessionWait title $ do

191− _ <- openDoc' "A.hs" "haskell" $ sourceA binding

192− _ <- openDoc' "B.hs" "haskell" sourceB

232+ _ <- createDoc "A.hs" "haskell" $ sourceA binding

233+ _ <- createDoc "B.hs" "haskell" sourceB

193234 expectDiagnostics $ expectedDs msg

194235 in

195236 [ deferralTest "type error" "True" "Couldn't match expected type"

196237 , deferralTest "typed hole" "_" "Found hole"

197238 , deferralTest "out of scope var" "unbound" "Variable not in scope"

198− , deferralTest "message shows error" "True" "A.hs:3:5: error:"

199239 ]

200240

201241 , testSessionWait "remove required module" $ do

202242 let contentA = T.unlines [ "module ModuleA where" ]

203− docA <- openDoc' "ModuleA.hs" "haskell" contentA

243+ docA <- createDoc "ModuleA.hs" "haskell" contentA

204244 let contentB = T.unlines

205245 [ "module ModuleB where"

206246 , "import ModuleA"

207247 ]

208− _ <- openDoc' "ModuleB.hs" "haskell" contentB

248+ _ <- createDoc "ModuleB.hs" "haskell" contentB

209249 let change = TextDocumentContentChangeEvent

210250 { _range = Just (Range (Position 0 0) (Position 0 20))

211251 , _rangeLength = Nothing

@@ -218,11 +258,21 @@ diagnosticTests = testGroup "diagnostics"

218258 [ "module ModuleB where"

219259 , "import ModuleA"

220260 ]

221− _ <- openDoc' "ModuleB.hs" "haskell" contentB

261+ _ <- createDoc "ModuleB.hs" "haskell" contentB

222262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

223263 let contentA = T.unlines [ "module ModuleA where" ]

224− _ <- openDoc' "ModuleA.hs" "haskell" contentA

264+ _ <- createDoc "ModuleA.hs" "haskell" contentA

225265 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", [])]

226276 , testSessionWait "cyclic module dependency" $ do

227277 let contentA = T.unlines

228278 [ "module ModuleA where"

@@ -232,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"

232282 [ "module ModuleB where"

233283 , "import ModuleA"

234284 ]

235− _ <- openDoc' "ModuleA.hs" "haskell" contentA

236− _ <- openDoc' "ModuleB.hs" "haskell" contentB

285+ _ <- createDoc "ModuleA.hs" "haskell" contentA

286+ _ <- createDoc "ModuleB.hs" "haskell" contentB

237287 expectDiagnostics

238288 [ ( "ModuleA.hs"

239289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]

@@ -254,9 +304,9 @@ diagnosticTests = testGroup "diagnostics"

254304 let contentBboot = T.unlines

255305 [ "module ModuleB where"

256306 ]

257− _ <- openDoc' "ModuleA.hs" "haskell" contentA

258− _ <- openDoc' "ModuleB.hs" "haskell" contentB

259− _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot

307+ _ <- createDoc "ModuleA.hs" "haskell" contentA

308+ _ <- createDoc "ModuleB.hs" "haskell" contentB

309+ _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot

260310 expectDiagnostics []

261311 , testSessionWait "correct reference used with hs-boot" $ do

262312 let contentB = T.unlines

@@ -278,10 +328,10 @@ diagnosticTests = testGroup "diagnostics"

278328 -- resolved to the hs-boot file

279329 , "y = x"

280330 ]

281− _ <- openDoc' "ModuleB.hs" "haskell" contentB

282− _ <- openDoc' "ModuleA.hs" "haskell" contentA

283− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot

284− _ <- openDoc' "ModuleC.hs" "haskell" contentC

331+ _ <- createDoc "ModuleB.hs" "haskell" contentB

332+ _ <- createDoc "ModuleA.hs" "haskell" contentA

333+ _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot

334+ _ <- createDoc "ModuleC.hs" "haskell" contentC

285335 expectDiagnostics []

286336 , testSessionWait "redundant import" $ do

287337 let contentA = T.unlines ["module ModuleA where"]

@@ -290,8 +340,8 @@ diagnosticTests = testGroup "diagnostics"

290340 , "module ModuleB where"

291341 , "import ModuleA"

292342 ]

293− _ <- openDoc' "ModuleA.hs" "haskell" contentA

294− _ <- openDoc' "ModuleB.hs" "haskell" contentB

343+ _ <- createDoc "ModuleA.hs" "haskell" contentA

344+ _ <- createDoc "ModuleB.hs" "haskell" contentB

295345 expectDiagnostics

296346 [ ( "ModuleB.hs"

297347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]

@@ -313,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"

313363 , "wrong1 = ThisList.map"

314364 , "wrong2 = BaseList.x"

315365 ]

316− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent

317− _ <- openDoc' "Main.hs" "haskell" mainContent

366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent

367+ _ <- createDoc "Main.hs" "haskell" mainContent

318368 expectDiagnostics

319369 [ ( "Main.hs"

320370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")

@@ -329,7 +379,7 @@ diagnosticTests = testGroup "diagnostics"

329379 , "foo :: Ord a => a -> Int"

330380 , "foo a = 1"

331381 ]

332− _ <- openDoc' "Foo.hs" "haskell" fooContent

382+ _ <- createDoc "Foo.hs" "haskell" fooContent

333383 expectDiagnostics

334384 [ ( "Foo.hs"

335385 -- The test is to make sure that warnings contain unqualified names

@@ -354,18 +404,18 @@ diagnosticTests = testGroup "diagnostics"

354404 Just pathB <- pure $ uriToFilePath uriB

355405 uriB <- pure $

356406 let (drive, suffix) = splitDrive pathB

357− in filePathToUri (joinDrive (map toLower drive ) suffix)

407+ in filePathToUri (joinDrive (lower drive) suffix)

358408 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)

359409 liftIO $ writeFileUTF8 pathB $ T.unpack bContent

360410 uriA <- getDocUri "A/A.hs"

361411 Just pathA <- pure $ uriToFilePath uriA

362412 uriA <- pure $

363413 let (drive, suffix) = splitDrive pathA

364− in filePathToUri (joinDrive (map toLower drive ) suffix)

414+ in filePathToUri (joinDrive (lower drive) suffix)

365415 let itemA = TextDocumentItem uriA "haskell" 0 aContent

366416 let a = TextDocumentIdentifier uriA

367417 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)

368− diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification

418+ diagsNot <- skipManyTill anyMessage diagnostic

369419 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)

370420 -- Check that if we put a lower-case drive in for A.A

371421 -- the diagnostics for A.B will also be lower-case.

@@ -374,6 +424,38 @@ diagnosticTests = testGroup "diagnostics"

374424 liftIO $ unless ("redundant" `T.isInfixOf` msg) $

375425 assertFailure ("Expected redundant import but got " <> T.unpack msg)

376426 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

377459 ]

378460

379461codeActionTests :: TestTree

@@ -381,9 +463,14 @@ codeActionTests = testGroup "code actions"

381463 [ renameActionTests

382464 , typeWildCardActionTests

383465 , removeImportTests

466+ , extendImportTests

467+ , suggestImportTests

468+ , addExtensionTests

469+ , fixConstructorImportTests

384470 , importRenameActionTests

385471 , fillTypedHoleTests

386472 , addSigActionTests

473+ , insertNewDefinitionTests

387474 ]

388475

389476codeLensesTests :: TestTree

@@ -391,6 +478,33 @@ codeLensesTests = testGroup "code lenses"

391478 [ addSigLensesTests

392479 ]

393480

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+

394508renameActionTests :: TestTree

395509renameActionTests = testGroup "rename actions"

396510 [ testSession "change to local variable name" $ do

@@ -399,11 +513,9 @@ renameActionTests = testGroup "rename actions"

399513 , "foo :: Int -> Int"

400514 , "foo argName = argNme"

401515 ]

402− doc <- openDoc' "Testing.hs" "haskell" content

516+ doc <- createDoc "Testing.hs" "haskell" content

403517 _ <- waitForDiagnostics

404− [CACodeAction action@CodeAction { _title = actionTitle }]

405− <- getCodeActions doc (Range (Position 2 14) (Position 2 20))

406− liftIO $ "Replace with ‘argName’" @=? actionTitle

518+ action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"

407519 executeCodeAction action

408520 contentAfterAction <- documentContents doc

409521 let expectedContentAfterAction = T.unlines

@@ -419,11 +531,9 @@ renameActionTests = testGroup "rename actions"

419531 , "foo :: Maybe a -> [a]"

420532 , "foo = maybToList"

421533 ]

422− doc <- openDoc' "Testing.hs" "haskell" content

534+ doc <- createDoc "Testing.hs" "haskell" content

423535 _ <- waitForDiagnostics

424− [CACodeAction action@CodeAction { _title = actionTitle }]

425− <- getCodeActions doc (Range (Position 3 6) (Position 3 16))

426− liftIO $ "Replace with ‘maybeToList’" @=? actionTitle

536+ action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"

427537 executeCodeAction action

428538 contentAfterAction <- documentContents doc

429539 let expectedContentAfterAction = T.unlines

@@ -439,12 +549,11 @@ renameActionTests = testGroup "rename actions"

439549 , "foo :: Char -> Char -> Char -> Char"

440550 , "foo argument1 argument2 argument3 = argumentX"

441551 ]

442− doc <- openDoc' "Testing.hs" "haskell" content

552+ doc <- createDoc "Testing.hs" "haskell" content

443553 _ <- waitForDiagnostics

444− actionsOrCommands <- getCodeActions doc (Range (Position 2 36) (Position 2 45))

445− let actionTitles = [ actionTitle | CACodeAction CodeAction{ _title = actionTitle } <- actionsOrCommands ]

446− expectedActionTitles = ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]

447− liftIO $ expectedActionTitles @=? actionTitles

554+ _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))

555+ ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]

556+ return()

448557 , testSession "change infix function" $ do

449558 let content = T.unlines

450559 [ "module Testing where"

@@ -452,7 +561,7 @@ renameActionTests = testGroup "rename actions"

452561 , "monus x y = max 0 (x - y)"

453562 , "foo x y = x `monnus` y"

454563 ]

455− doc <- openDoc' "Testing.hs" "haskell" content

564+ doc <- createDoc "Testing.hs" "haskell" content

456565 _ <- waitForDiagnostics

457566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))

458567 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]

@@ -475,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

475584 , "func :: _"

476585 , "func x = x"

477586 ]

478− doc <- openDoc' "Testing.hs" "haskell" content

587+ doc <- createDoc "Testing.hs" "haskell" content

479588 _ <- waitForDiagnostics

480589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

481590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -495,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

495604 , "func :: _"

496605 , "func x y = x + y"

497606 ]

498− doc <- openDoc' "Testing.hs" "haskell" content

607+ doc <- createDoc "Testing.hs" "haskell" content

499608 _ <- waitForDiagnostics

500609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

501610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -518,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

518627 , " y = x * 2"

519628 , " in y"

520629 ]

521− doc <- openDoc' "Testing.hs" "haskell" content

630+ doc <- createDoc "Testing.hs" "haskell" content

522631 _ <- waitForDiagnostics

523632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))

524633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -543,7 +652,7 @@ removeImportTests = testGroup "remove import actions"

543652 let contentA = T.unlines

544653 [ "module ModuleA where"

545654 ]

546− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

547656 let contentB = T.unlines

548657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

549658 , "module ModuleB where"

@@ -551,7 +660,7 @@ removeImportTests = testGroup "remove import actions"

551660 , "stuffB :: Integer"

552661 , "stuffB = 123"

553662 ]

554− docB <- openDoc' "ModuleB.hs" "haskell" contentB

663+ docB <- createDoc "ModuleB.hs" "haskell" contentB

555664 _ <- waitForDiagnostics

556665 [CACodeAction action@CodeAction { _title = actionTitle }]

557666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -569,7 +678,7 @@ removeImportTests = testGroup "remove import actions"

569678 let contentA = T.unlines

570679 [ "module ModuleA where"

571680 ]

572− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

573682 let contentB = T.unlines

574683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

575684 , "module ModuleB where"

@@ -577,7 +686,7 @@ removeImportTests = testGroup "remove import actions"

577686 , "stuffB :: Integer"

578687 , "stuffB = 123"

579688 ]

580− docB <- openDoc' "ModuleB.hs" "haskell" contentB

689+ docB <- createDoc "ModuleB.hs" "haskell" contentB

581690 _ <- waitForDiagnostics

582691 [CACodeAction action@CodeAction { _title = actionTitle }]

583692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -591,8 +700,454 @@ removeImportTests = testGroup "remove import actions"

591700 , "stuffB = 123"

592701 ]

593702 liftIO $ expectedContentAfterAction @=? contentAfterAction

703+ , testSession "redundant binding" $ do

704+ let contentA = T.unlines

705+ [ "module ModuleA where"

706+ , "stuffA = False"

707+ , "stuffB :: Integer"

708+ , "stuffB = 123"

709+ , "stuffC = ()"

710+ ]

711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

712+ let contentB = T.unlines

713+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"

714+ , "module ModuleB where"

715+ , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"

716+ , "main = print stuffB"

717+ ]

718+ docB <- createDoc "ModuleB.hs" "haskell" contentB

719+ _ <- waitForDiagnostics

720+ [CACodeAction action@CodeAction { _title = actionTitle }]

721+ <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

722+ liftIO $ "Remove stuffA, stuffC from import" @=? actionTitle

723+ executeCodeAction action

724+ contentAfterAction <- documentContents docB

725+ let expectedContentAfterAction = T.unlines

726+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"

727+ , "module ModuleB where"

728+ , "import ModuleA (stuffB)"

729+ , "main = print stuffB"

730+ ]

731+ liftIO $ expectedContentAfterAction @=? contentAfterAction

732+ , testSession "redundant operator" $ do

733+ let contentA = T.unlines

734+ [ "module ModuleA where"

735+ , "a !! b = a"

736+ , "a <?> b = a"

737+ , "stuffB :: Integer"

738+ , "stuffB = 123"

739+ ]

740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

741+ let contentB = T.unlines

742+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"

743+ , "module ModuleB where"

744+ , "import qualified ModuleA as A ((<?>), stuffB, (!!))"

745+ , "main = print A.stuffB"

746+ ]

747+ docB <- createDoc "ModuleB.hs" "haskell" contentB

748+ _ <- waitForDiagnostics

749+ [CACodeAction action@CodeAction { _title = actionTitle }]

750+ <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

751+ liftIO $ "Remove !!, <?> from import" @=? actionTitle

752+ executeCodeAction action

753+ contentAfterAction <- documentContents docB

754+ let expectedContentAfterAction = T.unlines

755+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"

756+ , "module ModuleB where"

757+ , "import qualified ModuleA as A (stuffB)"

758+ , "main = print A.stuffB"

759+ ]

760+ liftIO $ expectedContentAfterAction @=? contentAfterAction

761+ , testSession "redundant all import" $ do

762+ let contentA = T.unlines

763+ [ "module ModuleA where"

764+ , "data A = A"

765+ , "stuffB :: Integer"

766+ , "stuffB = 123"

767+ ]

768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

769+ let contentB = T.unlines

770+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"

771+ , "module ModuleB where"

772+ , "import ModuleA (A(..), stuffB)"

773+ , "main = print stuffB"

774+ ]

775+ docB <- createDoc "ModuleB.hs" "haskell" contentB

776+ _ <- waitForDiagnostics

777+ [CACodeAction action@CodeAction { _title = actionTitle }]

778+ <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

779+ liftIO $ "Remove A from import" @=? actionTitle

780+ executeCodeAction action

781+ contentAfterAction <- documentContents docB

782+ let expectedContentAfterAction = T.unlines

783+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"

784+ , "module ModuleB where"

785+ , "import ModuleA (stuffB)"

786+ , "main = print stuffB"

787+ ]

788+ liftIO $ expectedContentAfterAction @=? contentAfterAction

789+ , testSession "redundant constructor import" $ do

790+ let contentA = T.unlines

791+ [ "module ModuleA where"

792+ , "data D = A | B"

793+ , "data E = F"

794+ ]

795+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

796+ let contentB = T.unlines

797+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"

798+ , "module ModuleB where"

799+ , "import ModuleA (D(A,B), E(F))"

800+ , "main = B"

801+ ]

802+ docB <- createDoc "ModuleB.hs" "haskell" contentB

803+ _ <- waitForDiagnostics

804+ [CACodeAction action@CodeAction { _title = actionTitle }]

805+ <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

806+ liftIO $ "Remove A, E, F from import" @=? actionTitle

807+ executeCodeAction action

808+ contentAfterAction <- documentContents docB

809+ let expectedContentAfterAction = T.unlines

810+ [ "{-# OPTIONS_GHC -Wunused-imports #-}"

811+ , "module ModuleB where"

812+ , "import ModuleA (D(B))"

813+ , "main = B"

814+ ]

815+ liftIO $ expectedContentAfterAction @=? contentAfterAction

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')

5941118 ]

5951119

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+

5961151importRenameActionTests :: TestTree

5971152importRenameActionTests = testGroup "import rename actions"

5981153 [ testSession "Data.Mape -> Data.Map" $ check "Map"

@@ -602,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"

6021157 [ "module Testing where"

6031158 , "import Data.Mape"

6041159 ]

605− doc <- openDoc' "Testing.hs" "haskell" content

1160+ doc <- createDoc "Testing.hs" "haskell" content

6061161 _ <- waitForDiagnostics

6071162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))

6081163 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]

@@ -639,10 +1194,10 @@ fillTypedHoleTests = let

6391194 newA newB newC = testSession (T.unpack actionTitle) $ do

6401195 let originalCode = sourceCode oldA oldB oldC

6411196 let expectedCode = sourceCode newA newB newC

642− doc <- openDoc' "Testing.hs" "haskell" originalCode

1197+ doc <- createDoc "Testing.hs" "haskell" originalCode

6431198 _ <- waitForDiagnostics

6441199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))

645− let chosenAction = pickActionWithTitle actionTitle actionsOrCommands

1200+ chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands

6461201 executeCodeAction chosenAction

6471202 modifiedCode <- documentContents doc

6481203 liftIO $ expectedCode @=? modifiedCode

@@ -679,36 +1234,37 @@ fillTypedHoleTests = let

6791234

6801235addSigActionTests :: TestTree

6811236addSigActionTests = let

682− header = "{-# OPTIONS_GHC -Wmissing-signatures #-}"

683− moduleH = "module Sigs where"

1237+ header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"

1238+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"

6841239 before def = T.unlines [header, moduleH, def]

6851240 after' def sig = T.unlines [header, moduleH, sig, def]

6861241

6871242 def >:: sig = testSession (T.unpack def) $ do

6881243 let originalCode = before def

6891244 let expectedCode = after' def sig

690− doc <- openDoc' "Sigs.hs" "haskell" originalCode

1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode

6911246 _ <- waitForDiagnostics

6921247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))

693− let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

1248+ chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

6941249 executeCodeAction chosenAction

6951250 modifiedCode <- documentContents doc

6961251 liftIO $ expectedCode @=? modifiedCode

6971252 in

6981253 testGroup "add signature"

699− [ "abc = True" >:: "abc :: Bool"

700− , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"

701− , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"

702− , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"

703− , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"

704− , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"

1254+ [ "abc = True" >:: "abc :: Bool"

1255+ , "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"

1257+ , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"

1258+ , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"

1259+ , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"

1260+ , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"

7051261 ]

7061262

7071263addSigLensesTests :: TestTree

7081264addSigLensesTests = let

709− missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wunused-matches #-}"

1265+ missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"

7101266 notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"

711− moduleH = "module Sigs where"

1267+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"

7121268 other = T.unlines ["f :: Integer -> Integer", "f x = 3"]

7131269 before withMissing def

7141270 = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]

@@ -718,47 +1274,41 @@ addSigLensesTests = let

7181274 sigSession withMissing def sig = testSession (T.unpack def) $ do

7191275 let originalCode = before withMissing def

7201276 let expectedCode = after' withMissing def sig

721− doc <- openDoc' "Sigs.hs" "haskell" originalCode

1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode

7221278 [CodeLens {_command = Just c}] <- getCodeLenses doc

7231279 executeCommand c

7241280 modifiedCode <- getDocumentEdit doc

7251281 liftIO $ expectedCode @=? modifiedCode

7261282 in

7271283 testGroup "add signature"

728− [ testGroup "with warnings enabled"

729− [ sigSession True "abc = True" "abc :: Bool"

730− , sigSession True "foo a b = a + b" "foo :: Num a => a -> a -> a"

731− , sigSession True "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"

732− , sigSession True "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"

733− , sigSession True "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"

734− , sigSession True "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"

735− ]

736− , testGroup "with warnings disabled"

737− [ sigSession False "abc = True" "abc :: Bool"

738− , sigSession False "foo a b = a + b" "foo :: Num a => a -> a -> a"

739− , sigSession False "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"

740− , sigSession False "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"

741− , sigSession False "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"

742− , sigSession False "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"

1284+ [ testGroup title

1285+ [ sigSession enableWarnings "abc = True" "abc :: Bool"

1286+ , sigSession enableWarnings "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"

1288+ , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"

1289+ , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"

1290+ , sigSession enableWarnings "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"

1291+ , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a"

7431292 ]

1293+ | (title, enableWarnings) <-

1294+ [("with warnings enabled", True)

1295+ ,("with warnings disabled", False)

1296+ ]

7441297 ]

7451298

746−findDefinitionAndHoverTests :: TestTree

747−findDefinitionAndHoverTests = let

748−

749− tst (get, check) pos targetRange title = testSession title $ do

750− doc <- openTestDataDoc sourceFilePath

751− found <- get doc pos

752− check found targetRange

1299+checkDefs :: [Location] -> Session [Expect] -> Session ()

1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where

7531301

754− checkDefs :: [Location] -> [Expect] -> Session ()

755− checkDefs defs expectations = traverse_ check expectations where

756−

757− check (ExpectRange expectedRange) = do

758− assertNDefinitionsFound 1 defs

759− assertRangeCorrect (head defs) expectedRange

760− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"

761− check _ = pure () -- all other expectations not relevant to getDefinition

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

7621312

7631313 assertNDefinitionsFound :: Int -> [a] -> Session ()

7641314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)

@@ -766,23 +1316,35 @@ findDefinitionAndHoverTests = let

7661316 assertRangeCorrect Location{_range = foundRange} expectedRange =

7671317 liftIO $ expectedRange @=? foundRange

7681318

769− checkHover :: Maybe Hover -> [Expect] -> Session ()

770− checkHover hover expectations = traverse_ check expectations where

1319+

1320+findDefinitionAndHoverTests :: TestTree

1321+findDefinitionAndHoverTests = let

1322+

1323+ tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do

1324+ doc <- openTestDataDoc (dir </> sourceFilePath)

1325+ found <- get doc pos

1326+ check found targetRange

1327+

1328+

1329+

1330+ checkHover :: Maybe Hover -> Session [Expect] -> Session ()

1331+ checkHover hover expectations = traverse_ check =<< expectations where

7711332

7721333 check expected =

7731334 case hover of

774− Nothing -> liftIO $ assertFailure "no hover found"

1335+ Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"

7751336 Just Hover{_contents = (HoverContents MarkupContent{_value = msg})

7761337 ,_range = rangeInHover } ->

7771338 case expected of

7781339 ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg

7791340 ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg

7801341 ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets

1342+ ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover

7811343 _ -> pure () -- all other expectations not relevant to hover

7821344 _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover

7831345

7841346 extractLineColFromHoverMsg :: T.Text -> [T.Text]

785− extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "**" . last . T.splitOn (sourceFileName <> ":")

1347+ extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")

7861348

7871349 checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()

7881350 checkHoverRange expectedRange rangeInHover msg =

@@ -809,9 +1371,12 @@ findDefinitionAndHoverTests = let

8091371

8101372 mkFindTests tests = testGroup "get"

8111373 [ testGroup "definition" $ mapMaybe fst tests

812− , testGroup "hover" $ mapMaybe snd tests ]

1374+ , testGroup "hover" $ mapMaybe snd tests

1375+ , checkFileCompiles sourceFilePath ]

1376+

1377+ test runDef runHover look expect = testM runDef runHover look (return expect)

8131378

814− test runDef runHover look expect title =

1379+ testM runDef runHover look expect title =

8151380 ( runDef $ tst def look expect title

8161381 , runHover $ tst hover look expect title ) where

8171382 def = (getDefinitions, checkDefs)

@@ -819,71 +1384,100 @@ findDefinitionAndHoverTests = let

8191384 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out

8201385

8211386 -- search locations expectations on results

822− fffL4 = _start fffR ; fffR = mkRange 4 4 4 7 ; fff = [ExpectRange fffR]

823− fffL8 = Position 8 4 ;

824− fffL14 = Position 14 7 ;

825− aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]

826− dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]

827− dcL12 = Position 12 11 ;

828− xtcL5 = Position 5 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]

829− tcL6 = Position 6 11 ; tcData = [mkR 3 0 5 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:4:1"]]

830− vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]

831− opL16 = Position 16 15 ; op = [mkR 17 2 17 4]

832− opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]

833− aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]

834− b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]

835− xvL20 = Position 20 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]

836− clL23 = Position 23 11 ; cls = [mkR 21 0 22 20, ExpectHoverText ["MyClass", "GotoHover.hs:22:1"]]

837− clL25 = Position 25 9

838− eclL15 = Position 15 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]

839− dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]

840− dnbL30 = Position 30 23

841− lcbL33 = Position 33 26 ; lcb = [ExpectHoverText [":: Char"], mkR 33 26 33 27]

842− lclL33 = Position 33 22

843− mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14]

844− mclL37 = Position 37 1

845− docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]

846− eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]

847− intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]]

848− tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]

1387+ fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR]

1388+ fffL8 = Position 12 4 ;

1389+ fffL14 = Position 18 7 ;

1390+ aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]

1391+ dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]

1392+ dcL12 = Position 16 11 ;

1393+ xtcL5 = Position 9 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"]]

1395+ vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6]

1396+ opL16 = Position 20 15 ; op = [mkR 21 2 21 4]

1397+ opL18 = Position 22 22 ; opp = [mkR 22 13 22 17]

1398+ aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11]

1399+ b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7]

1400+ xvL20 = Position 24 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"]]

1402+ clL25 = Position 29 9

1403+ eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]

1404+ dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21]

1405+ dnbL30 = Position 34 23

1406+ lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27]

1407+ lclL33 = Position 37 22

1408+ mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14]

1409+ mclL37 = Position 41 1

1410+ spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]

1411+ docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]

1412+ ; constr = [ExpectHoverText ["Monad m"]]

1413+ eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]

1414+ intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: *\n"]]

1415+ tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]

1416+ intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]]

1417+ chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]]

1418+ txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]]

1419+ lstL43 = Position 47 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]

8491424 in

8501425 mkFindTests

851− -- def hover look expect

852− [ test yes yes fffL4 fff "field in record definition"

853− , test broken broken fffL8 fff "field in record construction #71"

854− , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs

855− , test yes yes aaaL14 aaa "top-level name" -- 120

856− , test broken broken dcL7 tcDC "data constructor record #247"

857− , test yes yes dcL12 tcDC "data constructor plain" -- 121

858− , test yes yes tcL6 tcData "type constructor #248" -- 147

859− , test broken yes xtcL5 xtc "type constructor external #248,249"

860− , test broken yes xvL20 xvMsg "value external package #249" -- 120

861− , test yes yes vvL16 vv "plain parameter" -- 120

862− , test yes yes aL18 apmp "pattern match name" -- 120

863− , test yes yes opL16 op "top-level operator" -- 120, 123

864− , test yes yes opL18 opp "parameter operator" -- 120

865− , test yes yes b'L19 bp "name in backticks" -- 120

866− , test yes yes clL23 cls "class in instance declaration #250"

867− , test yes yes clL25 cls "class in signature #250" -- 147

868− , test broken yes eclL15 ecls "external class in signature #249,250"

869− , test yes yes dnbL29 dnb "do-notation bind" -- 137

870− , test yes yes dnbL30 dnb "do-notation lookup"

871− , test yes yes lcbL33 lcb "listcomp bind" -- 137

872− , test yes yes lclL33 lcb "listcomp lookup"

873− , test yes yes mclL36 mcl "top-level fn 1st clause"

874− , test yes yes mclL37 mcl "top-level fn 2nd clause #246"

875− , test no broken docL41 doc "documentation #7"

876− , test no broken eitL40 kindE "kind of Either #273"

877− , test no broken intL40 kindI "kind of Int #273"

878− , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"

1426+ -- def hover look expect

1427+ [ test yes yes fffL4 fff "field in record definition"

1428+ , 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

1430+ , test yes yes aaaL14 aaa "top-level name" -- 120

1431+ , test yes yes dcL7 tcDC "data constructor record #247"

1432+ , test yes yes dcL12 tcDC "data constructor plain" -- 121

1433+ , test yes yes tcL6 tcData "type constructor #248" -- 147

1434+ , test broken yes xtcL5 xtc "type constructor external #248,249"

1435+ , test broken yes xvL20 xvMsg "value external package #249" -- 120

1436+ , test yes yes vvL16 vv "plain parameter" -- 120

1437+ , test yes yes aL18 apmp "pattern match name" -- 120

1438+ , test yes yes opL16 op "top-level operator" -- 120, 123

1439+ , test yes yes opL18 opp "parameter operator" -- 120

1440+ , test yes yes b'L19 bp "name in backticks" -- 120

1441+ , test yes yes clL23 cls "class in instance declaration #250"

1442+ , test yes yes clL25 cls "class in signature #250" -- 147

1443+ , test broken yes eclL15 ecls "external class in signature #249,250"

1444+ , test yes yes dnbL29 dnb "do-notation bind" -- 137

1445+ , test yes yes dnbL30 dnb "do-notation lookup"

1446+ , test yes yes lcbL33 lcb "listcomp bind" -- 137

1447+ , test yes yes lclL33 lcb "listcomp lookup"

1448+ , test yes yes mclL36 mcl "top-level fn 1st clause"

1449+ , 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"

1452+ , test no yes eitL40 kindE "kind of Either #273"

1453+ , test no yes intL40 kindI "kind of Int #273"

1454+ , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"

1455+ , test no yes intL41 litI "literal Int in hover info #274"

1456+ , test no yes chrL36 litC "literal Char in hover info #274"

1457+ , test no yes txtL8 litT "literal Text in hover info #274"

1458+ , test no yes lstL43 litL "literal List in hover info #274"

1459+ , test no yes 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)"

8791464 ]

8801465 where yes, broken :: (TestTree -> Maybe TestTree)

8811466 yes = Just -- test should run and pass

8821467 broken = Just . (`xfail` "known broken")

8831468 no = const Nothing -- don't run this test at all

8841469

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+

8851478pluginTests :: TestTree

886−pluginTests = testSessionWait "plugins" $ do

1479+pluginTests = (`xfail8101` "known broken (#556)")

1480+ $ testSessionWait "plugins" $ do

8871481 let content =

8881482 T.unlines

8891483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"

@@ -897,13 +1491,100 @@ pluginTests = testSessionWait "plugins" $ do

8971491 , "foo :: Int -> Int -> Int"

8981492 , "foo a b = a + c"

8991493 ]

900− _ <- openDoc' "Testing.hs" "haskell" content

1494+ _ <- createDoc "Testing.hs" "haskell" content

9011495 expectDiagnostics

9021496 [ ( "Testing.hs",

9031497 [(DsError, (8, 14), "Variable not in scope: c")]

9041498 )

9051499 ]

9061500

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+

1543+preprocessorTests :: TestTree

1544+preprocessorTests = testSessionWait "preprocessor" $ do

1545+ let content =

1546+ T.unlines

1547+ [ "{-# OPTIONS_GHC -F -pgmF=ghcide-test-preprocessor #-}"

1548+ , "module Testing where"

1549+ , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic

1550+ ]

1551+ _ <- createDoc "Testing.hs" "haskell" content

1552+ expectDiagnostics

1553+ [ ( "Testing.hs",

1554+ [(DsError, (2, 8), "Variable not in scope: z")]

1555+ )

1556+ ]

1557+

1558+

1559+safeTests :: TestTree

1560+safeTests =

1561+ testGroup

1562+ "SafeHaskell"

1563+ [ -- Test for https://github.com/digital-asset/ghcide/issues/424

1564+ testSessionWait "load" $ do

1565+ let sourceA =

1566+ T.unlines

1567+ ["{-# LANGUAGE Trustworthy #-}"

1568+ ,"module A where"

1569+ ,"import System.IO.Unsafe"

1570+ ,"import System.IO"

1571+ ,"trustWorthyId :: a -> a"

1572+ ,"trustWorthyId i = unsafePerformIO $ do"

1573+ ," putStrLn \"I'm safe\""

1574+ ," return i"]

1575+ sourceB =

1576+ T.unlines

1577+ ["{-# LANGUAGE Safe #-}"

1578+ ,"module B where"

1579+ ,"import A"

1580+ ,"safeId :: a -> a"

1581+ ,"safeId = trustWorthyId"

1582+ ]

1583+

1584+ _ <- createDoc "A.hs" "haskell" sourceA

1585+ _ <- createDoc "B.hs" "haskell" sourceB

1586+ expectNoMoreDiagnostics 1 ]

1587+

9071588thTests :: TestTree

9081589thTests =

9091590 testGroup

@@ -929,24 +1610,586 @@ thTests =

9291610 "b :: Integer",

9301611 "b = $(litE $ IntegerL $ a) + n"

9311612 ]

932− _ <- openDoc' "A.hs" "haskell" sourceA

933− _ <- openDoc' "B.hs" "haskell" sourceB

1613+ _ <- createDoc "A.hs" "haskell" sourceA

1614+ _ <- createDoc "B.hs" "haskell" sourceB

9341615 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 ()

9351637 ]

9361638

1639+completionTests :: TestTree

1640+completionTests

1641+ = testGroup "completion"

1642+ [ testSessionWait "variable" $ do

1643+ let source = T.unlines ["module A where", "f = hea"]

1644+ docId <- createDoc "A.hs" "haskell" source

1645+ compls <- getCompletions docId (Position 1 7)

1646+ liftIO $ map dropDocs compls @?=

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

1667+ let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]

1668+ docId <- createDoc "A.hs" "haskell" source

1669+ 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"]]

1671+ compls <- getCompletions docId (Position 2 7)

1672+ liftIO $ map dropDocs compls @?=

1673+ [ complItem "Bounded" (Just CiClass) (Just "* -> Constraint")

1674+ , complItem "Bool" (Just CiStruct) (Just "*") ]

1675+ let [ CompletionItem { _documentation = boundedDocs},

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

1684+ let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]

1685+ docId <- createDoc "A.hs" "haskell" source

1686+ 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"]]

1688+ compls <- getCompletions docId (Position 2 15)

1689+ liftIO $ map dropDocs compls @?=

1690+ [complItem "head" (Just CiFunction) (Just "[a] -> a")]

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+ ]

1724+ where

1725+ dropDocs :: CompletionItem -> CompletionItem

1726+ dropDocs ci = ci { _documentation = Nothing }

1727+ complItem label kind ty = CompletionItem

1728+ { _label = label

1729+ , _kind = kind

1730+ , _tags = List []

1731+ , _detail = (":: " <>) <$> ty

1732+ , _documentation = Nothing

1733+ , _deprecated = Nothing

1734+ , _preselect = Nothing

1735+ , _sortText = Nothing

1736+ , _filterText = Nothing

1737+ , _insertText = Nothing

1738+ , _insertTextFormat = Just PlainText

1739+ , _textEdit = Nothing

1740+ , _additionalTextEdits = Nothing

1741+ , _commitCharacters = Nothing

1742+ , _command = Nothing

1743+ , _xdata = Nothing

1744+ }

1745+ keywordItem label = CompletionItem

1746+ { _label = label

1747+ , _kind = Just CiKeyword

1748+ , _tags = List []

1749+ , _detail = Nothing

1750+ , _documentation = Nothing

1751+ , _deprecated = Nothing

1752+ , _preselect = Nothing

1753+ , _sortText = Nothing

1754+ , _filterText = Nothing

1755+ , _insertText = Nothing

1756+ , _insertTextFormat = Nothing

1757+ , _textEdit = Nothing

1758+ , _additionalTextEdits = Nothing

1759+ , _commitCharacters = Nothing

1760+ , _command = Nothing

1761+ , _xdata = Nothing

1762+ }

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+

1771+outlineTests :: TestTree

1772+outlineTests = testGroup

1773+ "outline"

1774+ [ testSessionWait "type class" $ do

1775+ let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]

1776+ docId <- createDoc "A.hs" "haskell" source

1777+ symbols <- getDocumentSymbols docId

1778+ liftIO $ symbols @?= Left

1779+ [ moduleSymbol

1780+ "A"

1781+ (R 0 7 0 8)

1782+ [ classSymbol "A a"

1783+ (R 1 0 1 30)

1784+ [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)]

1785+ ]

1786+ ]

1787+ , testSessionWait "type class instance " $ do

1788+ let source = T.unlines ["class A a where", "instance A () where"]

1789+ docId <- createDoc "A.hs" "haskell" source

1790+ symbols <- getDocumentSymbols docId

1791+ liftIO $ symbols @?= Left

1792+ [ classSymbol "A a" (R 0 0 0 15) []

1793+ , docSymbol "A ()" SkInterface (R 1 0 1 19)

1794+ ]

1795+ , testSessionWait "type family" $ do

1796+ let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]

1797+ docId <- createDoc "A.hs" "haskell" source

1798+ symbols <- getDocumentSymbols docId

1799+ liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]

1800+ , testSessionWait "type family instance " $ do

1801+ let source = T.unlines

1802+ [ "{-# language TypeFamilies #-}"

1803+ , "type family A a"

1804+ , "type instance A () = ()"

1805+ ]

1806+ docId <- createDoc "A.hs" "haskell" source

1807+ symbols <- getDocumentSymbols docId

1808+ liftIO $ symbols @?= Left

1809+ [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)

1810+ , docSymbol "A ()" SkInterface (R 2 0 2 23)

1811+ ]

1812+ , testSessionWait "data family" $ do

1813+ let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]

1814+ docId <- createDoc "A.hs" "haskell" source

1815+ symbols <- getDocumentSymbols docId

1816+ liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]

1817+ , testSessionWait "data family instance " $ do

1818+ let source = T.unlines

1819+ [ "{-# language TypeFamilies #-}"

1820+ , "data family A a"

1821+ , "data instance A () = A ()"

1822+ ]

1823+ docId <- createDoc "A.hs" "haskell" source

1824+ symbols <- getDocumentSymbols docId

1825+ liftIO $ symbols @?= Left

1826+ [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)

1827+ , docSymbol "A ()" SkInterface (R 2 0 2 25)

1828+ ]

1829+ , testSessionWait "constant" $ do

1830+ let source = T.unlines ["a = ()"]

1831+ docId <- createDoc "A.hs" "haskell" source

1832+ symbols <- getDocumentSymbols docId

1833+ liftIO $ symbols @?= Left

1834+ [docSymbol "a" SkFunction (R 0 0 0 6)]

1835+ , testSessionWait "pattern" $ do

1836+ let source = T.unlines ["Just foo = Just 21"]

1837+ docId <- createDoc "A.hs" "haskell" source

1838+ symbols <- getDocumentSymbols docId

1839+ liftIO $ symbols @?= Left

1840+ [docSymbol "Just foo" SkFunction (R 0 0 0 18)]

1841+ , testSessionWait "pattern with type signature" $ do

1842+ let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]

1843+ docId <- createDoc "A.hs" "haskell" source

1844+ symbols <- getDocumentSymbols docId

1845+ liftIO $ symbols @?= Left

1846+ [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]

1847+ , testSessionWait "function" $ do

1848+ let source = T.unlines ["a x = ()"]

1849+ docId <- createDoc "A.hs" "haskell" source

1850+ symbols <- getDocumentSymbols docId

1851+ liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]

1852+ , testSessionWait "type synonym" $ do

1853+ let source = T.unlines ["type A = Bool"]

1854+ docId <- createDoc "A.hs" "haskell" source

1855+ symbols <- getDocumentSymbols docId

1856+ liftIO $ symbols @?= Left

1857+ [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]

1858+ , testSessionWait "datatype" $ do

1859+ let source = T.unlines ["data A = C"]

1860+ docId <- createDoc "A.hs" "haskell" source

1861+ symbols <- getDocumentSymbols docId

1862+ liftIO $ symbols @?= Left

1863+ [ docSymbolWithChildren "A"

1864+ SkStruct

1865+ (R 0 0 0 10)

1866+ [docSymbol "C" SkConstructor (R 0 9 0 10)]

1867+ ]

1868+ , testSessionWait "record fields" $ do

1869+ let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"]

1870+ docId <- createDoc "A.hs" "haskell" source

1871+ symbols <- getDocumentSymbols docId

1872+ liftIO $ symbols @=? Left

1873+ [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13)

1874+ [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10)

1875+ [ docSymbol "x" SkField (R 1 2 1 3)

1876+ , docSymbol "y" SkField (R 2 4 2 5)

1877+ ]

1878+ ]

1879+ ]

1880+ , testSessionWait "import" $ do

1881+ let source = T.unlines ["import Data.Maybe"]

1882+ docId <- createDoc "A.hs" "haskell" source

1883+ symbols <- getDocumentSymbols docId

1884+ liftIO $ symbols @?= Left

1885+ [docSymbolWithChildren "imports"

1886+ SkModule

1887+ (R 0 0 0 17)

1888+ [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)

1889+ ]

1890+ ]

1891+ , testSessionWait "multiple import" $ do

1892+ let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]

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

1904+ let source = T.unlines

1905+ [ "{-# language ForeignFunctionInterface #-}"

1906+ , "foreign import ccall \"a\" a :: Int"

1907+ ]

1908+ docId <- createDoc "A.hs" "haskell" source

1909+ symbols <- getDocumentSymbols docId

1910+ liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]

1911+ , testSessionWait "foreign export" $ do

1912+ let source = T.unlines

1913+ [ "{-# language ForeignFunctionInterface #-}"

1914+ , "foreign export ccall odd :: Int -> Bool"

1915+ ]

1916+ docId <- createDoc "A.hs" "haskell" source

1917+ symbols <- getDocumentSymbols docId

1918+ liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]

1919+ ]

1920+ where

1921+ docSymbol name kind loc =

1922+ DocumentSymbol name Nothing kind Nothing loc loc Nothing

1923+ docSymbol' name kind loc selectionLoc =

1924+ DocumentSymbol name Nothing kind Nothing loc selectionLoc Nothing

1925+ docSymbolD name detail kind loc =

1926+ DocumentSymbol name (Just detail) kind Nothing loc loc Nothing

1927+ docSymbolWithChildren name kind loc cc =

1928+ DocumentSymbol name Nothing kind Nothing loc loc (Just $ List cc)

1929+ docSymbolWithChildren' name kind loc selectionLoc cc =

1930+ DocumentSymbol name Nothing kind Nothing loc selectionLoc (Just $ List cc)

1931+ moduleSymbol name loc cc = DocumentSymbol name

1932+ Nothing

1933+ SkFile

1934+ Nothing

1935+ (R 0 0 maxBound 0)

1936+ loc

1937+ (Just $ List cc)

1938+ classSymbol name loc cc = DocumentSymbol name

1939+ (Just "class")

1940+ SkClass

1941+ Nothing

1942+ loc

1943+ loc

1944+ (Just $ List cc)

1945+

1946+pattern R :: Int -> Int -> Int -> Int -> Range

1947+pattern R x y x' y' = Range (Position x y) (Position x' y')

1948+

9371949xfail :: TestTree -> String -> TestTree

9381950xfail = flip expectFailBecause

9391951

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+

9401959data Expect

9411960 = ExpectRange Range -- Both gotoDef and hover should report this range

1961+ | ExpectLocation Location

9421962-- | ExpectDefRange Range -- Only gotoDef should report this range

9431963 | ExpectHoverRange Range -- Only hover should report this range

9441964 | ExpectHoverText [T.Text] -- the hover message must contain these snippets

9451965 | ExpectExternFail -- definition lookup in other file expected to fail

1966+ | ExpectNoDefinitions

1967+ | ExpectNoHover

9461968-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples

1969+ deriving Eq

9471970

9481971mkR :: Int -> Int -> Int -> Int -> Expect

9491972mkR 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+

9502193----------------------------------------------------------------------

9512194-- Utils

9522195

@@ -954,6 +2197,12 @@ mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine st

9542197testSession :: String -> Session () -> TestTree

9552198testSession name = testCase name . run

9562199

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+

9572206testSessionWait :: String -> Session () -> TestTree

9582207testSessionWait name = testSession name .

9592208 -- Check that any diagnostics produced were already consumed by the test case.

@@ -964,35 +2213,284 @@ testSessionWait name = testSession name .

9642213 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.

9652214 ( >> expectNoMoreDiagnostics 0.5)

9662215

967−pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction

968−pickActionWithTitle title actions = head

969− [ action

970− | CACodeAction action@CodeAction{ _title = actionTitle } <- actions

971− , title == actionTitle ]

2216+pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction

2217+pickActionWithTitle title actions = do

2218+ assertBool ("Found no matching actions: " <> show titles) (not $ null matches)

2219+ return $ head matches

2220+ where

2221+ titles =

2222+ [ actionTitle

2223+ | CACodeAction CodeAction { _title = actionTitle } <- actions

2224+ ]

2225+ matches =

2226+ [ action

2227+ | CACodeAction action@CodeAction { _title = actionTitle } <- actions

2228+ , title == actionTitle

2229+ ]

9722230

9732231mkRange :: Int -> Int -> Int -> Int -> Range

9742232mkRange a b c d = Range (Position a b) (Position c d)

9752233

9762234run :: Session a -> IO a

977−run s = withTempDir $ \dir -> do

2235+run s = withTempDir $ \dir -> runInDir dir s

2236+

2237+runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a

2238+runWithExtraFiles prefix s = withTempDir $ \dir -> do

2239+ copyTestDataFiles dir prefix

2240+ runInDir dir (s dir)

2241+

2242+copyTestDataFiles :: FilePath -> FilePath -> IO ()

2243+copyTestDataFiles dir prefix = do

2244+ -- Copy all the test data files to the temporary workspace

2245+ testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]

2246+ for_ testDataFiles $ \f -> do

2247+ createDirectoryIfMissing True $ dir </> takeDirectory f

2248+ copyFile ("test/data" </> prefix </> f) (dir </> f)

2249+

2250+run' :: (FilePath -> Session a) -> IO a

2251+run' s = withTempDir $ \dir -> runInDir dir (s dir)

2252+

2253+runInDir :: FilePath -> Session a -> IO a

2254+runInDir dir s = do

9782255 ghcideExe <- locateGhcideExecutable

9792256

9802257 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56

9812258 -- since the package import test creates "Data/List.hs", which otherwise has no physical home

9822259 createDirectoryIfMissing True $ dir ++ "/Data"

9832260

984− let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]

2261+

2262+ let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]

9852263 -- HIE calls getXgdDirectory which assumes that HOME is set.

9862264 -- Only sets HOME if it wasn't already set.

9872265 setEnv "HOME" "/homeless-shelter" False

988− runSessionWithConfig conf cmd fullCaps { _window = Just $ WindowClientCapabilities $ Just True } dir s

2266+ let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }

2267+ runSessionWithConfig conf cmd lspTestCaps dir s

9892268 where

9902269 conf = defaultConfig

991− -- If you uncomment this you can see all messages

2270+ -- If you uncomment this you can see all logging

9922271 -- which can be quite useful for debugging.

993− -- { logMessages = True, logColor = False, logStdErr = True }

2272+ -- { logStdErr = True, logColor = False }

2273+ -- If you really want to, you can also see all messages

2274+ -- { logMessages = True, logColor = False }

9942275

9952276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier

9962277openTestDataDoc path = do

9972278 source <- liftIO $ readFileUtf8 $ "test/data" </> path

998− openDoc' path "haskell" source

2279+ createDoc 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+

2304+unitTests :: TestTree

2305+unitTests = do

2306+ testGroup "Unit"

2307+ [ testCase "empty file path does NOT work with the empty String literal" $

2308+ uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just "."

2309+ , testCase "empty file path works using toNormalizedFilePath'" $

2310+ uriToFilePath' (fromNormalizedUri $ filePathToUri' (toNormalizedFilePath' "")) @?= Just ""

2311+ , testCase "empty path URI" $ do

2312+ Just URI{..} <- pure $ parseURI (T.unpack $ getUri $ fromNormalizedUri emptyPathUri)

2313+ uriScheme @?= "file:"

2314+ uriPath @?= ""

2315+ , testCase "from empty path URI" $ do

2316+ let uri = Uri "file://"

2317+ uriToFilePath' uri @?= Just ""

2318+ ]

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/preprocessor/Main.hsnew file+10

@@ -0,0 +1,10 @@

2+module Main(main) where

4+import System.Environment

6+main :: IO ()

7+main = do

8+ _:input:output:_ <- getArgs

9+ let f = map (\x -> if x == 'x' then 'y' else x)

10+ writeFile output . f =<< readFile input

test/src/Development/IDE/Test.hs+8−2

@@ -1,10 +1,13 @@

22-- SPDX-License-Identifier: Apache-2.0

4+{-# LANGUAGE DuplicateRecordFields #-}

46module Development.IDE.Test

57 ( Cursor

68 , cursorPosition

79 , requireDiagnostic

10+ , diagnostic

811 , expectDiagnostics

912 , expectNoMoreDiagnostics

1013 ) where

@@ -15,7 +18,7 @@ import Control.Monad

1518import Control.Monad.IO.Class

1619import qualified Data.Map.Strict as Map

1720import qualified Data.Text as T

18−import Language.Haskell.LSP.Test hiding (message, openDoc')

21+import Language.Haskell.LSP.Test hiding (message)

1922import qualified Language.Haskell.LSP.Test as LspTest

2023import Language.Haskell.LSP.Types

2124import Language.Haskell.LSP.Types.Lens as Lsp

@@ -77,7 +80,7 @@ expectDiagnostics expected = do

7780 go m

7881 | Map.null m = pure ()

7982 | otherwise = do

80− diagsNot <- skipManyTill anyMessage LspTest.message :: Session PublishDiagnosticsNotification

83+ diagsNot <- skipManyTill anyMessage diagnostic

8184 let fileUri = diagsNot ^. params . uri

8285 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of

8386 Nothing -> do

@@ -96,6 +99,9 @@ expectDiagnostics expected = do

9699 " but got " <> show actual

97100 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m

98101

102+diagnostic :: Session PublishDiagnosticsNotification

103+diagnostic = LspTest.message

104+

99105standardizeQuotes :: T.Text -> T.Text

100106standardizeQuotes msg = let

101107 repl '‘' = '\''