master..87f449d · ghcide

git.iko.soy/ghcide

82 files changed+1861−11779

unifiedsplit

.azure/linux-stack.ymldeleted−63

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

1−jobs:

2−- job: ghcide_stack_linux

3− timeoutInMinutes: 60

4− pool:

5− vmImage: 'ubuntu-latest'

6− strategy:

7− matrix:

8− stack_810:

9− STACK_YAML: "stack810.yaml"

10− stack_88:

11− STACK_YAML: "stack88.yaml"

12− stack_86:

13− STACK_YAML: "stack.yaml"

14− stack_84:

15− STACK_YAML: "stack84.yaml"

16− stack_ghc_lib_88:

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

18− steps:

19− - checkout: self

20− - task: Cache@2

21− inputs:

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

23− path: .azure-cache

24− cacheHitVar: CACHE_RESTORED

25− displayName: "Cache stack artifacts"

26− - bash: |

27− mkdir -p ~/.stack

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

29− displayName: "Unpack cache"

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

31− - bash: |

32− ./fmt.sh

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

34− - bash: |

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

36− sudo apt-get update

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

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

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

40− fi

41− displayName: 'Install Stack'

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

43− displayName: 'stack setup'

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

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

46− - bash: |

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

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

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

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

51− - bash: |

52− mkdir -p .azure-cache

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

54− displayName: "Pack cache"

55− - bash: |

56− set -euo pipefail

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

58− curl -XPOST \

59− -i \

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

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

62− $(Slack.URL)

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

.azure/windows-stack.ymldeleted−68

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

1−jobs:

2−- job: ghcide_stack_windows

3− timeoutInMinutes: 60

4− pool:

5− vmImage: 'windows-2019'

6− strategy:

7− matrix:

8− stack_810:

9− STACK_YAML: "stack810.yaml"

10− stack_88:

11− STACK_YAML: "stack88.yaml"

12− stack_86:

13− STACK_YAML: "stack.yaml"

14− stack_84:

15− STACK_YAML: "stack84.yaml"

16− stack_ghc_lib_88:

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

18− variables:

19− STACK_ROOT: "C:\\sr"

20− steps:

21− - checkout: self

22− - task: Cache@2

23− inputs:

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

25− path: .azure-cache

26− cacheHitVar: CACHE_RESTORED

27− displayName: "Cache stack artifacts"

28− - bash: |

29− mkdir -p $STACK_ROOT

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

31− mkdir -p .stack-work

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

33− displayName: "Unpack cache"

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

35− - bash: |

36− ./fmt.sh

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

38− - bash: |

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

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

41− mkdir -p "$STACK_ROOT"

42− displayName: 'Install Stack'

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

44− displayName: 'stack setup'

45− - bash: |

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

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

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

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

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

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

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

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

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

55− - bash: |

56− mkdir -p .azure-cache

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

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

59− displayName: "Pack cache"

60− - bash: |

61− set -euo pipefail

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

63− curl -XPOST \

64− -i \

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

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

67− $(Slack.URL)

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

.editorconfigdeleted−11

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

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

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

3−

4−root = true

5−

6−[*]

7−end_of_line = LF

8−indent_style = space

9−indent_size = 4

10−trim_trailing_whitespace = true

11−insert_final_newline = true

.ghcinew file+24

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

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

3+:set -XBangPatterns

4+:set -XDeriveFunctor

5+:set -XDeriveGeneric

6+:set -XGeneralizedNewtypeDeriving

7+:set -XLambdaCase

8+:set -XNamedFieldPuns

9+:set -XOverloadedStrings

10+:set -XRecordWildCards

11+:set -XScopedTypeVariables

12+:set -XStandaloneDeriving

13+:set -XTupleSections

14+:set -XTypeApplications

15+:set -XViewPatterns

16+

17+:set -package=ghc

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

19+:set -DGHC_STABLE

20+:set -Iinclude

21+:set -isrc

22+:set -iexe

23+

24+:load Main

.gitignore−4

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

44cabal.project.local

55*~

66*.lock

7−/.tasty-rerun-log

8−.vscode

9−/.hlint-*

10−bench/example

.hlint.yaml+2−12

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

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

7474

7575 # Shady extensions

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

7677 - name: CPP

7778 within:

78− - Development.IDE.Compat

7979 - Development.IDE.Core.FileStore

8080 - Development.IDE.Core.Compile

81− - Development.IDE.Core.Rules

8281 - Development.IDE.GHC.Compat

83− - Development.IDE.GHC.Orphans

8482 - Development.IDE.GHC.Util

8583 - Development.IDE.Import.FindImports

86− - Development.IDE.LSP.Outline

84+ - Development.IDE.LSP.CodeAction

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

9386 - Main

9487

9588- flags:

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

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

10295#

10396- functions:

104− # Things that are unsafe in Haskell base library

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

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

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

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

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

110100

111101# Add custom hints for this project

112102#

CHANGELOG.md−57

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

11### unreleased

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

4−

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

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

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

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

9− files) (thanks @jinwoo)

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

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

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

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

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

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

16− @pepeiborra)

17−* Minor improvements to completions

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

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

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

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

22−

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

24−

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

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

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

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

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

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

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

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

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

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

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

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

37−

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

39−

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

41− comprehensions (see #243).

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

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

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

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

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

47− not enabled. (see #232)

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

49− workarounds. (see #264)

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

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

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

53−* Support custom preprocessors (see #282)

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

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

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

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

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

59−

603### 0.0.5 (2019-12-12)

614

625* Support for GHC plugins (see #192)

README.md+6−87

@@ -25,40 +25,13 @@ 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−

4528## Using it

4629

4730### Install `ghcide`

4831

4932#### With Nix

5033

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.

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

6235

6336#### With Cabal or Stack

6437

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

9164

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

9366

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−

9867### Using with VS Code

9968

10069You can install the VSCode extension from the [VSCode

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

10271

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−

12772### Using with Emacs

12873

12974If 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).

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

234179```

235180

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

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

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

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

242183

243184### SpaceVim

244185

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

259200{

260201 "languageserver": {

261202 "haskell": {

262− "command": "ghcide",

203+ "command": "stack",

263204 "args": [

205+ "exec",

206+ "ghcide",

264207 "--lsp"

265208 ],

266209 "rootPatterns": [

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

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

284227using `stack install ghcide` within a project.

285228

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−

300229## Hacking on ghcide

301230

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

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

312233

313234### Building the extension

314235

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

325246

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

327248

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−

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

331250

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.

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.

333252

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

azure-pipelines.yml+184−3

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

44 branches:

55 include:

66 - master

7− - azure*

98# Enable PR triggers that target the master branch

109pr:

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

1413 - master

1514

1615jobs:

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

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

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

bench/Main.hsdeleted−287

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

1−{-# LANGUAGE ConstraintKinds #-}

2−{-# LANGUAGE ExistentialQuantification #-}

3−{-# LANGUAGE ImplicitParams #-}

4−

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

6−

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

8−

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

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

11−

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

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

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

15−

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

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

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

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

20−

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

22−

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

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

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

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

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

28−

29− How to run:

30− 1. `cabal bench`

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

32−

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

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

35− produce the same results.

36−

37− -}

38−

39−import Control.Applicative.Combinators

40−import Control.Concurrent

41−import Control.Exception.Safe

42−import Control.Monad.Extra

43−import Control.Monad.IO.Class

44−import Data.Aeson

45−import Data.List

46−import Data.Maybe

47−import Data.Version

48−import Language.Haskell.LSP.Test

49−import Language.Haskell.LSP.Types

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

51−import Numeric.Natural

52−import Options.Applicative

53−import System.Directory

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

55−import System.Process

56−import System.Time.Extra

57−

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

59−-- convenient for hygienic edits

60−hygienicP :: Position

61−hygienicP = Position 854 23

62−

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

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

65−identifierP :: Position

66−identifierP = Position 853 12

67−

68−main :: IO ()

69−main = do

70− config <- execParser $ info configP fullDesc

71− let ?config = config

72−

73− output "starting test"

74−

75− cleanUp <- setup

76−

77− runBenchmarks

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

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

80− isJust <$> getHover doc identifierP,

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

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

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

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

85− bench "documentSymbols" 100 $

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

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

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

89− let change =

90− TextDocumentContentChangeEvent

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

92− _rangeLength = Nothing,

93− _text = " "

94− }

95− changeDoc doc [change]

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

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

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

99− let change =

100− TextDocumentContentChangeEvent

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

102− _rangeLength = Nothing,

103− _text = " "

104− }

105− changeDoc doc [change]

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

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

108− benchWithSetup

109− "code actions"

110− 10

111− ( \doc -> do

112− let p = identifierP

113− let change =

114− TextDocumentContentChangeEvent

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

116− _rangeLength = Nothing,

117− _text = "a"

118− }

119− changeDoc doc [change]

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

121− return p

122− )

123− ( \p doc -> do

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

125− ),

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

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

128− let p = identifierP

129− let change =

130− TextDocumentContentChangeEvent

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

132− _rangeLength = Nothing,

133− _text = "a"

134− }

135− changeDoc doc [change]

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

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

138− ]

139− `finally` cleanUp

140−

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

142−

143−examplePackageName :: String

144−examplePackageName = "Cabal"

145−

146−examplePackageVersion :: Version

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

148−

149−examplePackage :: String

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

151−

152−exampleModulePath :: FilePath

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

154−

155−examplesPath :: FilePath

156−examplesPath = "bench/example"

157−

158−data Config = Config

159− { verbose :: !Bool,

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

161− shakeProfiling :: !(Maybe FilePath),

162− outputCSV :: !Bool

163− }

164−

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

166−

167−configP :: Parser Config

168−configP = Config

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

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

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

172−

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

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

175−

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

177−

178−type Experiment = TextDocumentIdentifier -> Session Bool

179−

180−data Bench = forall setup.

181− Bench

182− { name :: !String,

183− samples :: !Natural,

184− benchSetup :: TextDocumentIdentifier -> Session setup,

185− experiment :: setup -> Experiment

186− }

187−

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

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

190− where

191− experiment () = userExperiment

192− benchSetup _ = return ()

193−

194−benchWithSetup ::

195− String ->

196− Natural ->

197− (TextDocumentIdentifier -> Session p) ->

198− (p -> Experiment) ->

199− Bench

200−benchWithSetup = Bench

201−

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

203−runBenchmarks benchmarks = do

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

205−

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

207− output $

208− "TOTAL "

209− <> name

210− <> " = "

211− <> showDuration duration

212− <> " ("

213− <> show samples

214− <> " repetitions)"

215−

216− when (outputCSV ?config) $ do

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

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

219−

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

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

222− $ runSessionWithConfig conf cmd lspTestCaps dir

223− $ do

224− doc <- openDoc exampleModulePath "haskell"

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

226−

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

228− userState <- benchSetup doc

229− let loop 0 = return True

230− loop n = do

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

232− if not res

233− then return False

234− else do

235− output (showDuration t)

236− loop (n -1)

237−

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

239−

240− exitServer

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

242− liftIO $ threadDelay 50000

243−

244− return $ if res then t else -1

245− where

246− cmd =

247− unwords $

248− [ "ghcide",

249− "--lsp",

250− "--cwd",

251− dir,

252− "+RTS",

253− "-S",

254− "-RTS"

255− ]

256− ++ concat

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

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

259− ]

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

261− lspTestCaps =

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

263− conf =

264− defaultConfig

265− { logStdErr = verbose ?config,

266− logMessages = False,

267− logColor = False

268− }

269−

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

271−setup = do

272− alreadyExists <- doesDirectoryExist examplesPath

273− when alreadyExists $ removeDirectoryRecursive examplesPath

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

275− writeFile

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

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

278−

279− whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True

280−

281− return $ removeDirectoryRecursive examplesPath

282−

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

284−exitServer :: Session ()

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

286−

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

docs/Setup.md+1−38

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

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−

6857## ghc: readCreateProcess: does not exist

6958

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

71−

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

7360

7461And we figured a hack around for this:

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

8269

8370## Could not find module ...

8471

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

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

10073

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

10275

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

133106## Docker stack builds

134107

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

136−

137−## stty error on Windows + Stack

138−

139−If you get an error like:

140−

141−```

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

143−```

144−

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

exe/Arguments.hs−6

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

1111 ,argsCwd :: Maybe FilePath

1212 ,argFiles :: [FilePath]

1313 ,argsVersion :: Bool

14− ,argsShakeProfiling :: Maybe FilePath

15− ,argsTesting :: Bool

16− ,argsThreads :: Int

1714 }

1815

1916getArguments :: IO Arguments

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

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

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

3229 <*> 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+81−566

@@ -2,32 +2,18 @@

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

86module Main(main) where

10−import Linker (initDynLinker)

11−import Data.IORef

12−import NameCache

13−import Packages

14−import Module

158import Arguments

16−import Control.Concurrent.Async

9+import Data.Maybe

10+import Data.List.Extra

11+import System.FilePath

1712import Control.Concurrent.Extra

1813import Control.Exception

1914import Control.Monad.Extra

20−import Control.Monad.IO.Class

2115import Data.Default

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

16+import System.Time.Extra

3117import Development.IDE.Core.FileStore

3218import Development.IDE.Core.OfInterest

3319import Development.IDE.Core.Service

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

4026import Development.IDE.Types.Options

4127import Development.IDE.Types.Logger

4228import Development.IDE.GHC.Util

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

29+import qualified Data.Text as T

30+import qualified Data.Text.IO as T

4731import Language.Haskell.LSP.Messages

48−import Language.Haskell.LSP.Types

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

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

33+import Linker

34+import Data.Version

5035import Development.IDE.LSP.LanguageServer

51−import qualified System.Directory.Extra as IO

36+import System.Directory.Extra as IO

5237import System.Environment

5338import System.IO

5439import System.Exit

55−import System.FilePath

56−import System.Directory

57−import System.Time.Extra

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

5940import Paths_ghcide

60−import Development.GitRev

61−import Development.Shake (Action, action)

62−import qualified Data.HashSet as HashSet

63−import qualified Data.HashMap.Strict as HM

41+import Development.Shake hiding (Env)

42+import qualified Data.Set as Set

6443import qualified Data.Map.Strict as Map

65−import qualified Crypto.Hash.SHA1 as H

66−import qualified Data.ByteString.Char8 as B

67−import Data.ByteString.Base16 (encode)

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

69−import GhcMonad

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

44+

7145import GHC hiding (def)

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

73−import Data.Either.Extra

46+import qualified GHC.Paths

7447

75−import HIE.Bios.Cradle

76−import HIE.Bios.Types

48+import HIE.Bios

7749

78−import Utils

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

51+getLibdir :: IO FilePath

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

7953

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

54+ghcideVersion :: String

55+ghcideVersion = "ghcide version: " <> showVersion version

56+ <> " (GHC: " <> VERSION_ghc <> ")"

9057

9158main :: IO ()

9259main = do

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

9461 -- then the language server will not work

9562 Arguments{..} <- getArguments

9663

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

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

64+ if argsVersion then putStrLn ghcideVersion >> exitSuccess

65+ else hPutStrLn stderr {- see WARNING above -} ghcideVersion

9966

10067 -- lock to avoid overlapping output on stdout

10168 lock <- newLock

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

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

10471

105− whenJust argsCwd IO.setCurrentDirectory

72+ whenJust argsCwd setCurrentDirectory

10673

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

74+ dir <- getCurrentDirectory

11675

11776 if argLSP then do

11877 t <- offsetTime

11978 hPutStrLn stderr "Starting LSP server..."

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

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

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

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

12281 t <- t

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

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

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

84+ session <- loadSession dir

85+ let options = (defaultIdeOptions $ return session)

86+ { optReportProgress = clientSupportsProgress caps }

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

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

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

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

14091

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

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

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

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

14695

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

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

14897 cradles <- mapM findCradle files

14998 let ucradles = nubOrd cradles

15099 let n = length ucradles

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

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

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

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

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

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

105+ when (isNothing x) $ print cradle

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

107+ cradleToSession cradle

108+

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

153110 vfs <- makeVFSHandle

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)

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

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

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

114+ cradle <- Map.lookup file filesToCradles

115+ Map.lookup cradle cradlesToSessions

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

117+

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

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

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

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

161122 when (failed /= []) $

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

163124

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

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

166− return ()

127+

128+ unless (null failed) exitFailure

129+

167130

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

169132expandFiles = concatMapM $ \x -> do

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

172135 let recurse "." = True

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

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

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

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

176139 when (null files) $

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

178141 return files

@@ -181,414 +144,42 @@ expandFiles = concatMapM $ \x -> do

181144kick :: Action ()

182145kick = do

183146 files <- getFilesOfInterest

184− void $ uses TypeCheck $ HashSet.toList files

147+ void $ uses TypeCheck $ Set.toList files

185148

186149-- | Print an LSP event.

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

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

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

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

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

153+ withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,) diags

191154showEvent lock e = withLock lock $ print e

192155

193156

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

157+cradleToSession :: Cradle -> IO HscEnvEq

158+cradleToSession cradle = do

159+ opts <- either throwIO return =<< getCompilerOptions "" cradle

208160 libdir <- getLibdir

209− env <- runGhc (Just libdir) getSession

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

162+ _targets <- initSession opts

163+ getSession

210164 initDynLinker env

211− pure env

212−

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

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

215−-- directories

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

217−-- to canonicalise it.

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

219−targetToFile is (TargetModule mod) = do

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

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

222− mapM (fmap toNormalizedFilePath' . canonicalizePath) fps

223−targetToFile _ (TargetFile f _) = do

224− f' <- canonicalizePath f

225− return [toNormalizedFilePath' f']

226−

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

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

229−

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

165+ newHscEnvEq env

386166

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)

403167

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

169+loadSession dir = do

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

171+ res <- findCradle v

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

173+ -- try and normalise that

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

175+ res' <- traverse makeAbsolute res

176+ return $ normalise <$> res'

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

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

179+ cradleToSession c

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

404181

405182

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−

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

593184--

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

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

605196 res <- onceFork $ op k

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

607198 Just res -> return (mp, res)

608−

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

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

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

612− let dflags'' =

613− -- disabled, generated directly by ghcide instead

614− flip gopt_unset Opt_WriteInterface $

615− -- disabled, generated directly by ghcide instead

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

617− dontWriteHieFiles $

618− setIgnoreInterfacePragmas $

619− setLinkerOptions $

620− disableOptimisation $

621− makeDynFlagsAbsolute compRoot dflags'

622− -- initPackages parses the -package flags and

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

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

625− return (final_df, targets)

626−

627−

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

629−-- (HscInterpreted) which implies LinkInMemory

630−-- HscInterpreted

631−setLinkerOptions :: DynFlags -> DynFlags

632−setLinkerOptions df = df {

633− ghcLink = LinkInMemory

634− , hscTarget = HscNothing

635− , ghcMode = CompManager

636− }

637−

638−setIgnoreInterfacePragmas :: DynFlags -> DynFlags

639−setIgnoreInterfacePragmas df =

640− gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges

641−

642−disableOptimisation :: DynFlags -> DynFlags

643−disableOptimisation df = updOptLevel 0 df

644−

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

646−setHiDir f d =

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

648− d { hiDir = Just f}

649−

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

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

652− where

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

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

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

656−

657−-- | Sub directory for the cache path

658−cacheDir :: String

659−cacheDir = "ghcide"

660−

661−notifyCradleLoaded :: FilePath -> FromServerMessage

662−notifyCradleLoaded fp =

663− NotCustomServer $

664− NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $

665− toJSON fp

666−

667−cradleLoadedMethod :: T.Text

668−cradleLoadedMethod = "ghcide/cradle/loaded"

669−

670−ghcVersionChecker :: IO VersionCheck

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

672−

673−checkGhcVersion :: IO (Maybe HscEnvEq)

674−checkGhcVersion = do

675− res <- ghcVersionChecker

676− case res of

677− Failure err -> do

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

679− return Nothing

680− Mismatch {..} ->

681− return $ Just GhcVersionMismatch {..}

682− _ ->

683− return Nothing

exe/Utils.hsdeleted−9

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

1−module Utils (getLibdir) where

2−

3−import qualified GHC.Paths

4−import System.Environment

5−import Data.Maybe

6−

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

8−getLibdir :: IO FilePath

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

fmt.sh+1−1

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

11#!/usr/bin/env bash

22set -eou pipefail

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

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

ghcide.cabal+19−156

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

22build-type: Simple

33category: Development

44name: ghcide

5−version: 0.2.0

5+version: 0.0.5

66license: Apache-2.0

77license-file: LICENSE

88author: Digital Asset

99maintainer: Digital Asset

10−copyright: Digital Asset 2018-2020

10+copyright: Digital Asset 2018-2019

1111synopsis: The core of an IDE

1212description:

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

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

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

18+ test/data/GotoHover.hs

2519

2620source-repository head

2721 type: git

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

3630 default-language: Haskell2010

3731 build-depends:

3832 aeson,

39− array,

4033 async,

4134 base == 4.*,

4235 binary,

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

4639 deepseq,

4740 directory,

4841 extra,

49− fuzzy,

5042 filepath,

51− haddock-library >= 1.8,

5243 hashable,

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

54− haskell-lsp == 0.22.*,

44+ haskell-lsp-types >= 0.18,

45+ haskell-lsp >= 0.18,

5546 mtl,

5647 network-uri,

5748 prettyprinter-ansi-terminal,

5849 prettyprinter-ansi-terminal,

5950 prettyprinter,

60− regex-tdfa >= 1.3.1.0,

6151 rope-utf16-splay,

6252 safe-exceptions,

63− shake >= 0.18.4,

53+ shake >= 0.17.5,

6454 sorted-list,

6555 stm,

6656 syb,

6757 text,

6858 time,

6959 transformers,

70− unordered-containers >= 0.2.10.0,

60+ unordered-containers,

7161 utf8-string,

7262 hslogger

7363 if flag(ghc-lib)

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

8070 ghc-boot-th,

8171 ghc-boot,

8272 ghc >= 8.4

83− if os(windows)

84− build-depends:

85− Win32

86− else

73+ if !os(windows)

8774 build-depends:

8875 unix

8976 c-sources:

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

10996 include-dirs:

11097 include

11198 exposed-modules:

112− Development.IDE.Compat

113− Development.IDE.Core.Debouncer

11499 Development.IDE.Core.FileStore

115− Development.IDE.Core.IdeConfiguration

116100 Development.IDE.Core.OfInterest

117101 Development.IDE.Core.PositionMapping

118102 Development.IDE.Core.Rules

119103 Development.IDE.Core.RuleTypes

120104 Development.IDE.Core.Service

121105 Development.IDE.Core.Shake

122− Development.IDE.GHC.Error

123106 Development.IDE.GHC.Util

124107 Development.IDE.Import.DependencyInformation

125− Development.IDE.LSP.HoverDefinition

126108 Development.IDE.LSP.LanguageServer

127− Development.IDE.LSP.Outline

128109 Development.IDE.LSP.Protocol

129110 Development.IDE.LSP.Server

130− Development.IDE.Spans.Common

131111 Development.IDE.Types.Diagnostics

132112 Development.IDE.Types.Location

133113 Development.IDE.Types.Logger

134114 Development.IDE.Types.Options

135− Development.IDE.Plugin

136− Development.IDE.Plugin.Completions

137− Development.IDE.Plugin.CodeAction

138115 other-modules:

116+ Development.IDE.Core.Debouncer

139117 Development.IDE.Core.Compile

140118 Development.IDE.Core.Preprocessor

141− Development.IDE.Core.FileExists

142119 Development.IDE.GHC.Compat

143120 Development.IDE.GHC.CPP

121+ Development.IDE.GHC.Error

144122 Development.IDE.GHC.Orphans

145123 Development.IDE.GHC.Warnings

146− Development.IDE.GHC.WithDynFlags

147124 Development.IDE.Import.FindImports

125+ Development.IDE.LSP.CodeAction

126+ Development.IDE.LSP.Definition

127+ Development.IDE.LSP.Hover

148128 Development.IDE.LSP.Notifications

149129 Development.IDE.Spans.AtPoint

150130 Development.IDE.Spans.Calculate

151131 Development.IDE.Spans.Documentation

152132 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

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

167134

168−executable ghcide-test-preprocessor

169− default-language: Haskell2010

170− hs-source-dirs: test/preprocessor

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

172− main-is: Main.hs

173− build-depends:

174− base == 4.*

175−

176135executable ghcide

177136 if flag(ghc-lib)

178137 buildable: False

179138 default-language: Haskell2010

180139 hs-source-dirs: exe

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"

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

191141 main-is: Main.hs

192142 build-depends:

193− time,

194− async,

195143 hslogger,

196− aeson,

197144 base == 4.*,

198− binary,

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

200− bytestring,

201145 containers,

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

203146 data-default,

204− deepseq,

205147 directory,

206148 extra,

207149 filepath,

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

209150 ghc-paths,

210151 ghc,

211− gitrev,

212− hashable,

213152 haskell-lsp,

214− haskell-lsp-types,

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

153+ hie-bios >= 0.2 && < 0.3,

216154 ghcide,

217155 optparse-applicative,

218156 shake,

219− text,

220− unordered-containers

157+ text

221158 other-modules:

222− Utils

223159 Arguments

224160 Paths_ghcide

225161

226162 default-extensions:

227− BangPatterns

228− DeriveFunctor

229− DeriveGeneric

230− GeneralizedNewtypeDeriving

231− LambdaCase

232− NamedFieldPuns

233− OverloadedStrings

234163 RecordWildCards

235− ScopedTypeVariables

236− StandaloneDeriving

237164 TupleSections

238− TypeApplications

239165 ViewPatterns

240166

241167test-suite ghcide-tests

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

244170 type: exitcode-stdio-1.0

245171 default-language: Haskell2010

246172 build-tool-depends:

247− ghcide:ghcide,

248− ghcide:ghcide-test-preprocessor

173+ ghcide:ghcide

249174 build-depends:

250− aeson,

251175 base,

252176 bytestring,

253177 containers,

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

264188 --------------------------------------------------------------

265189 ghcide,

266190 ghc-typelits-knownnat,

267− haddock-library,

268− haskell-lsp,

269191 haskell-lsp-types,

270− network-uri,

271192 lens,

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

193+ lsp-test >= 0.8,

273194 parser-combinators,

274− QuickCheck,

275− quickcheck-instances,

276− rope-utf16-splay,

277− shake,

278195 tasty,

279− tasty-expected-failure,

280196 tasty-hunit,

281− tasty-quickcheck,

282− tasty-rerun,

197+ tasty-expected-failure,

283198 text

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

285200 include-dirs: include

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

289204 Development.IDE.Test

290205 Development.IDE.Test.Runfiles

291206 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

338207 OverloadedStrings

339− RecordWildCards

340− ScopedTypeVariables

341− StandaloneDeriving

342− TupleSections

343− TypeApplications

344− ViewPatterns

hie.yaml+1−12

@@ -1,12 +1 @@

1−cradle:

2− cabal:

3− - path: "./src"

4− component: "ghcide:lib:ghcide"

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"

1+cradle: {stack}

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

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

1−

2−

3−{-

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

5−

6−Main functions for .hie file generation

7−-}

8−{- HLINT ignore -}

9−{-# LANGUAGE OverloadedStrings #-}

10−{-# LANGUAGE FlexibleInstances #-}

11−{-# LANGUAGE UndecidableInstances #-}

12−{-# LANGUAGE FlexibleContexts #-}

13−{-# LANGUAGE TypeSynonymInstances #-}

14−{-# LANGUAGE ScopedTypeVariables #-}

15−{-# LANGUAGE TypeFamilies #-}

16−{-# LANGUAGE TypeApplications #-}

17−{-# LANGUAGE AllowAmbiguousTypes #-}

18−{-# LANGUAGE ViewPatterns #-}

19−{-# LANGUAGE DeriveDataTypeable #-}

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

21−

22−import GhcPrelude

23−

24−import Avail ( Avails )

25−import Bag ( Bag, bagToList )

26−import BasicTypes

27−import BooleanFormula

28−import Class ( FunDep )

29−import CoreUtils ( exprType )

30−import ConLike ( conLikeName )

31−import Desugar ( deSugarExpr )

32−import FieldLabel

33−import GHC.Hs

34−import HscTypes

35−import Module ( ModuleName, ml_hs_file )

36−import MonadUtils ( concatMapM, liftIO )

37−import Name ( Name, nameSrcSpan, setNameLoc )

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

39−import SrcLoc

40−import TcHsSyn ( hsLitType, hsPatType )

41−import Type ( mkVisFunTys, Type )

42−import TysWiredIn ( mkListTy, mkSumTy )

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

44−import TcRnTypes

45−import MkIface ( mkIfaceExports )

46−import Panic

47−

48−import HieTypes

49−import HieUtils

50−

51−import qualified Data.Array as A

52−import qualified Data.ByteString as BS

53−import qualified Data.Map as M

54−import qualified Data.Set as S

55−import Data.Data ( Data, Typeable )

56−import Data.List ( foldl1' )

57−import Data.Maybe ( listToMaybe )

58−import Control.Monad.Trans.Reader

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

60−

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

62−

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

64−need to pay attention to the following things:

65−

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

67−

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

69− something the user typed

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

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

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

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

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

75−

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

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

78−

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

80−

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

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

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

84−

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

86−

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

88−

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

90−

91−data ContextInfo

92− = Use -- ^ regular variable

93− | MatchBind

94− | IEThing IEType -- ^ import/export

95− | TyDecl

96− -- | Value binding

97− | ValBind

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

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

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

101− ...

102−

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

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

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

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

107−

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

109−particular location, you would do the following:

110−

111− toHie $ C Use located_name

112−

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

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

115−`SrcSpans`.

116−

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

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

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

120−in HieAst.

121−

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

123−the name.

124−

125−For a function definition `foo`:

126−

127−foo x = x + y

128− where y = x^2

129−

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

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

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

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

134−

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

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

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

138−.hie file.

139−

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

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

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

143−

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

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

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

147−

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

149−

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

151− HsVar _ (L _ var) ->

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

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

154− ]

155− HsConLikeOut _ con ->

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

157− ]

158− ...

159− HsApp _ a b ->

160− [ toHie a

161− , toHie b

162− ]

163−

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

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

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

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

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

169−appropriately annotated symbols contained in the subtree.

170−

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

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

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

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

175−when given a typechecked AST:

176−

177−class Data a => HasType a where

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

179−instance HasType (LHsExpr GhcTc) where

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

181−instance HasType (LHsExpr GhcRn) where

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

183−

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

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

186−

187−-}

188−

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

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

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

192− , Maybe LHsDocString )

193−type TypecheckedSource = LHsBinds GhcTc

194−

195−

196−{- Note [Name Remapping]

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

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

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

200−-}

201−newtype HieState = HieState

202− { name_remapping :: NameEnv Id

203− }

204−

205−initState :: HieState

206−initState = HieState emptyNameEnv

207−

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

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

210−

211−instance ModifyState Name where

212− addSubstitution _ _ hs = hs

213−

214−instance ModifyState Id where

215− addSubstitution mono poly hs =

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

217−

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

219−modifyState = foldr go id

220− where

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

222− go _ f = f

223−

224−type HieM = ReaderT HieState Hsc

225−

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

227−mkHieFile :: ModSummary

228− -> TcGblEnv

229− -> RenamedSource

230− -> BS.ByteString -> Hsc HieFile

231−mkHieFile ms ts rs src = do

232− let tc_binds = tcg_binds ts

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

234− let Just src_file = ml_hs_file $ ms_location ms

235− return $ HieFile

236− { hie_hs_file = src_file

237− , hie_module = ms_mod ms

238− , hie_types = arr

239− , hie_asts = asts'

240− -- mkIfaceExports sorts the AvailInfos for stability

241− , hie_exports = mkIfaceExports (tcg_exports ts)

242− , hie_hs_src = src

243− }

244−

245−getCompressedAsts :: TypecheckedSource -> RenamedSource

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

247−getCompressedAsts ts rs = do

248− asts <- enrichHie ts rs

249− return $ compressTypes asts

250−

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

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

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

254− rasts <- processGrp hsGrp

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

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

257− let spanFile children = case children of

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

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

260− (realSrcSpanEnd $ nodeSpan $ last children)

261−

262− modulify xs =

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

264−

265− asts = HieASTs

266− $ resolveTyVarScopes

267− $ M.map (modulify . mergeSortAsts)

268− $ M.fromListWith (++)

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

270−

271− flat_asts = concat

272− [ tasts

273− , rasts

274− , imps

275− , exps

276− ]

277− return asts

278− where

279− processGrp grp = concatM

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

281− , toHie $ hs_splcds grp

282− , toHie $ hs_tyclds grp

283− , toHie $ hs_derivds grp

284− , toHie $ hs_fixds grp

285− , toHie $ hs_defds grp

286− , toHie $ hs_fords grp

287− , toHie $ hs_warnds grp

288− , toHie $ hs_annds grp

289− , toHie $ hs_ruleds grp

290− ]

291−

292−getRealSpan :: SrcSpan -> Maybe Span

293−getRealSpan (RealSrcSpan sp) = Just sp

294−getRealSpan _ = Nothing

295−

296−grhss_span :: GRHSs p body -> SrcSpan

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

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

299−

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

301−bindingsOnly [] = []

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

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

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

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

306− _ -> bindingsOnly xs

307−

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

309−concatM xs = concat <$> sequence xs

310−

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

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

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

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

315−carry the required info

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

317−-}

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

319−

320−data RContext a = RC RecFieldContext a

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

322−-- ^ context for record fields

323−

324−data IEContext a = IEC IEType a

325−-- ^ context for imports/exports

326−

327−data BindContext a = BC BindType Scope a

328−-- ^ context for imports/exports

329−

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

331−-- ^ context for pattern synonym fields.

332−

333−data SigContext a = SC SigInfo a

334−-- ^ context for type signatures

335−

336−data SigInfo = SI SigType (Maybe Span)

337−

338−data SigType = BindSig | ClassSig | InstSig

339−

340−data RScoped a = RS Scope a

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

342−-- including a itself

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

344−-- let/where bindings

345−

346−-- | Pattern scope

347−data PScoped a = PS (Maybe Span)

348− Scope -- ^ use site of the pattern

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

350− a

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

352−

353−{- Note [TyVar Scopes]

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

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

356−in a separate pass

357−-}

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

359−

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

361−-- ^ First scope remains constant

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

363−-- things to its right, ala RScoped

364−

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

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

367−listScopes _ [] = []

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

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

370− where

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

372− sc = combineScopes scope $ mkScope $ getLoc p

373−

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

375−patScopes

376− :: Maybe Span

377− -> Scope

378− -> Scope

379− -> [LPat (GhcPass p)]

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

381−patScopes rsp useScope patScope xs =

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

383− listScopes patScope (map dL xs)

384−

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

386−tvScopes

387− :: TyVarScope

388− -> Scope

389− -> [LHsTyVarBndr a]

390− -> [TVScoped (LHsTyVarBndr a)]

391−tvScopes tvScope rhsScope xs =

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

393−

394−{- Note [Scoping Rules for SigPat]

395−Explicitly quantified variables in pattern type signatures are not

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

397−are (HsWC and HsIB).

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

399−are brought into the RHS Scope

400−For example

401−foo :: forall a. ...;

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

403−

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

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

406−

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

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

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

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

411−on the the LHsType

412−-}

413−

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

415−

416−type family ProtectedSig a where

417− ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs

418− GhcRn

419− (Shielded (LHsType GhcRn)))

420− ProtectedSig GhcTc = NoExtField

421−

422−class ProtectSig a where

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

424−

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

426− loc (SH _ a) = loc a

427−

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

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

430−

431−instance ProtectSig GhcTc where

432− protectSig _ _ = noExtField

433−

434−instance ProtectSig GhcRn where

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

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

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

438− protectSig _ (XHsWildCardBndrs nec) = noExtCon nec

439−

440−class HasLoc a where

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

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

443− loc :: a -> SrcSpan

444−

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

446− loc (TS _ a) = loc a

447−

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

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

450−

451−instance HasLoc (LHsQTyVars GhcRn) where

452− loc (HsQTvs _ vs) = loc vs

453− loc _ = noSrcSpan

454−

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

456− loc (HsIB _ a) = loc a

457− loc _ = noSrcSpan

458−

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

460− loc (HsWC _ a) = loc a

461− loc _ = noSrcSpan

462−

463−instance HasLoc (Located a) where

464− loc (L l _) = l

465−

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

467− loc [] = noSrcSpan

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

469−

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

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

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

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

474− loc _ = noSrcSpan

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

476− loc (HsValArg tm) = loc tm

477− loc (HsTypeArg _ ty) = loc ty

478− loc (HsArgPar sp) = sp

479−

480−instance HasLoc (HsDataDefn GhcRn) where

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

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

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

484− loc _ = noSrcSpan

485−

486−{- Note [Real DataCon Name]

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

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

489−original datacon name

490−See also Note [Data Constructor Naming]

491−-}

492−class HasRealDataConName p where

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

494−

495−instance HasRealDataConName GhcRn where

496− getRealDataCon _ n = n

497−instance HasRealDataConName GhcTc where

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

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

500−

501−-- | The main worker class

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

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

504−class ToHie a where

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

506−

507−-- | Used to collect type info

508−class Data a => HasType a where

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

510−

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

512− toHie = concatMapM toHie

513−

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

515− toHie = toHie . bagToList

516−

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

518− toHie = maybe (pure []) toHie

519−

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

521− toHie _ = pure []

522−

523−instance ToHie (TScoped NoExtField) where

524− toHie _ = pure []

525−

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

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

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

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

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

531− toHie _ = pure []

532−

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

534− toHie c = case c of

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

536− -> do

537− m <- asks name_remapping

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

539− Just var -> var

540− Nothing-> name'

541− pure

542− [Node

543− (NodeInfo S.empty [] $

544− M.singleton (Right $ varName name)

545− (IdentifierDetails (Just $ varType name')

546− (S.singleton context)))

547− span

548− []]

549− _ -> pure []

550−

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

552− toHie c = case c of

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

554− m <- asks name_remapping

555− let name = case lookupNameEnv m name' of

556− Just var -> varName var

557− Nothing -> name'

558− pure

559− [Node

560− (NodeInfo S.empty [] $

561− M.singleton (Right name)

562− (IdentifierDetails Nothing

563− (S.singleton context)))

564− span

565− []]

566− _ -> pure []

567−

568−-- | Dummy instances - never called

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

570− toHie _ = pure []

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

572− toHie _ = pure []

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

574− toHie _ = pure []

575−instance ToHie (TScoped Type) where

576− toHie _ = pure []

577−

578−instance HasType (LHsBind GhcRn) where

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

580−

581−instance HasType (LHsBind GhcTc) where

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

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

584− _ -> makeNode bind spn

585−

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

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

588−

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

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

591−

592−instance HasType (LHsExpr GhcRn) where

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

594−

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

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

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

598−--

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

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

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

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

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

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

605−--

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

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

608−--

609−-- See #16233

610−instance HasType (LHsExpr GhcTc) where

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

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

613− let tyOpt = case e' of

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

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

616−

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

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

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

620−

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

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

623− HsDo ty _ _ -> Just ty

624− HsMultiIf ty _ -> Just ty

625−

626− _ -> Nothing

627−

628− in

629− case tyOpt of

630− Just t -> makeTypeNode e' spn t

631− Nothing

632− | skipDesugaring e' -> fallback

633− | otherwise -> do

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

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

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

637− where

638− fallback = makeNode e' spn

639−

640− matchGroupType :: MatchGroupTc -> Type

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

642−

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

644− --

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

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

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

648− skipDesugaring :: HsExpr a -> Bool

649− skipDesugaring e = case e of

650− HsVar{} -> False

651− HsUnboundVar{} -> False

652− HsConLikeOut{} -> False

653− HsRecFld{} -> False

654− HsOverLabel{} -> False

655− HsIPVar{} -> False

656− HsWrap{} -> False

657− _ -> True

658−

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

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

661− , ToHie (PScoped (LPat a))

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

663− , ToHie (LHsExpr a)

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

665− , HasType (LHsBind a)

666− , ModifyState (IdP a)

667− , Data (HsBind a)

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

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

670− concatM $ getTypeNode b : case bind of

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

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

673− , toHie matches

674− ]

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

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

677− , toHie rhs

678− ]

679− VarBind{var_rhs = expr} ->

680− [ toHie expr

681− ]

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

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

684− toHie $ fmap (BC context scope) binds

685− ]

686− PatSynBind _ psb ->

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

688− ]

689− XHsBindsLR _ -> []

690−

691−instance ( ToHie (LMatch a body)

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

693− toHie mg = concatM $ case mg of

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

695− [ pure $ locOnly span

696− , toHie alts

697− ]

698− MG{} -> []

699− XMatchGroup _ -> []

700−

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

702− , ToHie (PScoped (LPat a))

703− , ToHie (HsPatSynDir a)

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

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

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

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

708− , toHie $ toBind dets

709− , toHie $ PS Nothing lhsScope NoScope pat

710− , toHie dir

711− ]

712− where

713− lhsScope = combineScopes varScope detScope

714− varScope = mkLScope var

715− detScope = case dets of

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

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

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

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

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

721− detSpan = case detScope of

722− LocalScope a -> Just a

723− _ -> Nothing

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

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

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

727− XPatSynBind _ -> []

728−

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

730− ) => ToHie (HsPatSynDir a) where

731− toHie dir = case dir of

732− ExplicitBidirectional mg -> toHie mg

733− _ -> pure []

734−

735−instance ( a ~ GhcPass p

736− , ToHie body

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

738− , ToHie (PScoped (LPat a))

739− , ToHie (GRHSs a body)

740− , Data (Match a body)

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

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

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

744− [ toHie mctx

745− , let rhsScope = mkScope $ grhss_span grhss

746− in toHie $ patScopes Nothing rhsScope NoScope pats

747− , toHie grhss

748− ]

749− XMatch _ -> []

750−

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

752− ) => ToHie (HsMatchContext a) where

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

754− toHie (StmtCtxt a) = toHie a

755− toHie _ = pure []

756−

757−instance ( ToHie (HsMatchContext a)

758− ) => ToHie (HsStmtContext a) where

759− toHie (PatGuard a) = toHie a

760− toHie (ParStmtCtxt a) = toHie a

761− toHie (TransStmtCtxt a) = toHie a

762− toHie _ = pure []

763−

764−instance ( a ~ GhcPass p

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

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

767− , ToHie (LHsExpr a)

768− , ToHie (TScoped (LHsSigWcType a))

769− , ProtectSig a

770− , ToHie (TScoped (ProtectedSig a))

771− , HasType (LPat a)

772− , Data (HsSplice a)

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

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

775− concatM $ getTypeNode lpat : case opat of

776− WildPat _ ->

777− []

778− VarPat _ lname ->

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

780− ]

781− LazyPat _ p ->

782− [ toHie $ PS rsp scope pscope p

783− ]

784− AsPat _ lname pat ->

785− [ toHie $ C (PatternBind scope

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

787− rsp)

788− lname

789− , toHie $ PS rsp scope pscope pat

790− ]

791− ParPat _ pat ->

792− [ toHie $ PS rsp scope pscope pat

793− ]

794− BangPat _ pat ->

795− [ toHie $ PS rsp scope pscope pat

796− ]

797− ListPat _ pats ->

798− [ toHie $ patScopes rsp scope pscope pats

799− ]

800− TuplePat _ pats _ ->

801− [ toHie $ patScopes rsp scope pscope pats

802− ]

803− SumPat _ pat _ _ ->

804− [ toHie $ PS rsp scope pscope pat

805− ]

806− ConPatIn c dets ->

807− [ toHie $ C Use c

808− , toHie $ contextify dets

809− ]

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

811− [ toHie $ C Use $ fmap conLikeName con

812− , toHie $ contextify dets

813− ]

814− ViewPat _ expr pat ->

815− [ toHie expr

816− , toHie $ PS rsp scope pscope pat

817− ]

818− SplicePat _ sp ->

819− [ toHie $ L ospan sp

820− ]

821− LitPat _ _ ->

822− []

823− NPat _ _ _ _ ->

824− []

825− NPlusKPat _ n _ _ _ _ ->

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

827− ]

828− SigPat _ pat sig ->

829− [ toHie $ PS rsp scope pscope pat

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

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

832− (protectSig @a cscope sig)

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

834− ]

835− CoPat _ _ _ _ ->

836− []

837− XPat _ -> []

838− where

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

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

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

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

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

844− where

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

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

847− scoped_fds = listScopes pscope fds

848−

849−instance ( ToHie body

850− , ToHie (LGRHS a body)

851− , ToHie (RScoped (LHsLocalBinds a))

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

853− toHie grhs = concatM $ case grhs of

854− GRHSs _ grhss binds ->

855− [ toHie grhss

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

857− ]

858− XGRHSs _ -> []

859−

860−instance ( ToHie (Located body)

861− , ToHie (RScoped (GuardLStmt a))

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

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

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

865− GRHS _ guards body ->

866− [ toHie $ listScopes (mkLScope body) guards

867− , toHie body

868− ]

869− XGRHS _ -> []

870−

871−instance ( a ~ GhcPass p

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

873− , HasType (LHsExpr a)

874− , ToHie (PScoped (LPat a))

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

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

877− , ToHie (RContext (HsRecordBinds a))

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

879− , ToHie (ArithSeqInfo a)

880− , ToHie (LHsCmdTop a)

881− , ToHie (RScoped (GuardLStmt a))

882− , ToHie (RScoped (LHsLocalBinds a))

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

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

885− , Data (HsExpr a)

886− , Data (HsSplice a)

887− , Data (HsTupArg a)

888− , Data (AmbiguousFieldOcc a)

889− , (HasRealDataConName a)

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

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

892− HsVar _ (L _ var) ->

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

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

895− ]

896− HsUnboundVar _ _ ->

897− []

898− HsConLikeOut _ con ->

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

900− ]

901− HsRecFld _ fld ->

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

903− ]

904− HsOverLabel _ _ _ -> []

905− HsIPVar _ _ -> []

906− HsOverLit _ _ -> []

907− HsLit _ _ -> []

908− HsLam _ mg ->

909− [ toHie mg

910− ]

911− HsLamCase _ mg ->

912− [ toHie mg

913− ]

914− HsApp _ a b ->

915− [ toHie a

916− , toHie b

917− ]

918− HsAppType _ expr sig ->

919− [ toHie expr

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

921− ]

922− OpApp _ a b c ->

923− [ toHie a

924− , toHie b

925− , toHie c

926− ]

927− NegApp _ a _ ->

928− [ toHie a

929− ]

930− HsPar _ a ->

931− [ toHie a

932− ]

933− SectionL _ a b ->

934− [ toHie a

935− , toHie b

936− ]

937− SectionR _ a b ->

938− [ toHie a

939− , toHie b

940− ]

941− ExplicitTuple _ args _ ->

942− [ toHie args

943− ]

944− ExplicitSum _ _ _ expr ->

945− [ toHie expr

946− ]

947− HsCase _ expr matches ->

948− [ toHie expr

949− , toHie matches

950− ]

951− HsIf _ _ a b c ->

952− [ toHie a

953− , toHie b

954− , toHie c

955− ]

956− HsMultiIf _ grhss ->

957− [ toHie grhss

958− ]

959− HsLet _ binds expr ->

960− [ toHie $ RS (mkLScope expr) binds

961− , toHie expr

962− ]

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

964− [ pure $ locOnly ispan

965− , toHie $ listScopes NoScope stmts

966− ]

967− ExplicitList _ _ exprs ->

968− [ toHie exprs

969− ]

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

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

972− -- See Note [Real DataCon Name]

973− , toHie $ RC RecFieldAssign $ binds

974− ]

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

976− [ toHie expr

977− , toHie $ map (RC RecFieldAssign) upds

978− ]

979− ExprWithTySig _ expr sig ->

980− [ toHie expr

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

982− ]

983− ArithSeq _ _ info ->

984− [ toHie info

985− ]

986− HsSCC _ _ _ expr ->

987− [ toHie expr

988− ]

989− HsCoreAnn _ _ _ expr ->

990− [ toHie expr

991− ]

992− HsProc _ pat cmdtop ->

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

994− , toHie cmdtop

995− ]

996− HsStatic _ expr ->

997− [ toHie expr

998− ]

999− HsTick _ _ expr ->

1000− [ toHie expr

1001− ]

1002− HsBinTick _ _ _ expr ->

1003− [ toHie expr

1004− ]

1005− HsTickPragma _ _ _ _ expr ->

1006− [ toHie expr

1007− ]

1008− HsWrap _ _ a ->

1009− [ toHie $ L mspan a

1010− ]

1011− HsBracket _ b ->

1012− [ toHie b

1013− ]

1014− HsRnBracketOut _ b p ->

1015− [ toHie b

1016− , toHie p

1017− ]

1018− HsTcBracketOut _ b p ->

1019− [ toHie b

1020− , toHie p

1021− ]

1022− HsSpliceE _ x ->

1023− [ toHie $ L mspan x

1024− ]

1025− XExpr _ -> []

1026−

1027−instance ( a ~ GhcPass p

1028− , ToHie (LHsExpr a)

1029− , Data (HsTupArg a)

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

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

1032− Present _ expr ->

1033− [ toHie expr

1034− ]

1035− Missing _ -> []

1036− XTupArg _ -> []

1037−

1038−instance ( a ~ GhcPass p

1039− , ToHie (PScoped (LPat a))

1040− , ToHie (LHsExpr a)

1041− , ToHie (SigContext (LSig a))

1042− , ToHie (RScoped (LHsLocalBinds a))

1043− , ToHie (RScoped (ApplicativeArg a))

1044− , ToHie (Located body)

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

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

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

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

1049− LastStmt _ body _ _ ->

1050− [ toHie body

1051− ]

1052− BindStmt _ pat body _ _ ->

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

1054− , toHie body

1055− ]

1056− ApplicativeStmt _ stmts _ ->

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

1058− ]

1059− BodyStmt _ body _ _ ->

1060− [ toHie body

1061− ]

1062− LetStmt _ binds ->

1063− [ toHie $ RS scope binds

1064− ]

1065− ParStmt _ parstmts _ _ ->

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

1067− toHie $ listScopes NoScope stmts)

1068− parstmts

1069− ]

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

1071− [ toHie $ listScopes scope stmts

1072− , toHie using

1073− , toHie by

1074− ]

1075− RecStmt {recS_stmts = stmts} ->

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

1077− ]

1078− XStmtLR _ -> []

1079−

1080−instance ( ToHie (LHsExpr a)

1081− , ToHie (PScoped (LPat a))

1082− , ToHie (BindContext (LHsBind a))

1083− , ToHie (SigContext (LSig a))

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

1085− , Data (HsLocalBinds a)

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

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

1088− EmptyLocalBinds _ -> []

1089− HsIPBinds _ _ -> []

1090− HsValBinds _ valBinds ->

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

1092− valBinds

1093− ]

1094− XHsLocalBindsLR _ -> []

1095−

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

1097− , ToHie (SigContext (LSig a))

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

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

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

1101− ValBinds _ binds sigs ->

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

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

1104− ]

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

1106−

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

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

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

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

1111− ]

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

1113− toHie (RS sc (NValBinds binds sigs)) = concatM $

1114− [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)

1115− , toHie $ fmap (SC (SI BindSig Nothing)) sigs

1116− ]

1117−

1118−instance ( ToHie (RContext (LHsRecField a arg))

1119− ) => ToHie (RContext (HsRecFields a arg)) where

1120− toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields

1121−

1122−instance ( ToHie (RFContext (Located label))

1123− , ToHie arg

1124− , HasLoc arg

1125− , Data label

1126− , Data arg

1127− ) => ToHie (RContext (LHsRecField' label arg)) where

1128− toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of

1129− HsRecField label expr _ ->

1130− [ toHie $ RFC c (getRealSpan $ loc expr) label

1131− , toHie expr

1132− ]

1133−

1134−removeDefSrcSpan :: Name -> Name

1135−removeDefSrcSpan n = setNameLoc n noSrcSpan

1136−

1137−instance ToHie (RFContext (LFieldOcc GhcRn)) where

1138− toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1139− FieldOcc name _ ->

1140− [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)

1141− ]

1142− XFieldOcc _ -> []

1143−

1144−instance ToHie (RFContext (LFieldOcc GhcTc)) where

1145− toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1146− FieldOcc var _ ->

1147− let var' = setVarName var (removeDefSrcSpan $ varName var)

1148− in [ toHie $ C (RecField c rhs) (L nspan var')

1149− ]

1150− XFieldOcc _ -> []

1151−

1152−instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where

1153− toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1154− Unambiguous name _ ->

1155− [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name

1156− ]

1157− Ambiguous _name _ ->

1158− [ ]

1159− XAmbiguousFieldOcc _ -> []

1160−

1161−instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where

1162− toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1163− Unambiguous var _ ->

1164− let var' = setVarName var (removeDefSrcSpan $ varName var)

1165− in [ toHie $ C (RecField c rhs) (L nspan var')

1166− ]

1167− Ambiguous var _ ->

1168− let var' = setVarName var (removeDefSrcSpan $ varName var)

1169− in [ toHie $ C (RecField c rhs) (L nspan var')

1170− ]

1171− XAmbiguousFieldOcc _ -> []

1172−

1173−instance ( a ~ GhcPass p

1174− , ToHie (PScoped (LPat a))

1175− , ToHie (BindContext (LHsBind a))

1176− , ToHie (LHsExpr a)

1177− , ToHie (SigContext (LSig a))

1178− , ToHie (RScoped (HsValBindsLR a a))

1179− , Data (StmtLR a a (Located (HsExpr a)))

1180− , Data (HsLocalBinds a)

1181− ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where

1182− toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM

1183− [ toHie $ PS Nothing sc NoScope pat

1184− , toHie expr

1185− ]

1186− toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM

1187− [ toHie $ listScopes NoScope stmts

1188− , toHie $ PS Nothing sc NoScope pat

1189− ]

1190− toHie (RS _ (XApplicativeArg _)) = pure []

1191−

1192−instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where

1193− toHie (PrefixCon args) = toHie args

1194− toHie (RecCon rec) = toHie rec

1195− toHie (InfixCon a b) = concatM [ toHie a, toHie b]

1196−

1197−instance ( ToHie (LHsCmd a)

1198− , Data (HsCmdTop a)

1199− ) => ToHie (LHsCmdTop a) where

1200− toHie (L span top) = concatM $ makeNode top span : case top of

1201− HsCmdTop _ cmd ->

1202− [ toHie cmd

1203− ]

1204− XCmdTop _ -> []

1205−

1206−instance ( a ~ GhcPass p

1207− , ToHie (PScoped (LPat a))

1208− , ToHie (BindContext (LHsBind a))

1209− , ToHie (LHsExpr a)

1210− , ToHie (MatchGroup a (LHsCmd a))

1211− , ToHie (SigContext (LSig a))

1212− , ToHie (RScoped (HsValBindsLR a a))

1213− , Data (HsCmd a)

1214− , Data (HsCmdTop a)

1215− , Data (StmtLR a a (Located (HsCmd a)))

1216− , Data (HsLocalBinds a)

1217− , Data (StmtLR a a (Located (HsExpr a)))

1218− ) => ToHie (LHsCmd (GhcPass p)) where

1219− toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of

1220− HsCmdArrApp _ a b _ _ ->

1221− [ toHie a

1222− , toHie b

1223− ]

1224− HsCmdArrForm _ a _ _ cmdtops ->

1225− [ toHie a

1226− , toHie cmdtops

1227− ]

1228− HsCmdApp _ a b ->

1229− [ toHie a

1230− , toHie b

1231− ]

1232− HsCmdLam _ mg ->

1233− [ toHie mg

1234− ]

1235− HsCmdPar _ a ->

1236− [ toHie a

1237− ]

1238− HsCmdCase _ expr alts ->

1239− [ toHie expr

1240− , toHie alts

1241− ]

1242− HsCmdIf _ _ a b c ->

1243− [ toHie a

1244− , toHie b

1245− , toHie c

1246− ]

1247− HsCmdLet _ binds cmd' ->

1248− [ toHie $ RS (mkLScope cmd') binds

1249− , toHie cmd'

1250− ]

1251− HsCmdDo _ (L ispan stmts) ->

1252− [ pure $ locOnly ispan

1253− , toHie $ listScopes NoScope stmts

1254− ]

1255− HsCmdWrap _ _ _ -> []

1256− XCmd _ -> []

1257−

1258−instance ToHie (TyClGroup GhcRn) where

1259− toHie TyClGroup{ group_tyclds = classes

1260− , group_roles = roles

1261− , group_kisigs = sigs

1262− , group_instds = instances } =

1263− concatM

1264− [ toHie classes

1265− , toHie sigs

1266− , toHie roles

1267− , toHie instances

1268− ]

1269− toHie (XTyClGroup _) = pure []

1270−

1271−instance ToHie (LTyClDecl GhcRn) where

1272− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1273− FamDecl {tcdFam = fdecl} ->

1274− [ toHie (L span fdecl)

1275− ]

1276− SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->

1277− [ toHie $ C (Decl SynDec $ getRealSpan span) name

1278− , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars

1279− , toHie typ

1280− ]

1281− DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->

1282− [ toHie $ C (Decl DataDec $ getRealSpan span) name

1283− , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars

1284− , toHie defn

1285− ]

1286− where

1287− quant_scope = mkLScope $ dd_ctxt defn

1288− rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc

1289− sig_sc = maybe NoScope mkLScope $ dd_kindSig defn

1290− con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn

1291− deriv_sc = mkLScope $ dd_derivs defn

1292− ClassDecl { tcdCtxt = context

1293− , tcdLName = name

1294− , tcdTyVars = vars

1295− , tcdFDs = deps

1296− , tcdSigs = sigs

1297− , tcdMeths = meths

1298− , tcdATs = typs

1299− , tcdATDefs = deftyps

1300− } ->

1301− [ toHie $ C (Decl ClassDec $ getRealSpan span) name

1302− , toHie context

1303− , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars

1304− , toHie deps

1305− , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs

1306− , toHie $ fmap (BC InstanceBind ModuleScope) meths

1307− , toHie typs

1308− , concatMapM (pure . locOnly . getLoc) deftyps

1309− , toHie deftyps

1310− ]

1311− where

1312− context_scope = mkLScope context

1313− rhs_scope = foldl1' combineScopes $ map mkScope

1314− [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]

1315− XTyClDecl _ -> []

1316−

1317−instance ToHie (LFamilyDecl GhcRn) where

1318− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1319− FamilyDecl _ info name vars _ sig inj ->

1320− [ toHie $ C (Decl FamDec $ getRealSpan span) name

1321− , toHie $ TS (ResolvedScopes [rhsSpan]) vars

1322− , toHie info

1323− , toHie $ RS injSpan sig

1324− , toHie inj

1325− ]

1326− where

1327− rhsSpan = sigSpan `combineScopes` injSpan

1328− sigSpan = mkScope $ getLoc sig

1329− injSpan = maybe NoScope (mkScope . getLoc) inj

1330− XFamilyDecl _ -> []

1331−

1332−instance ToHie (FamilyInfo GhcRn) where

1333− toHie (ClosedTypeFamily (Just eqns)) = concatM $

1334− [ concatMapM (pure . locOnly . getLoc) eqns

1335− , toHie $ map go eqns

1336− ]

1337− where

1338− go (L l ib) = TS (ResolvedScopes [mkScope l]) ib

1339− toHie _ = pure []

1340−

1341−instance ToHie (RScoped (LFamilyResultSig GhcRn)) where

1342− toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of

1343− NoSig _ ->

1344− []

1345− KindSig _ k ->

1346− [ toHie k

1347− ]

1348− TyVarSig _ bndr ->

1349− [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr

1350− ]

1351− XFamilyResultSig _ -> []

1352−

1353−instance ToHie (Located (FunDep (Located Name))) where

1354− toHie (L span fd@(lhs, rhs)) = concatM $

1355− [ makeNode fd span

1356− , toHie $ map (C Use) lhs

1357− , toHie $ map (C Use) rhs

1358− ]

1359−

1360−instance (ToHie rhs, HasLoc rhs)

1361− => ToHie (TScoped (FamEqn GhcRn rhs)) where

1362− toHie (TS _ f) = toHie f

1363−

1364−instance (ToHie rhs, HasLoc rhs)

1365− => ToHie (FamEqn GhcRn rhs) where

1366− toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $

1367− [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var

1368− , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1369− , toHie pats

1370− , toHie rhs

1371− ]

1372− where scope = combineScopes patsScope rhsScope

1373− patsScope = mkScope (loc pats)

1374− rhsScope = mkScope (loc rhs)

1375− toHie (XFamEqn _) = pure []

1376−

1377−instance ToHie (LInjectivityAnn GhcRn) where

1378− toHie (L span ann) = concatM $ makeNode ann span : case ann of

1379− InjectivityAnn lhs rhs ->

1380− [ toHie $ C Use lhs

1381− , toHie $ map (C Use) rhs

1382− ]

1383−

1384−instance ToHie (HsDataDefn GhcRn) where

1385− toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM

1386− [ toHie ctx

1387− , toHie mkind

1388− , toHie cons

1389− , toHie derivs

1390− ]

1391− toHie (XHsDataDefn _) = pure []

1392−

1393−instance ToHie (HsDeriving GhcRn) where

1394− toHie (L span clauses) = concatM

1395− [ pure $ locOnly span

1396− , toHie clauses

1397− ]

1398−

1399−instance ToHie (LHsDerivingClause GhcRn) where

1400− toHie (L span cl) = concatM $ makeNode cl span : case cl of

1401− HsDerivingClause _ strat (L ispan tys) ->

1402− [ toHie strat

1403− , pure $ locOnly ispan

1404− , toHie $ map (TS (ResolvedScopes [])) tys

1405− ]

1406− XHsDerivingClause _ -> []

1407−

1408−instance ToHie (Located (DerivStrategy GhcRn)) where

1409− toHie (L span strat) = concatM $ makeNode strat span : case strat of

1410− StockStrategy -> []

1411− AnyclassStrategy -> []

1412− NewtypeStrategy -> []

1413− ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]

1414−

1415−instance ToHie (Located OverlapMode) where

1416− toHie (L span _) = pure $ locOnly span

1417−

1418−instance ToHie (LConDecl GhcRn) where

1419− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1420− ConDeclGADT { con_names = names, con_qvars = qvars

1421− , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->

1422− [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names

1423− , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars

1424− , toHie ctx

1425− , toHie args

1426− , toHie typ

1427− ]

1428− where

1429− rhsScope = combineScopes argsScope tyScope

1430− ctxScope = maybe NoScope mkLScope ctx

1431− argsScope = condecl_scope args

1432− tyScope = mkLScope typ

1433− ConDeclH98 { con_name = name, con_ex_tvs = qvars

1434− , con_mb_cxt = ctx, con_args = dets } ->

1435− [ toHie $ C (Decl ConDec $ getRealSpan span) name

1436− , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars

1437− , toHie ctx

1438− , toHie dets

1439− ]

1440− where

1441− rhsScope = combineScopes ctxScope argsScope

1442− ctxScope = maybe NoScope mkLScope ctx

1443− argsScope = condecl_scope dets

1444− XConDecl _ -> []

1445− where condecl_scope args = case args of

1446− PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs

1447− InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)

1448− RecCon x -> mkLScope x

1449−

1450−instance ToHie (Located [LConDeclField GhcRn]) where

1451− toHie (L span decls) = concatM $

1452− [ pure $ locOnly span

1453− , toHie decls

1454− ]

1455−

1456−instance ( HasLoc thing

1457− , ToHie (TScoped thing)

1458− ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where

1459− toHie (TS sc (HsIB ibrn a)) = concatM $

1460− [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn

1461− , toHie $ TS sc a

1462− ]

1463− where span = loc a

1464− toHie (TS _ (XHsImplicitBndrs _)) = pure []

1465−

1466−instance ( HasLoc thing

1467− , ToHie (TScoped thing)

1468− ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where

1469− toHie (TS sc (HsWC names a)) = concatM $

1470− [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names

1471− , toHie $ TS sc a

1472− ]

1473− where span = loc a

1474− toHie (TS _ (XHsWildCardBndrs _)) = pure []

1475−

1476−instance ToHie (LStandaloneKindSig GhcRn) where

1477− toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]

1478−

1479−instance ToHie (StandaloneKindSig GhcRn) where

1480− toHie sig = concatM $ case sig of

1481− StandaloneKindSig _ name typ ->

1482− [ toHie $ C TyDecl name

1483− , toHie $ TS (ResolvedScopes []) typ

1484− ]

1485− XStandaloneKindSig _ -> []

1486−

1487−instance ToHie (SigContext (LSig GhcRn)) where

1488− toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of

1489− TypeSig _ names typ ->

1490− [ toHie $ map (C TyDecl) names

1491− , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1492− ]

1493− PatSynSig _ names typ ->

1494− [ toHie $ map (C TyDecl) names

1495− , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1496− ]

1497− ClassOpSig _ _ names typ ->

1498− [ case styp of

1499− ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names

1500− _ -> toHie $ map (C $ TyDecl) names

1501− , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ

1502− ]

1503− IdSig _ _ -> []

1504− FixSig _ fsig ->

1505− [ toHie $ L sp fsig

1506− ]

1507− InlineSig _ name _ ->

1508− [ toHie $ (C Use) name

1509− ]

1510− SpecSig _ name typs _ ->

1511− [ toHie $ (C Use) name

1512− , toHie $ map (TS (ResolvedScopes [])) typs

1513− ]

1514− SpecInstSig _ _ typ ->

1515− [ toHie $ TS (ResolvedScopes []) typ

1516− ]

1517− MinimalSig _ _ form ->

1518− [ toHie form

1519− ]

1520− SCCFunSig _ _ name mtxt ->

1521− [ toHie $ (C Use) name

1522− , pure $ maybe [] (locOnly . getLoc) mtxt

1523− ]

1524− CompleteMatchSig _ _ (L ispan names) typ ->

1525− [ pure $ locOnly ispan

1526− , toHie $ map (C Use) names

1527− , toHie $ fmap (C Use) typ

1528− ]

1529− XSig _ -> []

1530−

1531−instance ToHie (LHsType GhcRn) where

1532− toHie x = toHie $ TS (ResolvedScopes []) x

1533−

1534−instance ToHie (TScoped (LHsType GhcRn)) where

1535− toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of

1536− HsForAllTy _ _ bndrs body ->

1537− [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs

1538− , toHie body

1539− ]

1540− HsQualTy _ ctx body ->

1541− [ toHie ctx

1542− , toHie body

1543− ]

1544− HsTyVar _ _ var ->

1545− [ toHie $ C Use var

1546− ]

1547− HsAppTy _ a b ->

1548− [ toHie a

1549− , toHie b

1550− ]

1551− HsAppKindTy _ ty ki ->

1552− [ toHie ty

1553− , toHie $ TS (ResolvedScopes []) ki

1554− ]

1555− HsFunTy _ a b ->

1556− [ toHie a

1557− , toHie b

1558− ]

1559− HsListTy _ a ->

1560− [ toHie a

1561− ]

1562− HsTupleTy _ _ tys ->

1563− [ toHie tys

1564− ]

1565− HsSumTy _ tys ->

1566− [ toHie tys

1567− ]

1568− HsOpTy _ a op b ->

1569− [ toHie a

1570− , toHie $ C Use op

1571− , toHie b

1572− ]

1573− HsParTy _ a ->

1574− [ toHie a

1575− ]

1576− HsIParamTy _ ip ty ->

1577− [ toHie ip

1578− , toHie ty

1579− ]

1580− HsKindSig _ a b ->

1581− [ toHie a

1582− , toHie b

1583− ]

1584− HsSpliceTy _ a ->

1585− [ toHie $ L span a

1586− ]

1587− HsDocTy _ a _ ->

1588− [ toHie a

1589− ]

1590− HsBangTy _ _ ty ->

1591− [ toHie ty

1592− ]

1593− HsRecTy _ fields ->

1594− [ toHie fields

1595− ]

1596− HsExplicitListTy _ _ tys ->

1597− [ toHie tys

1598− ]

1599− HsExplicitTupleTy _ tys ->

1600− [ toHie tys

1601− ]

1602− HsTyLit _ _ -> []

1603− HsWildCardTy _ -> []

1604− HsStarTy _ _ -> []

1605− XHsType _ -> []

1606−

1607−instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where

1608− toHie (HsValArg tm) = toHie tm

1609− toHie (HsTypeArg _ ty) = toHie ty

1610− toHie (HsArgPar sp) = pure $ locOnly sp

1611−

1612−instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where

1613− toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1614− UserTyVar _ var ->

1615− [ toHie $ C (TyVarBind sc tsc) var

1616− ]

1617− KindedTyVar _ var kind ->

1618− [ toHie $ C (TyVarBind sc tsc) var

1619− , toHie kind

1620− ]

1621− XTyVarBndr _ -> []

1622−

1623−instance ToHie (TScoped (LHsQTyVars GhcRn)) where

1624− toHie (TS sc (HsQTvs implicits vars)) = concatM $

1625− [ pure $ bindingsOnly bindings

1626− , toHie $ tvScopes sc NoScope vars

1627− ]

1628− where

1629− varLoc = loc vars

1630− bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits

1631− toHie (TS _ (XLHsQTyVars _)) = pure []

1632−

1633−instance ToHie (LHsContext GhcRn) where

1634− toHie (L span tys) = concatM $

1635− [ pure $ locOnly span

1636− , toHie tys

1637− ]

1638−

1639−instance ToHie (LConDeclField GhcRn) where

1640− toHie (L span field) = concatM $ makeNode field span : case field of

1641− ConDeclField _ fields typ _ ->

1642− [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields

1643− , toHie typ

1644− ]

1645− XConDeclField _ -> []

1646−

1647−instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where

1648− toHie (From expr) = toHie expr

1649− toHie (FromThen a b) = concatM $

1650− [ toHie a

1651− , toHie b

1652− ]

1653− toHie (FromTo a b) = concatM $

1654− [ toHie a

1655− , toHie b

1656− ]

1657− toHie (FromThenTo a b c) = concatM $

1658− [ toHie a

1659− , toHie b

1660− , toHie c

1661− ]

1662−

1663−instance ToHie (LSpliceDecl GhcRn) where

1664− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1665− SpliceDecl _ splice _ ->

1666− [ toHie splice

1667− ]

1668− XSpliceDecl _ -> []

1669−

1670−instance ToHie (HsBracket a) where

1671− toHie _ = pure []

1672−

1673−instance ToHie PendingRnSplice where

1674− toHie _ = pure []

1675−

1676−instance ToHie PendingTcSplice where

1677− toHie _ = pure []

1678−

1679−instance ToHie (LBooleanFormula (Located Name)) where

1680− toHie (L span form) = concatM $ makeNode form span : case form of

1681− Var a ->

1682− [ toHie $ C Use a

1683− ]

1684− And forms ->

1685− [ toHie forms

1686− ]

1687− Or forms ->

1688− [ toHie forms

1689− ]

1690− Parens f ->

1691− [ toHie f

1692− ]

1693−

1694−instance ToHie (Located HsIPName) where

1695− toHie (L span e) = makeNode e span

1696−

1697−instance ( ToHie (LHsExpr a)

1698− , Data (HsSplice a)

1699− ) => ToHie (Located (HsSplice a)) where

1700− toHie (L span sp) = concatM $ makeNode sp span : case sp of

1701− HsTypedSplice _ _ _ expr ->

1702− [ toHie expr

1703− ]

1704− HsUntypedSplice _ _ _ expr ->

1705− [ toHie expr

1706− ]

1707− HsQuasiQuote _ _ _ ispan _ ->

1708− [ pure $ locOnly ispan

1709− ]

1710− HsSpliced _ _ _ ->

1711− []

1712− HsSplicedT _ ->

1713− []

1714− XSplice _ -> []

1715−

1716−instance ToHie (LRoleAnnotDecl GhcRn) where

1717− toHie (L span annot) = concatM $ makeNode annot span : case annot of

1718− RoleAnnotDecl _ var roles ->

1719− [ toHie $ C Use var

1720− , concatMapM (pure . locOnly . getLoc) roles

1721− ]

1722− XRoleAnnotDecl _ -> []

1723−

1724−instance ToHie (LInstDecl GhcRn) where

1725− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1726− ClsInstD _ d ->

1727− [ toHie $ L span d

1728− ]

1729− DataFamInstD _ d ->

1730− [ toHie $ L span d

1731− ]

1732− TyFamInstD _ d ->

1733− [ toHie $ L span d

1734− ]

1735− XInstDecl _ -> []

1736−

1737−instance ToHie (LClsInstDecl GhcRn) where

1738− toHie (L span decl) = concatM

1739− [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl

1740− , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl

1741− , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl

1742− , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl

1743− , toHie $ cid_tyfam_insts decl

1744− , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl

1745− , toHie $ cid_datafam_insts decl

1746− , toHie $ cid_overlap_mode decl

1747− ]

1748−

1749−instance ToHie (LDataFamInstDecl GhcRn) where

1750− toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1751−

1752−instance ToHie (LTyFamInstDecl GhcRn) where

1753− toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1754−

1755−instance ToHie (Context a)

1756− => ToHie (PatSynFieldContext (RecordPatSynField a)) where

1757− toHie (PSC sp (RecordPatSynField a b)) = concatM $

1758− [ toHie $ C (RecField RecFieldDecl sp) a

1759− , toHie $ C Use b

1760− ]

1761−

1762−instance ToHie (LDerivDecl GhcRn) where

1763− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1764− DerivDecl _ typ strat overlap ->

1765− [ toHie $ TS (ResolvedScopes []) typ

1766− , toHie strat

1767− , toHie overlap

1768− ]

1769− XDerivDecl _ -> []

1770−

1771−instance ToHie (LFixitySig GhcRn) where

1772− toHie (L span sig) = concatM $ makeNode sig span : case sig of

1773− FixitySig _ vars _ ->

1774− [ toHie $ map (C Use) vars

1775− ]

1776− XFixitySig _ -> []

1777−

1778−instance ToHie (LDefaultDecl GhcRn) where

1779− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1780− DefaultDecl _ typs ->

1781− [ toHie typs

1782− ]

1783− XDefaultDecl _ -> []

1784−

1785−instance ToHie (LForeignDecl GhcRn) where

1786− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1787− ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->

1788− [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name

1789− , toHie $ TS (ResolvedScopes []) sig

1790− , toHie fi

1791− ]

1792− ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->

1793− [ toHie $ C Use name

1794− , toHie $ TS (ResolvedScopes []) sig

1795− , toHie fe

1796− ]

1797− XForeignDecl _ -> []

1798−

1799−instance ToHie ForeignImport where

1800− toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $

1801− [ locOnly a

1802− , locOnly b

1803− , locOnly c

1804− ]

1805−

1806−instance ToHie ForeignExport where

1807− toHie (CExport (L a _) (L b _)) = pure $ concat $

1808− [ locOnly a

1809− , locOnly b

1810− ]

1811−

1812−instance ToHie (LWarnDecls GhcRn) where

1813− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1814− Warnings _ _ warnings ->

1815− [ toHie warnings

1816− ]

1817− XWarnDecls _ -> []

1818−

1819−instance ToHie (LWarnDecl GhcRn) where

1820− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1821− Warning _ vars _ ->

1822− [ toHie $ map (C Use) vars

1823− ]

1824− XWarnDecl _ -> []

1825−

1826−instance ToHie (LAnnDecl GhcRn) where

1827− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1828− HsAnnotation _ _ prov expr ->

1829− [ toHie prov

1830− , toHie expr

1831− ]

1832− XAnnDecl _ -> []

1833−

1834−instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where

1835− toHie (ValueAnnProvenance a) = toHie $ C Use a

1836− toHie (TypeAnnProvenance a) = toHie $ C Use a

1837− toHie ModuleAnnProvenance = pure []

1838−

1839−instance ToHie (LRuleDecls GhcRn) where

1840− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1841− HsRules _ _ rules ->

1842− [ toHie rules

1843− ]

1844− XRuleDecls _ -> []

1845−

1846−instance ToHie (LRuleDecl GhcRn) where

1847− toHie (L _ (XRuleDecl _)) = pure []

1848− toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM

1849− [ makeNode r span

1850− , pure $ locOnly $ getLoc rname

1851− , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1852− , toHie $ map (RS $ mkScope span) bndrs

1853− , toHie exprA

1854− , toHie exprB

1855− ]

1856− where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc

1857− bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)

1858− exprA_sc = mkLScope exprA

1859− exprB_sc = mkLScope exprB

1860−

1861−instance ToHie (RScoped (LRuleBndr GhcRn)) where

1862− toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1863− RuleBndr _ var ->

1864− [ toHie $ C (ValBind RegularBind sc Nothing) var

1865− ]

1866− RuleBndrSig _ var typ ->

1867− [ toHie $ C (ValBind RegularBind sc Nothing) var

1868− , toHie $ TS (ResolvedScopes [sc]) typ

1869− ]

1870− XRuleBndr _ -> []

1871−

1872−instance ToHie (LImportDecl GhcRn) where

1873− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1874− ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->

1875− [ toHie $ IEC Import name

1876− , toHie $ fmap (IEC ImportAs) as

1877− , maybe (pure []) goIE hidden

1878− ]

1879− XImportDecl _ -> []

1880− where

1881− goIE (hiding, (L sp liens)) = concatM $

1882− [ pure $ locOnly sp

1883− , toHie $ map (IEC c) liens

1884− ]

1885− where

1886− c = if hiding then ImportHiding else Import

1887−

1888−instance ToHie (IEContext (LIE GhcRn)) where

1889− toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of

1890− IEVar _ n ->

1891− [ toHie $ IEC c n

1892− ]

1893− IEThingAbs _ n ->

1894− [ toHie $ IEC c n

1895− ]

1896− IEThingAll _ n ->

1897− [ toHie $ IEC c n

1898− ]

1899− IEThingWith _ n _ ns flds ->

1900− [ toHie $ IEC c n

1901− , toHie $ map (IEC c) ns

1902− , toHie $ map (IEC c) flds

1903− ]

1904− IEModuleContents _ n ->

1905− [ toHie $ IEC c n

1906− ]

1907− IEGroup _ _ _ -> []

1908− IEDoc _ _ -> []

1909− IEDocNamed _ _ -> []

1910− XIE _ -> []

1911−

1912−instance ToHie (IEContext (LIEWrappedName Name)) where

1913− toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of

1914− IEName n ->

1915− [ toHie $ C (IEThing c) n

1916− ]

1917− IEPattern p ->

1918− [ toHie $ C (IEThing c) p

1919− ]

1920− IEType n ->

1921− [ toHie $ C (IEThing c) n

1922− ]

1923−

1924−instance ToHie (IEContext (Located (FieldLbl Name))) where

1925− toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of

1926− FieldLabel _ _ n ->

1927− [ toHie $ C (IEThing c) $ L span n

1928− ]

src-ghc88/Development/IDE/GHC/HieAst.hsdeleted−1789

@@ -1,1789 +0,0 @@

1−

2−{-

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

4−

5−Main functions for .hie file generation

6−-}

7−{- HLINT ignore -}

8−{-# LANGUAGE OverloadedStrings #-}

9−{-# LANGUAGE FlexibleInstances #-}

10−{-# LANGUAGE UndecidableInstances #-}

11−{-# LANGUAGE FlexibleContexts #-}

12−{-# LANGUAGE TypeSynonymInstances #-}

13−{-# LANGUAGE ScopedTypeVariables #-}

14−{-# LANGUAGE TypeFamilies #-}

15−{-# LANGUAGE TypeApplications #-}

16−{-# LANGUAGE AllowAmbiguousTypes #-}

17−{-# LANGUAGE ViewPatterns #-}

18−{-# LANGUAGE DeriveDataTypeable #-}

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

20−

21−import Avail ( Avails )

22−import Bag ( Bag, bagToList )

23−import BasicTypes

24−import BooleanFormula

25−import Class ( FunDep )

26−import CoreUtils ( exprType )

27−import ConLike ( conLikeName )

28−import Desugar ( deSugarExpr )

29−import FieldLabel

30−import HsSyn

31−import HscTypes

32−import Module ( ModuleName, ml_hs_file )

33−import MonadUtils ( concatMapM, liftIO )

34−import Name ( Name, nameSrcSpan, setNameLoc )

35−import SrcLoc

36−import TcHsSyn ( hsLitType, hsPatType )

37−import Type ( mkFunTys, Type )

38−import TysWiredIn ( mkListTy, mkSumTy )

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

40−import TcRnTypes

41−import MkIface ( mkIfaceExports )

42−

43−import HieTypes

44−import HieUtils

45−

46−import qualified Data.Array as A

47−import qualified Data.ByteString as BS

48−import qualified Data.Map as M

49−import qualified Data.Set as S

50−import Data.Data ( Data, Typeable )

51−import Data.List (foldl', foldl1' )

52−import Data.Maybe ( listToMaybe )

53−import Control.Monad.Trans.Reader

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

55−

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

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

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

59− , Maybe LHsDocString )

60−type TypecheckedSource = LHsBinds GhcTc

61−

62−

63−{- Note [Name Remapping]

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

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

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

67−-}

68−newtype HieState = HieState

69− { name_remapping :: M.Map Name Id

70− }

71−

72−initState :: HieState

73−initState = HieState M.empty

74−

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

76− addSubstitution :: a -> a -> HieState -> HieState

77−

78−instance ModifyState Name where

79− addSubstitution _ _ hs = hs

80−

81−instance ModifyState Id where

82− addSubstitution mono poly hs =

83− hs{name_remapping = M.insert (varName mono) poly (name_remapping hs)}

84−

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

86−modifyState = foldr go id

87− where

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

89− go _ f = f

90−

91−type HieM = ReaderT HieState Hsc

92−

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

94−mkHieFile :: ModSummary

95− -> TcGblEnv

96− -> RenamedSource

97− -> BS.ByteString

98− -> Hsc HieFile

99−mkHieFile ms ts rs src = do

100− let tc_binds = tcg_binds ts

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

102− let Just src_file = ml_hs_file $ ms_location ms

103− return $ HieFile

104− { hie_hs_file = src_file

105− , hie_module = ms_mod ms

106− , hie_types = arr

107− , hie_asts = asts'

108− -- mkIfaceExports sorts the AvailInfos for stability

109− , hie_exports = mkIfaceExports (tcg_exports ts)

110− , hie_hs_src = src

111− }

112−

113−getCompressedAsts :: TypecheckedSource -> RenamedSource

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

115−getCompressedAsts ts rs = do

116− asts <- enrichHie ts rs

117− return $ compressTypes asts

118−

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

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

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

122− rasts <- processGrp hsGrp

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

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

125− let spanFile children = case children of

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

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

128− (realSrcSpanEnd $ nodeSpan $ last children)

129−

130− modulify xs =

131− Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs

132−

133− asts = HieASTs

134− $ resolveTyVarScopes

135− $ M.map (modulify . mergeSortAsts)

136− $ M.fromListWith (++)

137− $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts

138−

139− flat_asts = concat

140− [ tasts

141− , rasts

142− , imps

143− , exps

144− ]

145− return asts

146− where

147− processGrp grp = concatM

148− [ toHie $ fmap (RS ModuleScope ) hs_valds grp

149− , toHie $ hs_splcds grp

150− , toHie $ hs_tyclds grp

151− , toHie $ hs_derivds grp

152− , toHie $ hs_fixds grp

153− , toHie $ hs_defds grp

154− , toHie $ hs_fords grp

155− , toHie $ hs_warnds grp

156− , toHie $ hs_annds grp

157− , toHie $ hs_ruleds grp

158− ]

159−

160−getRealSpan :: SrcSpan -> Maybe Span

161−getRealSpan (RealSrcSpan sp) = Just sp

162−getRealSpan _ = Nothing

163−

164−grhss_span :: GRHSs p body -> SrcSpan

165−grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)

166−grhss_span (XGRHSs _) = error "XGRHS has no span"

167−

168−bindingsOnly :: [Context Name] -> [HieAST a]

169−bindingsOnly [] = []

170−bindingsOnly (C c n : xs) = case nameSrcSpan n of

171− RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs

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

173− info = mempty{identInfo = S.singleton c}

174− _ -> bindingsOnly xs

175−

176−concatM :: Monad m => [m [a]] -> m [a]

177−concatM xs = concat <$> sequence xs

178−

179−{- Note [Capturing Scopes and other non local information]

180−toHie is a local tranformation, but scopes of bindings cannot be known locally,

181−hence we have to push the relevant info down into the binding nodes.

182−We use the following types (*Context and *Scoped) to wrap things and

183−carry the required info

184−(Maybe Span) always carries the span of the entire binding, including rhs

185−-}

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

187−

188−data RContext a = RC RecFieldContext a

189−data RFContext a = RFC RecFieldContext (Maybe Span) a

190−-- ^ context for record fields

191−

192−data IEContext a = IEC IEType a

193−-- ^ context for imports/exports

194−

195−data BindContext a = BC BindType Scope a

196−-- ^ context for imports/exports

197−

198−data PatSynFieldContext a = PSC (Maybe Span) a

199−-- ^ context for pattern synonym fields.

200−

201−data SigContext a = SC SigInfo a

202−-- ^ context for type signatures

203−

204−data SigInfo = SI SigType (Maybe Span)

205−

206−data SigType = BindSig | ClassSig | InstSig

207−

208−data RScoped a = RS Scope a

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

210−-- including a itself

211−-- (Includes a in a few special cases like recursive do bindings) or

212−-- let/where bindings

213−

214−-- | Pattern scope

215−data PScoped a = PS (Maybe Span)

216− Scope -- ^ use site of the pattern

217− Scope -- ^ pattern to the right of a, not including a

218− a

219− deriving (Typeable, Data) -- Pattern Scope

220−

221−{- Note [TyVar Scopes]

222−Due to -XScopedTypeVariables, type variables can be in scope quite far from

223−their original binding. We resolve the scope of these type variables

224−in a separate pass

225−-}

226−data TScoped a = TS TyVarScope a -- TyVarScope

227−

228−data TVScoped a = TVS TyVarScope Scope a -- TyVarScope

229−-- ^ First scope remains constant

230−-- Second scope is used to build up the scope of a tyvar over

231−-- things to its right, ala RScoped

232−

233−-- | Each element scopes over the elements to the right

234−listScopes :: Scope -> [Located a] -> [RScoped (Located a)]

235−listScopes _ [] = []

236−listScopes rhsScope [pat] = [RS rhsScope pat]

237−listScopes rhsScope (pat : pats) = RS sc pat : pats'

238− where

239− pats'@((RS scope p):_) = listScopes rhsScope pats

240− sc = combineScopes scope $ mkScope $ getLoc p

241−

242−-- | 'listScopes' specialised to 'PScoped' things

243−patScopes

244− :: Maybe Span

245− -> Scope

246− -> Scope

247− -> [LPat (GhcPass p)]

248− -> [PScoped (LPat (GhcPass p))]

249−patScopes rsp useScope patScope xs =

250− map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $

251− listScopes patScope (map dL xs)

252−

253−-- | 'listScopes' specialised to 'TVScoped' things

254−tvScopes

255− :: TyVarScope

256− -> Scope

257− -> [LHsTyVarBndr a]

258− -> [TVScoped (LHsTyVarBndr a)]

259−tvScopes tvScope rhsScope xs =

260− map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs

261−

262−{- Note [Scoping Rules for SigPat]

263−Explicitly quantified variables in pattern type signatures are not

264−brought into scope in the rhs, but implicitly quantified variables

265−are (HsWC and HsIB).

266−This is unlike other signatures, where explicitly quantified variables

267−are brought into the RHS Scope

268−For example

269−foo :: forall a. ...;

270−foo = ... -- a is in scope here

271−

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

273−-- ^ a is in scope here (pattern body)

274−

275−bax (x :: a) = ... -- a is in scope here

276−Because of HsWC and HsIB pass on their scope to their children

277−we must wrap the LHsType in pattern signatures in a

278−Shielded explictly, so that the HsWC/HsIB scope is not passed

279−on the the LHsType

280−-}

281−

282−data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead

283−

284−type family ProtectedSig a where

285− ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs

286− GhcRn

287− (Shielded (LHsType GhcRn)))

288− ProtectedSig GhcTc = NoExt

289−

290−class ProtectSig a where

291− protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a

292−

293−instance (HasLoc a) => HasLoc (Shielded a) where

294− loc (SH _ a) = loc a

295−

296−instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where

297− toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)

298−

299−instance ProtectSig GhcTc where

300− protectSig _ _ = NoExt

301−

302−instance ProtectSig GhcRn where

303− protectSig sc (HsWC a (HsIB b sig)) =

304− HsWC a (HsIB b (SH sc sig))

305− protectSig _ _ = error "protectSig not given HsWC (HsIB)"

306−

307−class HasLoc a where

308− -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can

309− -- know what their implicit bindings are scoping over

310− loc :: a -> SrcSpan

311−

312−instance HasLoc thing => HasLoc (TScoped thing) where

313− loc (TS _ a) = loc a

314−

315−instance HasLoc thing => HasLoc (PScoped thing) where

316− loc (PS _ _ _ a) = loc a

317−

318−instance HasLoc (LHsQTyVars GhcRn) where

319− loc (HsQTvs _ vs) = loc vs

320− loc _ = noSrcSpan

321−

322−instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where

323− loc (HsIB _ a) = loc a

324− loc _ = noSrcSpan

325−

326−instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where

327− loc (HsWC _ a) = loc a

328− loc _ = noSrcSpan

329−

330−instance HasLoc (Located a) where

331− loc (L l _) = l

332−

333−instance HasLoc a => HasLoc [a] where

334− loc [] = noSrcSpan

335− loc xs = foldl1' combineSrcSpans $ map loc xs

336−

337−instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where

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

339− loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans

340− [loc a, loc tvs, loc b, loc c]

341− loc _ = noSrcSpan

342−instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where

343− loc (HsValArg tm) = loc tm

344− loc (HsTypeArg _ ty) = loc ty

345− loc (HsArgPar sp) = sp

346−

347−instance HasLoc (HsDataDefn GhcRn) where

348− loc def@(HsDataDefn{}) = loc $ dd_cons def

349− -- Only used for data family instances, so we only need rhs

350− -- Most probably the rest will be unhelpful anyway

351− loc _ = noSrcSpan

352−

353−instance HasLoc (Pat (GhcPass a)) where

354− loc (dL -> L l _) = l

355−

356−-- | The main worker class

357−class ToHie a where

358− toHie :: a -> HieM [HieAST Type]

359−

360−-- | Used to collect type info

361−class Data a => HasType a where

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

363−

364−instance (ToHie a) => ToHie [a] where

365− toHie = concatMapM toHie

366−

367−instance (ToHie a) => ToHie (Bag a) where

368− toHie = toHie . bagToList

369−

370−instance (ToHie a) => ToHie (Maybe a) where

371− toHie = maybe (pure []) toHie

372−

373−instance ToHie (Context (Located NoExt)) where

374− toHie _ = pure []

375−

376−instance ToHie (TScoped NoExt) where

377− toHie _ = pure []

378−

379−instance ToHie (IEContext (Located ModuleName)) where

380− toHie (IEC c (L (RealSrcSpan span) mname)) =

381− pure $ [Node (NodeInfo S.empty [] idents) span []]

382− where details = mempty{identInfo = S.singleton (IEThing c)}

383− idents = M.singleton (Left mname) details

384− toHie _ = pure []

385−

386−instance ToHie (Context (Located Var)) where

387− toHie c = case c of

388− C context (L (RealSrcSpan span) name')

389− -> do

390− m <- asks name_remapping

391− let name = M.findWithDefault name' (varName name') m

392− pure

393− [Node

394− (NodeInfo S.empty [] $

395− M.singleton (Right $ varName name)

396− (IdentifierDetails (Just $ varType name')

397− (S.singleton context)))

398− span

399− []]

400− _ -> pure []

401−

402−instance ToHie (Context (Located Name)) where

403− toHie c = case c of

404− C context (L (RealSrcSpan span) name') -> do

405− m <- asks name_remapping

406− let name = case M.lookup name' m of

407− Just var -> varName var

408− Nothing -> name'

409− pure

410− [Node

411− (NodeInfo S.empty [] $

412− M.singleton (Right name)

413− (IdentifierDetails Nothing

414− (S.singleton context)))

415− span

416− []]

417− _ -> pure []

418−

419−-- | Dummy instances - never called

420−instance ToHie (TScoped (LHsSigWcType GhcTc)) where

421− toHie _ = pure []

422−instance ToHie (TScoped (LHsWcType GhcTc)) where

423− toHie _ = pure []

424−instance ToHie (SigContext (LSig GhcTc)) where

425− toHie _ = pure []

426−instance ToHie (TScoped Type) where

427− toHie _ = pure []

428−

429−instance HasType (LHsBind GhcRn) where

430− getTypeNode (L spn bind) = makeNode bind spn

431−

432−instance HasType (LHsBind GhcTc) where

433− getTypeNode (L spn bind) = case bind of

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

435− _ -> makeNode bind spn

436−

437−instance HasType (LPat GhcRn) where

438− getTypeNode (dL -> L spn pat) = makeNode pat spn

439−

440−instance HasType (LPat GhcTc) where

441− getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)

442−

443−instance HasType (LHsExpr GhcRn) where

444− getTypeNode (L spn e) = makeNode e spn

445−

446−-- | This instance tries to construct 'HieAST' nodes which include the type of

447−-- the expression. It is not yet possible to do this efficiently for all

448−-- expression forms, so we skip filling in the type for those inputs.

449−--

450−-- 'HsApp', for example, doesn't have any type information available directly on

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

452−-- query the type of that. Yet both the desugaring call and the type query both

453−-- involve recursive calls to the function and argument! This is particularly

454−-- problematic when you realize that the HIE traversal will eventually visit

455−-- those nodes too and ask for their types again.

456−--

457−-- Since the above is quite costly, we just skip cases where computing the

458−-- expression's type is going to be expensive.

459−--

460−-- See #16233

461−instance HasType (LHsExpr GhcTc) where

462− getTypeNode e@(L spn e') = lift $

463− -- Some expression forms have their type immediately available

464− let tyOpt = case e' of

465− HsLit _ l -> Just (hsLitType l)

466− HsOverLit _ o -> Just (overLitType o)

467−

468− HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)

469− HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)

470− HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)

471−

472− ExplicitList ty _ _ -> Just (mkListTy ty)

473− ExplicitSum ty _ _ _ -> Just (mkSumTy ty)

474− HsDo ty _ _ -> Just ty

475− HsMultiIf ty _ -> Just ty

476−

477− _ -> Nothing

478−

479− in

480− case tyOpt of

481− _ | skipDesugaring e' -> fallback

482− | otherwise -> do

483− hs_env <- Hsc $ \e w -> return (e,w)

484− (_,mbe) <- liftIO $ deSugarExpr hs_env e

485− maybe fallback (makeTypeNode e' spn . exprType) mbe

486− where

487− fallback = makeNode e' spn

488−

489− matchGroupType :: MatchGroupTc -> Type

490− matchGroupType (MatchGroupTc args res) = mkFunTys args res

491−

492− -- | Skip desugaring of these expressions for performance reasons.

493− --

494− -- See impact on Haddock output (esp. missing type annotations or links)

495− -- before marking more things here as 'False'. See impact on Haddock

496− -- performance before marking more things as 'True'.

497− skipDesugaring :: HsExpr a -> Bool

498− skipDesugaring e = case e of

499− HsVar{} -> False

500− HsUnboundVar{} -> False

501− HsConLikeOut{} -> False

502− HsRecFld{} -> False

503− HsOverLabel{} -> False

504− HsIPVar{} -> False

505− HsWrap{} -> False

506− _ -> True

507−

508−instance ( ToHie (Context (Located (IdP a)))

509− , ToHie (MatchGroup a (LHsExpr a))

510− , ToHie (PScoped (LPat a))

511− , ToHie (GRHSs a (LHsExpr a))

512− , ToHie (LHsExpr a)

513− , ToHie (Located (PatSynBind a a))

514− , HasType (LHsBind a)

515− , ModifyState (IdP a)

516− , Data (HsBind a)

517− ) => ToHie (BindContext (LHsBind a)) where

518− toHie (BC context scope b@(L span bind)) =

519− concatM $ getTypeNode b : case bind of

520− FunBind{fun_id = name, fun_matches = matches} ->

521− [ toHie $ C (ValBind context scope $ getRealSpan span) name

522− , toHie matches

523− ]

524− PatBind{pat_lhs = lhs, pat_rhs = rhs} ->

525− [ toHie $ PS (getRealSpan span) scope NoScope lhs

526− , toHie rhs

527− ]

528− VarBind{var_rhs = expr} ->

529− [ toHie expr

530− ]

531− AbsBinds{abs_exports = xs, abs_binds = binds} ->

532− [ local (modifyState xs) $ -- Note [Name Remapping]

533− toHie $ fmap (BC context scope) binds

534− ]

535− PatSynBind _ psb ->

536− [ toHie $ L span psb -- PatSynBinds only occur at the top level

537− ]

538− XHsBindsLR _ -> []

539−

540−instance ( ToHie (LMatch a body)

541− ) => ToHie (MatchGroup a body) where

542− toHie mg = concatM $ case mg of

543− MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->

544− [ pure $ locOnly span

545− , toHie alts

546− ]

547− MG{} -> []

548− XMatchGroup _ -> []

549−

550−instance ( ToHie (Context (Located (IdP a)))

551− , ToHie (PScoped (LPat a))

552− , ToHie (HsPatSynDir a)

553− ) => ToHie (Located (PatSynBind a a)) where

554− toHie (L sp psb) = concatM $ case psb of

555− PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->

556− [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var

557− , toHie $ toBind dets

558− , toHie $ PS Nothing lhsScope NoScope pat

559− , toHie dir

560− ]

561− where

562− lhsScope = combineScopes varScope detScope

563− varScope = mkLScope var

564− detScope = case dets of

565− (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args

566− (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)

567− (RecCon r) -> foldr go NoScope r

568− go (RecordPatSynField a b) c = combineScopes c

569− $ combineScopes (mkLScope a) (mkLScope b)

570− detSpan = case detScope of

571− LocalScope a -> Just a

572− _ -> Nothing

573− toBind (PrefixCon args) = PrefixCon $ map (C Use) args

574− toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)

575− toBind (RecCon r) = RecCon $ map (PSC detSpan) r

576− XPatSynBind _ -> []

577−

578−instance ( ToHie (MatchGroup a (LHsExpr a))

579− ) => ToHie (HsPatSynDir a) where

580− toHie dir = case dir of

581− ExplicitBidirectional mg -> toHie mg

582− _ -> pure []

583−

584−instance ( a ~ GhcPass p

585− , ToHie body

586− , ToHie (HsMatchContext (NameOrRdrName (IdP a)))

587− , ToHie (PScoped (LPat a))

588− , ToHie (GRHSs a body)

589− , Data (Match a body)

590− ) => ToHie (LMatch (GhcPass p) body) where

591− toHie (L span m ) = concatM $ makeNode m span : case m of

592− Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->

593− [ toHie mctx

594− , let rhsScope = mkScope $ grhss_span grhss

595− in toHie $ patScopes Nothing rhsScope NoScope pats

596− , toHie grhss

597− ]

598− XMatch _ -> []

599−

600−instance ( ToHie (Context (Located a))

601− ) => ToHie (HsMatchContext a) where

602− toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name

603− toHie (StmtCtxt a) = toHie a

604− toHie _ = pure []

605−

606−instance ( ToHie (HsMatchContext a)

607− ) => ToHie (HsStmtContext a) where

608− toHie (PatGuard a) = toHie a

609− toHie (ParStmtCtxt a) = toHie a

610− toHie (TransStmtCtxt a) = toHie a

611− toHie _ = pure []

612−

613−instance ( a ~ GhcPass p

614− , ToHie (Context (Located (IdP a)))

615− , ToHie (RContext (HsRecFields a (PScoped (LPat a))))

616− , ToHie (LHsExpr a)

617− , ToHie (TScoped (LHsSigWcType a))

618− , ProtectSig a

619− , ToHie (TScoped (ProtectedSig a))

620− , HasType (LPat a)

621− , Data (HsSplice a)

622− ) => ToHie (PScoped (LPat (GhcPass p))) where

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

624− concatM $ getTypeNode lpat : case opat of

625− WildPat _ ->

626− []

627− VarPat _ lname ->

628− [ toHie $ C (PatternBind scope pscope rsp) lname

629− ]

630− LazyPat _ p ->

631− [ toHie $ PS rsp scope pscope p

632− ]

633− AsPat _ lname pat ->

634− [ toHie $ C (PatternBind scope

635− (combineScopes (mkLScope (dL pat)) pscope)

636− rsp)

637− lname

638− , toHie $ PS rsp scope pscope pat

639− ]

640− ParPat _ pat ->

641− [ toHie $ PS rsp scope pscope pat

642− ]

643− BangPat _ pat ->

644− [ toHie $ PS rsp scope pscope pat

645− ]

646− ListPat _ pats ->

647− [ toHie $ patScopes rsp scope pscope pats

648− ]

649− TuplePat _ pats _ ->

650− [ toHie $ patScopes rsp scope pscope pats

651− ]

652− SumPat _ pat _ _ ->

653− [ toHie $ PS rsp scope pscope pat

654− ]

655− ConPatIn c dets ->

656− [ toHie $ C Use c

657− , toHie $ contextify dets

658− ]

659− ConPatOut {pat_con = con, pat_args = dets}->

660− [ toHie $ C Use $ fmap conLikeName con

661− , toHie $ contextify dets

662− ]

663− ViewPat _ expr pat ->

664− [ toHie expr

665− , toHie $ PS rsp scope pscope pat

666− ]

667− SplicePat _ sp ->

668− [ toHie $ L ospan sp

669− ]

670− LitPat _ _ ->

671− []

672− NPat _ _ _ _ ->

673− []

674− NPlusKPat _ n _ _ _ _ ->

675− [ toHie $ C (PatternBind scope pscope rsp) n

676− ]

677− SigPat _ pat sig ->

678− [ toHie $ PS rsp scope pscope pat

679− , let cscope = mkLScope (dL pat) in

680− toHie $ TS (ResolvedScopes [cscope, scope, pscope])

681− (protectSig @a cscope sig)

682− -- See Note [Scoping Rules for SigPat]

683− ]

684− CoPat _ _ _ _ ->

685− []

686− XPat _ -> []

687− where

688− contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args

689− contextify (InfixCon a b) = InfixCon a' b'

690− where [a', b'] = patScopes rsp scope pscope [a,b]

691− contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r

692− contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a

693− where

694− go (RS fscope (L spn (HsRecField lbl pat pun))) =

695− L spn $ HsRecField lbl (PS rsp scope fscope pat) pun

696− scoped_fds = listScopes pscope fds

697−

698−instance ( ToHie body

699− , ToHie (LGRHS a body)

700− , ToHie (RScoped (LHsLocalBinds a))

701− ) => ToHie (GRHSs a body) where

702− toHie grhs = concatM $ case grhs of

703− GRHSs _ grhss binds ->

704− [ toHie grhss

705− , toHie $ RS (mkScope $ grhss_span grhs) binds

706− ]

707− XGRHSs _ -> []

708−

709−instance ( ToHie (Located body)

710− , ToHie (RScoped (GuardLStmt a))

711− , Data (GRHS a (Located body))

712− ) => ToHie (LGRHS a (Located body)) where

713− toHie (L span g) = concatM $ makeNode g span : case g of

714− GRHS _ guards body ->

715− [ toHie $ listScopes (mkLScope body) guards

716− , toHie body

717− ]

718− XGRHS _ -> []

719−

720−instance ( a ~ GhcPass p

721− , ToHie (Context (Located (IdP a)))

722− , HasType (LHsExpr a)

723− , ToHie (PScoped (LPat a))

724− , ToHie (MatchGroup a (LHsExpr a))

725− , ToHie (LGRHS a (LHsExpr a))

726− , ToHie (RContext (HsRecordBinds a))

727− , ToHie (RFContext (Located (AmbiguousFieldOcc a)))

728− , ToHie (ArithSeqInfo a)

729− , ToHie (LHsCmdTop a)

730− , ToHie (RScoped (GuardLStmt a))

731− , ToHie (RScoped (LHsLocalBinds a))

732− , ToHie (TScoped (LHsWcType (NoGhcTc a)))

733− , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))

734− , Data (HsExpr a)

735− , Data (HsSplice a)

736− , Data (HsTupArg a)

737− , Data (AmbiguousFieldOcc a)

738− ) => ToHie (LHsExpr (GhcPass p)) where

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

740− HsVar _ (L _ var) ->

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

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

743− ]

744− HsUnboundVar _ _ ->

745− []

746− HsConLikeOut _ con ->

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

748− ]

749− HsRecFld _ fld ->

750− [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)

751− ]

752− HsOverLabel _ _ _ -> []

753− HsIPVar _ _ -> []

754− HsOverLit _ _ -> []

755− HsLit _ _ -> []

756− HsLam _ mg ->

757− [ toHie mg

758− ]

759− HsLamCase _ mg ->

760− [ toHie mg

761− ]

762− HsApp _ a b ->

763− [ toHie a

764− , toHie b

765− ]

766− HsAppType _ expr sig ->

767− [ toHie expr

768− , toHie $ TS (ResolvedScopes []) sig

769− ]

770− OpApp _ a b c ->

771− [ toHie a

772− , toHie b

773− , toHie c

774− ]

775− NegApp _ a _ ->

776− [ toHie a

777− ]

778− HsPar _ a ->

779− [ toHie a

780− ]

781− SectionL _ a b ->

782− [ toHie a

783− , toHie b

784− ]

785− SectionR _ a b ->

786− [ toHie a

787− , toHie b

788− ]

789− ExplicitTuple _ args _ ->

790− [ toHie args

791− ]

792− ExplicitSum _ _ _ expr ->

793− [ toHie expr

794− ]

795− HsCase _ expr matches ->

796− [ toHie expr

797− , toHie matches

798− ]

799− HsIf _ _ a b c ->

800− [ toHie a

801− , toHie b

802− , toHie c

803− ]

804− HsMultiIf _ grhss ->

805− [ toHie grhss

806− ]

807− HsLet _ binds expr ->

808− [ toHie $ RS (mkLScope expr) binds

809− , toHie expr

810− ]

811− HsDo _ _ (L ispan stmts) ->

812− [ pure $ locOnly ispan

813− , toHie $ listScopes NoScope stmts

814− ]

815− ExplicitList _ _ exprs ->

816− [ toHie exprs

817− ]

818− RecordCon {rcon_con_name = name, rcon_flds = binds}->

819− [ toHie $ C Use name

820− , toHie $ RC RecFieldAssign $ binds

821− ]

822− RecordUpd {rupd_expr = expr, rupd_flds = upds}->

823− [ toHie expr

824− , toHie $ map (RC RecFieldAssign) upds

825− ]

826− ExprWithTySig _ expr sig ->

827− [ toHie expr

828− , toHie $ TS (ResolvedScopes [mkLScope expr]) sig

829− ]

830− ArithSeq _ _ info ->

831− [ toHie info

832− ]

833− HsSCC _ _ _ expr ->

834− [ toHie expr

835− ]

836− HsCoreAnn _ _ _ expr ->

837− [ toHie expr

838− ]

839− HsProc _ pat cmdtop ->

840− [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat

841− , toHie cmdtop

842− ]

843− HsStatic _ expr ->

844− [ toHie expr

845− ]

846− HsArrApp _ a b _ _ ->

847− [ toHie a

848− , toHie b

849− ]

850− HsArrForm _ expr _ cmds ->

851− [ toHie expr

852− , toHie cmds

853− ]

854− HsTick _ _ expr ->

855− [ toHie expr

856− ]

857− HsBinTick _ _ _ expr ->

858− [ toHie expr

859− ]

860− HsTickPragma _ _ _ _ expr ->

861− [ toHie expr

862− ]

863− HsWrap _ _ a ->

864− [ toHie $ L mspan a

865− ]

866− HsBracket _ b ->

867− [ toHie b

868− ]

869− HsRnBracketOut _ b p ->

870− [ toHie b

871− , toHie p

872− ]

873− HsTcBracketOut _ b p ->

874− [ toHie b

875− , toHie p

876− ]

877− HsSpliceE _ x ->

878− [ toHie $ L mspan x

879− ]

880− EWildPat _ -> []

881− EAsPat _ a b ->

882− [ toHie $ C Use a

883− , toHie b

884− ]

885− EViewPat _ a b ->

886− [ toHie a

887− , toHie b

888− ]

889− ELazyPat _ a ->

890− [ toHie a

891− ]

892− XExpr _ -> []

893−

894−instance ( a ~ GhcPass p

895− , ToHie (LHsExpr a)

896− , Data (HsTupArg a)

897− ) => ToHie (LHsTupArg (GhcPass p)) where

898− toHie (L span arg) = concatM $ makeNode arg span : case arg of

899− Present _ expr ->

900− [ toHie expr

901− ]

902− Missing _ -> []

903− XTupArg _ -> []

904−

905−instance ( a ~ GhcPass p

906− , ToHie (PScoped (LPat a))

907− , ToHie (LHsExpr a)

908− , ToHie (SigContext (LSig a))

909− , ToHie (RScoped (LHsLocalBinds a))

910− , ToHie (RScoped (ApplicativeArg a))

911− , ToHie (Located body)

912− , Data (StmtLR a a (Located body))

913− , Data (StmtLR a a (Located (HsExpr a)))

914− ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where

915− toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of

916− LastStmt _ body _ _ ->

917− [ toHie body

918− ]

919− BindStmt _ pat body _ _ ->

920− [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat

921− , toHie body

922− ]

923− ApplicativeStmt _ stmts _ ->

924− [ concatMapM (toHie . RS scope . snd) stmts

925− ]

926− BodyStmt _ body _ _ ->

927− [ toHie body

928− ]

929− LetStmt _ binds ->

930− [ toHie $ RS scope binds

931− ]

932− ParStmt _ parstmts _ _ ->

933− [ concatMapM (\(ParStmtBlock _ stmts _ _) ->

934− toHie $ listScopes NoScope stmts)

935− parstmts

936− ]

937− TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->

938− [ toHie $ listScopes scope stmts

939− , toHie using

940− , toHie by

941− ]

942− RecStmt {recS_stmts = stmts} ->

943− [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts

944− ]

945− XStmtLR _ -> []

946−

947−instance ( ToHie (LHsExpr a)

948− , ToHie (PScoped (LPat a))

949− , ToHie (BindContext (LHsBind a))

950− , ToHie (SigContext (LSig a))

951− , ToHie (RScoped (HsValBindsLR a a))

952− , Data (HsLocalBinds a)

953− ) => ToHie (RScoped (LHsLocalBinds a)) where

954− toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of

955− EmptyLocalBinds _ -> []

956− HsIPBinds _ _ -> []

957− HsValBinds _ valBinds ->

958− [ toHie $ RS (combineScopes scope $ mkScope sp)

959− valBinds

960− ]

961− XHsLocalBindsLR _ -> []

962−

963−instance ( ToHie (BindContext (LHsBind a))

964− , ToHie (SigContext (LSig a))

965− , ToHie (RScoped (XXValBindsLR a a))

966− ) => ToHie (RScoped (HsValBindsLR a a)) where

967− toHie (RS sc v) = concatM $ case v of

968− ValBinds _ binds sigs ->

969− [ toHie $ fmap (BC RegularBind sc) binds

970− , toHie $ fmap (SC (SI BindSig Nothing)) sigs

971− ]

972− XValBindsLR x -> [ toHie $ RS sc x ]

973−

974−instance ToHie (RScoped (NHsValBindsLR GhcTc)) where

975− toHie (RS sc (NValBinds binds sigs)) = concatM $

976− [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)

977− , toHie $ fmap (SC (SI BindSig Nothing)) sigs

978− ]

979−instance ToHie (RScoped (NHsValBindsLR GhcRn)) where

980− toHie (RS sc (NValBinds binds sigs)) = concatM $

981− [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)

982− , toHie $ fmap (SC (SI BindSig Nothing)) sigs

983− ]

984−

985−instance ( ToHie (RContext (LHsRecField a arg))

986− ) => ToHie (RContext (HsRecFields a arg)) where

987− toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields

988−

989−instance ( ToHie (RFContext (Located label))

990− , ToHie arg

991− , HasLoc arg

992− , Data label

993− , Data arg

994− ) => ToHie (RContext (LHsRecField' label arg)) where

995− toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of

996− HsRecField label expr _ ->

997− [ toHie $ RFC c (getRealSpan $ loc expr) label

998− , toHie expr

999− ]

1000−

1001−removeDefSrcSpan :: Name -> Name

1002−removeDefSrcSpan n = setNameLoc n noSrcSpan

1003−

1004−instance ToHie (RFContext (LFieldOcc GhcRn)) where

1005− toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1006− FieldOcc name _ ->

1007− [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)

1008− ]

1009− XFieldOcc _ -> []

1010−

1011−instance ToHie (RFContext (LFieldOcc GhcTc)) where

1012− toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1013− FieldOcc var _ ->

1014− let var' = setVarName var (removeDefSrcSpan $ varName var)

1015− in [ toHie $ C (RecField c rhs) (L nspan var')

1016− ]

1017− XFieldOcc _ -> []

1018−

1019−instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where

1020− toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1021− Unambiguous name _ ->

1022− [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name

1023− ]

1024− Ambiguous _name _ ->

1025− [ ]

1026− XAmbiguousFieldOcc _ -> []

1027−

1028−instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where

1029− toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1030− Unambiguous var _ ->

1031− let var' = setVarName var (removeDefSrcSpan $ varName var)

1032− in [ toHie $ C (RecField c rhs) (L nspan var')

1033− ]

1034− Ambiguous var _ ->

1035− let var' = setVarName var (removeDefSrcSpan $ varName var)

1036− in [ toHie $ C (RecField c rhs) (L nspan var')

1037− ]

1038− XAmbiguousFieldOcc _ -> []

1039−

1040−instance ( a ~ GhcPass p

1041− , ToHie (PScoped (LPat a))

1042− , ToHie (BindContext (LHsBind a))

1043− , ToHie (LHsExpr a)

1044− , ToHie (SigContext (LSig a))

1045− , ToHie (RScoped (HsValBindsLR a a))

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

1047− , Data (HsLocalBinds a)

1048− ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where

1049− toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM

1050− [ toHie $ PS Nothing sc NoScope pat

1051− , toHie expr

1052− ]

1053− toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM

1054− [ toHie $ listScopes NoScope stmts

1055− , toHie $ PS Nothing sc NoScope pat

1056− ]

1057− toHie (RS _ (XApplicativeArg _)) = pure []

1058−

1059−instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where

1060− toHie (PrefixCon args) = toHie args

1061− toHie (RecCon rec) = toHie rec

1062− toHie (InfixCon a b) = concatM [ toHie a, toHie b]

1063−

1064−instance ( ToHie (LHsCmd a)

1065− , Data (HsCmdTop a)

1066− ) => ToHie (LHsCmdTop a) where

1067− toHie (L span top) = concatM $ makeNode top span : case top of

1068− HsCmdTop _ cmd ->

1069− [ toHie cmd

1070− ]

1071− XCmdTop _ -> []

1072−

1073−instance ( a ~ GhcPass p

1074− , ToHie (PScoped (LPat a))

1075− , ToHie (BindContext (LHsBind a))

1076− , ToHie (LHsExpr a)

1077− , ToHie (MatchGroup a (LHsCmd a))

1078− , ToHie (SigContext (LSig a))

1079− , ToHie (RScoped (HsValBindsLR a a))

1080− , Data (HsCmd a)

1081− , Data (HsCmdTop a)

1082− , Data (StmtLR a a (Located (HsCmd a)))

1083− , Data (HsLocalBinds a)

1084− , Data (StmtLR a a (Located (HsExpr a)))

1085− ) => ToHie (LHsCmd (GhcPass p)) where

1086− toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of

1087− HsCmdArrApp _ a b _ _ ->

1088− [ toHie a

1089− , toHie b

1090− ]

1091− HsCmdArrForm _ a _ _ cmdtops ->

1092− [ toHie a

1093− , toHie cmdtops

1094− ]

1095− HsCmdApp _ a b ->

1096− [ toHie a

1097− , toHie b

1098− ]

1099− HsCmdLam _ mg ->

1100− [ toHie mg

1101− ]

1102− HsCmdPar _ a ->

1103− [ toHie a

1104− ]

1105− HsCmdCase _ expr alts ->

1106− [ toHie expr

1107− , toHie alts

1108− ]

1109− HsCmdIf _ _ a b c ->

1110− [ toHie a

1111− , toHie b

1112− , toHie c

1113− ]

1114− HsCmdLet _ binds cmd' ->

1115− [ toHie $ RS (mkLScope cmd') binds

1116− , toHie cmd'

1117− ]

1118− HsCmdDo _ (L ispan stmts) ->

1119− [ pure $ locOnly ispan

1120− , toHie $ listScopes NoScope stmts

1121− ]

1122− HsCmdWrap _ _ _ -> []

1123− XCmd _ -> []

1124−

1125−instance ToHie (TyClGroup GhcRn) where

1126− toHie (TyClGroup _ classes roles instances) = concatM

1127− [ toHie classes

1128− , toHie roles

1129− , toHie instances

1130− ]

1131− toHie (XTyClGroup _) = pure []

1132−

1133−instance ToHie (LTyClDecl GhcRn) where

1134− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1135− FamDecl {tcdFam = fdecl} ->

1136− [ toHie (L span fdecl)

1137− ]

1138− SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->

1139− [ toHie $ C (Decl SynDec $ getRealSpan span) name

1140− , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars

1141− , toHie typ

1142− ]

1143− DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->

1144− [ toHie $ C (Decl DataDec $ getRealSpan span) name

1145− , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars

1146− , toHie defn

1147− ]

1148− where

1149− quant_scope = mkLScope $ dd_ctxt defn

1150− rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc

1151− sig_sc = maybe NoScope mkLScope $ dd_kindSig defn

1152− con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn

1153− deriv_sc = mkLScope $ dd_derivs defn

1154− ClassDecl { tcdCtxt = context

1155− , tcdLName = name

1156− , tcdTyVars = vars

1157− , tcdFDs = deps

1158− , tcdSigs = sigs

1159− , tcdMeths = meths

1160− , tcdATs = typs

1161− , tcdATDefs = deftyps

1162− } ->

1163− [ toHie $ C (Decl ClassDec $ getRealSpan span) name

1164− , toHie context

1165− , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars

1166− , toHie deps

1167− , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs

1168− , toHie $ fmap (BC InstanceBind ModuleScope) meths

1169− , toHie typs

1170− , concatMapM (pure . locOnly . getLoc) deftyps

1171− , toHie $ map (go . unLoc) deftyps

1172− ]

1173− where

1174− context_scope = mkLScope context

1175− rhs_scope = foldl1' combineScopes $ map mkScope

1176− [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]

1177−

1178− go :: TyFamDefltEqn GhcRn

1179− -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)

1180− go (FamEqn a var bndrs pat b rhs) =

1181− FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs

1182− go (XFamEqn NoExt) = XFamEqn NoExt

1183− XTyClDecl _ -> []

1184−

1185−instance ToHie (LFamilyDecl GhcRn) where

1186− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1187− FamilyDecl _ info name vars _ sig inj ->

1188− [ toHie $ C (Decl FamDec $ getRealSpan span) name

1189− , toHie $ TS (ResolvedScopes [rhsSpan]) vars

1190− , toHie info

1191− , toHie $ RS injSpan sig

1192− , toHie inj

1193− ]

1194− where

1195− rhsSpan = sigSpan `combineScopes` injSpan

1196− sigSpan = mkScope $ getLoc sig

1197− injSpan = maybe NoScope (mkScope . getLoc) inj

1198− XFamilyDecl _ -> []

1199−

1200−instance ToHie (FamilyInfo GhcRn) where

1201− toHie (ClosedTypeFamily (Just eqns)) = concatM $

1202− [ concatMapM (pure . locOnly . getLoc) eqns

1203− , toHie $ map go eqns

1204− ]

1205− where

1206− go (L l ib) = TS (ResolvedScopes [mkScope l]) ib

1207− toHie _ = pure []

1208−

1209−instance ToHie (RScoped (LFamilyResultSig GhcRn)) where

1210− toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of

1211− NoSig _ ->

1212− []

1213− KindSig _ k ->

1214− [ toHie k

1215− ]

1216− TyVarSig _ bndr ->

1217− [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr

1218− ]

1219− XFamilyResultSig _ -> []

1220−

1221−instance ToHie (Located (FunDep (Located Name))) where

1222− toHie (L span fd@(lhs, rhs)) = concatM $

1223− [ makeNode fd span

1224− , toHie $ map (C Use) lhs

1225− , toHie $ map (C Use) rhs

1226− ]

1227−

1228−instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs)

1229− => ToHie (TScoped (FamEqn GhcRn pats rhs)) where

1230− toHie (TS _ f) = toHie f

1231−

1232−instance ( ToHie pats

1233− , ToHie rhs

1234− , HasLoc pats

1235− , HasLoc rhs

1236− ) => ToHie (FamEqn GhcRn pats rhs) where

1237− toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $

1238− [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var

1239− , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1240− , toHie pats

1241− , toHie rhs

1242− ]

1243− where scope = combineScopes patsScope rhsScope

1244− patsScope = mkScope (loc pats)

1245− rhsScope = mkScope (loc rhs)

1246− toHie (XFamEqn _) = pure []

1247−

1248−instance ToHie (LInjectivityAnn GhcRn) where

1249− toHie (L span ann) = concatM $ makeNode ann span : case ann of

1250− InjectivityAnn lhs rhs ->

1251− [ toHie $ C Use lhs

1252− , toHie $ map (C Use) rhs

1253− ]

1254−

1255−instance ToHie (HsDataDefn GhcRn) where

1256− toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM

1257− [ toHie ctx

1258− , toHie mkind

1259− , toHie cons

1260− , toHie derivs

1261− ]

1262− toHie (XHsDataDefn _) = pure []

1263−

1264−instance ToHie (HsDeriving GhcRn) where

1265− toHie (L span clauses) = concatM

1266− [ pure $ locOnly span

1267− , toHie clauses

1268− ]

1269−

1270−instance ToHie (LHsDerivingClause GhcRn) where

1271− toHie (L span cl) = concatM $ makeNode cl span : case cl of

1272− HsDerivingClause _ strat (L ispan tys) ->

1273− [ toHie strat

1274− , pure $ locOnly ispan

1275− , toHie $ map (TS (ResolvedScopes [])) tys

1276− ]

1277− XHsDerivingClause _ -> []

1278−

1279−instance ToHie (Located (DerivStrategy GhcRn)) where

1280− toHie (L span strat) = concatM $ makeNode strat span : case strat of

1281− StockStrategy -> []

1282− AnyclassStrategy -> []

1283− NewtypeStrategy -> []

1284− ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]

1285−

1286−instance ToHie (Located OverlapMode) where

1287− toHie (L span _) = pure $ locOnly span

1288−

1289−instance ToHie (LConDecl GhcRn) where

1290− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1291− ConDeclGADT { con_names = names, con_qvars = qvars

1292− , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->

1293− [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names

1294− , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars

1295− , toHie ctx

1296− , toHie args

1297− , toHie typ

1298− ]

1299− where

1300− rhsScope = combineScopes argsScope tyScope

1301− ctxScope = maybe NoScope mkLScope ctx

1302− argsScope = condecl_scope args

1303− tyScope = mkLScope typ

1304− ConDeclH98 { con_name = name, con_ex_tvs = qvars

1305− , con_mb_cxt = ctx, con_args = dets } ->

1306− [ toHie $ C (Decl ConDec $ getRealSpan span) name

1307− , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars

1308− , toHie ctx

1309− , toHie dets

1310− ]

1311− where

1312− rhsScope = combineScopes ctxScope argsScope

1313− ctxScope = maybe NoScope mkLScope ctx

1314− argsScope = condecl_scope dets

1315− XConDecl _ -> []

1316− where condecl_scope args = case args of

1317− PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs

1318− InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)

1319− RecCon x -> mkLScope x

1320−

1321−instance ToHie (Located [LConDeclField GhcRn]) where

1322− toHie (L span decls) = concatM $

1323− [ pure $ locOnly span

1324− , toHie decls

1325− ]

1326−

1327−instance ( HasLoc thing

1328− , ToHie (TScoped thing)

1329− ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where

1330− toHie (TS sc (HsIB ibrn a)) = concatM $

1331− [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn

1332− , toHie $ TS sc a

1333− ]

1334− where span = loc a

1335− toHie (TS _ (XHsImplicitBndrs _)) = pure []

1336−

1337−instance ( HasLoc thing

1338− , ToHie (TScoped thing)

1339− ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where

1340− toHie (TS sc (HsWC names a)) = concatM $

1341− [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names

1342− , toHie $ TS sc a

1343− ]

1344− where span = loc a

1345− toHie (TS _ (XHsWildCardBndrs _)) = pure []

1346−

1347−instance ToHie (SigContext (LSig GhcRn)) where

1348− toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of

1349− TypeSig _ names typ ->

1350− [ toHie $ map (C TyDecl) names

1351− , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1352− ]

1353− PatSynSig _ names typ ->

1354− [ toHie $ map (C TyDecl) names

1355− , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1356− ]

1357− ClassOpSig _ _ names typ ->

1358− [ case styp of

1359− ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names

1360− _ -> toHie $ map (C $ TyDecl) names

1361− , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ

1362− ]

1363− IdSig _ _ -> []

1364− FixSig _ fsig ->

1365− [ toHie $ L sp fsig

1366− ]

1367− InlineSig _ name _ ->

1368− [ toHie $ (C Use) name

1369− ]

1370− SpecSig _ name typs _ ->

1371− [ toHie $ (C Use) name

1372− , toHie $ map (TS (ResolvedScopes [])) typs

1373− ]

1374− SpecInstSig _ _ typ ->

1375− [ toHie $ TS (ResolvedScopes []) typ

1376− ]

1377− MinimalSig _ _ form ->

1378− [ toHie form

1379− ]

1380− SCCFunSig _ _ name mtxt ->

1381− [ toHie $ (C Use) name

1382− , pure $ maybe [] (locOnly . getLoc) mtxt

1383− ]

1384− CompleteMatchSig _ _ (L ispan names) typ ->

1385− [ pure $ locOnly ispan

1386− , toHie $ map (C Use) names

1387− , toHie $ fmap (C Use) typ

1388− ]

1389− XSig _ -> []

1390−

1391−instance ToHie (LHsType GhcRn) where

1392− toHie x = toHie $ TS (ResolvedScopes []) x

1393−

1394−instance ToHie (TScoped (LHsType GhcRn)) where

1395− toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of

1396− HsForAllTy _ bndrs body ->

1397− [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs

1398− , toHie body

1399− ]

1400− HsQualTy _ ctx body ->

1401− [ toHie ctx

1402− , toHie body

1403− ]

1404− HsTyVar _ _ var ->

1405− [ toHie $ C Use var

1406− ]

1407− HsAppTy _ a b ->

1408− [ toHie a

1409− , toHie b

1410− ]

1411− HsAppKindTy _ ty ki ->

1412− [ toHie ty

1413− , toHie $ TS (ResolvedScopes []) ki

1414− ]

1415− HsFunTy _ a b ->

1416− [ toHie a

1417− , toHie b

1418− ]

1419− HsListTy _ a ->

1420− [ toHie a

1421− ]

1422− HsTupleTy _ _ tys ->

1423− [ toHie tys

1424− ]

1425− HsSumTy _ tys ->

1426− [ toHie tys

1427− ]

1428− HsOpTy _ a op b ->

1429− [ toHie a

1430− , toHie $ C Use op

1431− , toHie b

1432− ]

1433− HsParTy _ a ->

1434− [ toHie a

1435− ]

1436− HsIParamTy _ ip ty ->

1437− [ toHie ip

1438− , toHie ty

1439− ]

1440− HsKindSig _ a b ->

1441− [ toHie a

1442− , toHie b

1443− ]

1444− HsSpliceTy _ a ->

1445− [ toHie $ L span a

1446− ]

1447− HsDocTy _ a _ ->

1448− [ toHie a

1449− ]

1450− HsBangTy _ _ ty ->

1451− [ toHie ty

1452− ]

1453− HsRecTy _ fields ->

1454− [ toHie fields

1455− ]

1456− HsExplicitListTy _ _ tys ->

1457− [ toHie tys

1458− ]

1459− HsExplicitTupleTy _ tys ->

1460− [ toHie tys

1461− ]

1462− HsTyLit _ _ -> []

1463− HsWildCardTy _ -> []

1464− HsStarTy _ _ -> []

1465− XHsType _ -> []

1466−

1467−instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where

1468− toHie (HsValArg tm) = toHie tm

1469− toHie (HsTypeArg _ ty) = toHie ty

1470− toHie (HsArgPar sp) = pure $ locOnly sp

1471−

1472−instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where

1473− toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1474− UserTyVar _ var ->

1475− [ toHie $ C (TyVarBind sc tsc) var

1476− ]

1477− KindedTyVar _ var kind ->

1478− [ toHie $ C (TyVarBind sc tsc) var

1479− , toHie kind

1480− ]

1481− XTyVarBndr _ -> []

1482−

1483−instance ToHie (TScoped (LHsQTyVars GhcRn)) where

1484− toHie (TS sc (HsQTvs (HsQTvsRn implicits _) vars)) = concatM $

1485− [ pure $ bindingsOnly bindings

1486− , toHie $ tvScopes sc NoScope vars

1487− ]

1488− where

1489− varLoc = loc vars

1490− bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits

1491− toHie (TS _ (XLHsQTyVars _)) = pure []

1492−

1493−instance ToHie (LHsContext GhcRn) where

1494− toHie (L span tys) = concatM $

1495− [ pure $ locOnly span

1496− , toHie tys

1497− ]

1498−

1499−instance ToHie (LConDeclField GhcRn) where

1500− toHie (L span field) = concatM $ makeNode field span : case field of

1501− ConDeclField _ fields typ _ ->

1502− [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields

1503− , toHie typ

1504− ]

1505− XConDeclField _ -> []

1506−

1507−instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where

1508− toHie (From expr) = toHie expr

1509− toHie (FromThen a b) = concatM $

1510− [ toHie a

1511− , toHie b

1512− ]

1513− toHie (FromTo a b) = concatM $

1514− [ toHie a

1515− , toHie b

1516− ]

1517− toHie (FromThenTo a b c) = concatM $

1518− [ toHie a

1519− , toHie b

1520− , toHie c

1521− ]

1522−

1523−instance ToHie (LSpliceDecl GhcRn) where

1524− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1525− SpliceDecl _ splice _ ->

1526− [ toHie splice

1527− ]

1528− XSpliceDecl _ -> []

1529−

1530−instance ToHie (HsBracket a) where

1531− toHie _ = pure []

1532−

1533−instance ToHie PendingRnSplice where

1534− toHie _ = pure []

1535−

1536−instance ToHie PendingTcSplice where

1537− toHie _ = pure []

1538−

1539−instance ToHie (LBooleanFormula (Located Name)) where

1540− toHie (L span form) = concatM $ makeNode form span : case form of

1541− Var a ->

1542− [ toHie $ C Use a

1543− ]

1544− And forms ->

1545− [ toHie forms

1546− ]

1547− Or forms ->

1548− [ toHie forms

1549− ]

1550− Parens f ->

1551− [ toHie f

1552− ]

1553−

1554−instance ToHie (Located HsIPName) where

1555− toHie (L span e) = makeNode e span

1556−

1557−instance ( ToHie (LHsExpr a)

1558− , Data (HsSplice a)

1559− ) => ToHie (Located (HsSplice a)) where

1560− toHie (L span sp) = concatM $ makeNode sp span : case sp of

1561− HsTypedSplice _ _ _ expr ->

1562− [ toHie expr

1563− ]

1564− HsUntypedSplice _ _ _ expr ->

1565− [ toHie expr

1566− ]

1567− HsQuasiQuote _ _ _ ispan _ ->

1568− [ pure $ locOnly ispan

1569− ]

1570− HsSpliced _ _ _ ->

1571− []

1572− HsSplicedT _ ->

1573− []

1574− XSplice _ -> []

1575−

1576−instance ToHie (LRoleAnnotDecl GhcRn) where

1577− toHie (L span annot) = concatM $ makeNode annot span : case annot of

1578− RoleAnnotDecl _ var roles ->

1579− [ toHie $ C Use var

1580− , concatMapM (pure . locOnly . getLoc) roles

1581− ]

1582− XRoleAnnotDecl _ -> []

1583−

1584−instance ToHie (LInstDecl GhcRn) where

1585− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1586− ClsInstD _ d ->

1587− [ toHie $ L span d

1588− ]

1589− DataFamInstD _ d ->

1590− [ toHie $ L span d

1591− ]

1592− TyFamInstD _ d ->

1593− [ toHie $ L span d

1594− ]

1595− XInstDecl _ -> []

1596−

1597−instance ToHie (LClsInstDecl GhcRn) where

1598− toHie (L span decl) = concatM

1599− [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl

1600− , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl

1601− , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl

1602− , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl

1603− , toHie $ cid_tyfam_insts decl

1604− , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl

1605− , toHie $ cid_datafam_insts decl

1606− , toHie $ cid_overlap_mode decl

1607− ]

1608−

1609−instance ToHie (LDataFamInstDecl GhcRn) where

1610− toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1611−

1612−instance ToHie (LTyFamInstDecl GhcRn) where

1613− toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1614−

1615−instance ToHie (Context a)

1616− => ToHie (PatSynFieldContext (RecordPatSynField a)) where

1617− toHie (PSC sp (RecordPatSynField a b)) = concatM $

1618− [ toHie $ C (RecField RecFieldDecl sp) a

1619− , toHie $ C Use b

1620− ]

1621−

1622−instance ToHie (LDerivDecl GhcRn) where

1623− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1624− DerivDecl _ typ strat overlap ->

1625− [ toHie $ TS (ResolvedScopes []) typ

1626− , toHie strat

1627− , toHie overlap

1628− ]

1629− XDerivDecl _ -> []

1630−

1631−instance ToHie (LFixitySig GhcRn) where

1632− toHie (L span sig) = concatM $ makeNode sig span : case sig of

1633− FixitySig _ vars _ ->

1634− [ toHie $ map (C Use) vars

1635− ]

1636− XFixitySig _ -> []

1637−

1638−instance ToHie (LDefaultDecl GhcRn) where

1639− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1640− DefaultDecl _ typs ->

1641− [ toHie typs

1642− ]

1643− XDefaultDecl _ -> []

1644−

1645−instance ToHie (LForeignDecl GhcRn) where

1646− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1647− ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->

1648− [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name

1649− , toHie $ TS (ResolvedScopes []) sig

1650− , toHie fi

1651− ]

1652− ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->

1653− [ toHie $ C Use name

1654− , toHie $ TS (ResolvedScopes []) sig

1655− , toHie fe

1656− ]

1657− XForeignDecl _ -> []

1658−

1659−instance ToHie ForeignImport where

1660− toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $

1661− [ locOnly a

1662− , locOnly b

1663− , locOnly c

1664− ]

1665−

1666−instance ToHie ForeignExport where

1667− toHie (CExport (L a _) (L b _)) = pure $ concat $

1668− [ locOnly a

1669− , locOnly b

1670− ]

1671−

1672−instance ToHie (LWarnDecls GhcRn) where

1673− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1674− Warnings _ _ warnings ->

1675− [ toHie warnings

1676− ]

1677− XWarnDecls _ -> []

1678−

1679−instance ToHie (LWarnDecl GhcRn) where

1680− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1681− Warning _ vars _ ->

1682− [ toHie $ map (C Use) vars

1683− ]

1684− XWarnDecl _ -> []

1685−

1686−instance ToHie (LAnnDecl GhcRn) where

1687− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1688− HsAnnotation _ _ prov expr ->

1689− [ toHie prov

1690− , toHie expr

1691− ]

1692− XAnnDecl _ -> []

1693−

1694−instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where

1695− toHie (ValueAnnProvenance a) = toHie $ C Use a

1696− toHie (TypeAnnProvenance a) = toHie $ C Use a

1697− toHie ModuleAnnProvenance = pure []

1698−

1699−instance ToHie (LRuleDecls GhcRn) where

1700− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1701− HsRules _ _ rules ->

1702− [ toHie rules

1703− ]

1704− XRuleDecls _ -> []

1705−

1706−instance ToHie (LRuleDecl GhcRn) where

1707− toHie (L _ (XRuleDecl _)) = pure []

1708− toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM

1709− [ makeNode r span

1710− , pure $ locOnly $ getLoc rname

1711− , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1712− , toHie $ map (RS $ mkScope span) bndrs

1713− , toHie exprA

1714− , toHie exprB

1715− ]

1716− where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc

1717− bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)

1718− exprA_sc = mkLScope exprA

1719− exprB_sc = mkLScope exprB

1720−

1721−instance ToHie (RScoped (LRuleBndr GhcRn)) where

1722− toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1723− RuleBndr _ var ->

1724− [ toHie $ C (ValBind RegularBind sc Nothing) var

1725− ]

1726− RuleBndrSig _ var typ ->

1727− [ toHie $ C (ValBind RegularBind sc Nothing) var

1728− , toHie $ TS (ResolvedScopes [sc]) typ

1729− ]

1730− XRuleBndr _ -> []

1731−

1732−instance ToHie (LImportDecl GhcRn) where

1733− toHie (L span decl) = concatM $ makeNode decl span : case decl of

1734− ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->

1735− [ toHie $ IEC Import name

1736− , toHie $ fmap (IEC ImportAs) as

1737− , maybe (pure []) goIE hidden

1738− ]

1739− XImportDecl _ -> []

1740− where

1741− goIE (hiding, (L sp liens)) = concatM $

1742− [ pure $ locOnly sp

1743− , toHie $ map (IEC c) liens

1744− ]

1745− where

1746− c = if hiding then ImportHiding else Import

1747−

1748−instance ToHie (IEContext (LIE GhcRn)) where

1749− toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of

1750− IEVar _ n ->

1751− [ toHie $ IEC c n

1752− ]

1753− IEThingAbs _ n ->

1754− [ toHie $ IEC c n

1755− ]

1756− IEThingAll _ n ->

1757− [ toHie $ IEC c n

1758− ]

1759− IEThingWith _ n _ ns flds ->

1760− [ toHie $ IEC c n

1761− , toHie $ map (IEC c) ns

1762− , toHie $ map (IEC c) flds

1763− ]

1764− IEModuleContents _ n ->

1765− [ toHie $ IEC c n

1766− ]

1767− IEGroup _ _ _ -> []

1768− IEDoc _ _ -> []

1769− IEDocNamed _ _ -> []

1770− XIE _ -> []

1771−

1772−instance ToHie (IEContext (LIEWrappedName Name)) where

1773− toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of

1774− IEName n ->

1775− [ toHie $ C (IEThing c) n

1776− ]

1777− IEPattern p ->

1778− [ toHie $ C (IEThing c) p

1779− ]

1780− IEType n ->

1781− [ toHie $ C (IEThing c) n

1782− ]

1783−

1784−instance ToHie (IEContext (Located (FieldLbl Name))) where

1785− toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of

1786− FieldLabel _ _ n ->

1787− [ toHie $ C (IEThing c) $ L span n

1788− ]

1789−

src/Development/IDE/Compat.hsdeleted−19

@@ -1,19 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−module Development.IDE.Compat

3− (

4− getProcessID

5− ) where

6−

7−#ifdef mingw32_HOST_OS

8−

9−import qualified System.Win32.Process as P (getCurrentProcessId)

10−getProcessID :: IO Int

11−getProcessID = fromIntegral <$> P.getCurrentProcessId

12−

13−#else

14−

15−import qualified System.Posix.Process as P (getProcessID)

16−getProcessID :: IO Int

17−getProcessID = fromIntegral <$> P.getProcessID

18−

19−#endif

src/Development/IDE/Core/Compile.hs+105−322

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

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

1312 , compileModule

1413 , parseModule

1514 , typecheckModule

@@ -17,18 +16,10 @@ module Development.IDE.Core.Compile

1716 , addRelativeImport

1817 , mkTcModuleResult

1918 , generateByteCode

20− , generateAndWriteHieFile

21− , generateAndWriteHiFile

22− , getModSummaryFromImports

23− , loadHieFile

24− , loadInterface

25− , loadDepModule

26− , loadModuleHome

2719 ) where

2820

2921import Development.IDE.Core.RuleTypes

3022import Development.IDE.Core.Preprocessor

31−import Development.IDE.Core.Shake

3223import Development.IDE.GHC.Error

3324import Development.IDE.GHC.Warnings

3425import Development.IDE.Types.Diagnostics

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

3728import qualified GHC.LanguageExtensions.Type as GHC

3829import Development.IDE.Types.Options

3930import Development.IDE.Types.Location

40−import Outputable

4131

4232#if MIN_GHC_API_VERSION(8,6,0)

4333import DynamicLoading (initializePlugins)

@@ -46,60 +36,42 @@ import DynamicLoading (initializePlugins)

4636import GHC hiding (parseModule, typecheckModule)

4737import qualified Parser

4838import Lexer

49−#if MIN_GHC_API_VERSION(8,10,0)

50−#else

5139import ErrUtils

52−#endif

5340

54−import Finder

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

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

41+import qualified GHC

5742import GhcMonad

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

5944import qualified HeaderInfo as Hdr

60−import HscMain (hscInteractive, hscSimplify)

61−import LoadIface (readIface)

62−import qualified Maybes

45+import HscMain (hscInteractive)

6346import MkIface

64−import NameCache

6547import StringBuffer as SB

66−import TcRnMonad (initIfaceLoad, tcg_th_coreplugins)

67−import TcIface (typecheckIface)

6848import TidyPgm

6949

70−import Control.Exception.Safe

7150import Control.Monad.Extra

7251import Control.Monad.Except

7352import Control.Monad.Trans.Except

74−import Data.Bifunctor (first, second)

53+import Data.Function

54+import Data.Ord

7555import qualified Data.Text as T

7656import Data.IORef

7757import Data.List.Extra

7858import Data.Maybe

59+import Data.Tuple.Extra

7960import qualified Data.Map.Strict as Map

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

8762

8863

89−-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.

64+-- | Given a string buffer, return a pre-processed @ParsedModule@.

9065parseModule

9166 :: IdeOptions

9267 -> HscEnv

93− -> [PackageName]

9468 -> FilePath

9569 -> Maybe SB.StringBuffer

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

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

10375

10476

10577-- | Given a package identifier, what packages does it depend on

@@ -110,39 +82,31 @@ computePackageDeps

11082computePackageDeps env pkg = do

11183 let dflags = hsc_dflags env

11284 case lookupInstalledPackage dflags pkg of

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

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

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

11587 Just pkgInfo -> return $ Right $ depends pkgInfo

11688

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

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+ modSummary' <- initPlugins modSummary

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

107+ GHC.typecheckModule $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}

108+ tcm2 <- mkTcModuleResult tcm

109+ return (map unDefer warnings, tcm2)

146110

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

148112initPlugins modSummary = do

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

154118 return modSummary

155119#endif

156120

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−

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

164122-- provide errors.

165123compileModule

166− :: RunSimplifier

167− -> HscEnv

168− -> [(ModSummary, HomeModInfo)]

124+ :: HscEnv

125+ -> [TcModuleResult]

169126 -> TcModuleResult

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

171−compileModule (RunSimplifier simplify) packageState deps tmr =

127+ -> IO ([FileDiagnostic], Maybe (SafeHaskellMode, CgGuts, ModDetails))

128+compileModule packageState deps tmr =

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

173− evalGhcEnv packageState $

130+ runGhcEnv packageState $

174131 catchSrcErrors "compile" $ do

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

132+ setupEnv (deps ++ [tmr])

176133

177134 let tm = tmrModule tmr

178135 session <- getSession

@@ -181,30 +138,20 @@ compileModule (RunSimplifier simplify) packageState deps tmr =

181138 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}

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

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

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

141+

191142 -- give variables unique OccNames

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

143+ (guts, details) <- liftIO $ tidyProgram session desugar

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

194145

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

146+generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO ([FileDiagnostic], Maybe Linkable)

196147generateByteCode hscEnv deps tmr guts =

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

198− evalGhcEnv hscEnv $

149+ runGhcEnv hscEnv $

199150 catchSrcErrors "bytecode" $ do

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

151+ setupEnv (deps ++ [tmr])

201152 session <- getSession

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

203−#if MIN_GHC_API_VERSION(8,10,0)

204− liftIO $ hscInteractive session guts (GHC.ms_location $ tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)

205−#else

206− liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)

207−#endif

154+ liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)

208155 let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr

209156 let unlinked = BCOs bytecode sptEntries

210157 let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]

@@ -223,20 +170,12 @@ demoteTypeErrorsToWarnings =

223170 . (`gopt_set` Opt_DeferTypedHoles)

224171 . (`gopt_set` Opt_DeferOutOfScopeVariables)

225172

226−enableTopLevelWarnings :: ParsedModule -> ParsedModule

227−enableTopLevelWarnings =

228− (update_pm_mod_summary . update_hspp_opts)

229− ((`wopt_set` Opt_WarnMissingPatternSynonymSignatures) .

230− (`wopt_set` Opt_WarnMissingSignatures))

231− -- the line below would show also warnings for let bindings without signature

232− -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures)))

173+ update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary

174+ update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}

233175

234−update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary

235−update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}

236−

237−update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule

238−update_pm_mod_summary up pm =

239− pm{pm_mod_summary = up $ pm_mod_summary pm}

176+ update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule

177+ update_pm_mod_summary up pm =

178+ pm{pm_mod_summary = up $ pm_mod_summary pm}

240179

241180unDefer :: (WarnReason, FileDiagnostic) -> FileDiagnostic

242181unDefer (Reason Opt_WarnDeferredTypeErrors , fd) = upgradeWarningToError fd

@@ -245,17 +184,12 @@ unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = upgradeWarningToError

245184unDefer ( _ , fd) = fd

246185

247186upgradeWarningToError :: FileDiagnostic -> FileDiagnostic

248−upgradeWarningToError (nfp, sh, fd) =

249− (nfp, sh, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where

187+upgradeWarningToError (nfp, fd) =

188+ (nfp, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where

250189 warn2err :: T.Text -> T.Text

251190 warn2err = T.intercalate ": error:" . T.splitOn ": warning:"

252191

253−hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)

254−hideDiag originalFlags (Reason warning, (nfp, _sh, fd))

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

256−hideDiag _originalFlags t = t

257−

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

192+addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags

259193addRelativeImport fp modu dflags = dflags

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

261195

@@ -265,81 +199,25 @@ mkTcModuleResult

265199 -> m TcModuleResult

266200mkTcModuleResult tcm = do

267201 session <- getSession

268− let sf = modInfoSafe (tm_checked_module_info tcm)

269−#if MIN_GHC_API_VERSION(8,10,0)

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

271−#else

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

273−#endif

202+ (iface, _) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv

274203 let mod_info = HomeModInfo iface details Nothing

275204 return $ TcModuleResult tcm mod_info

276205 where

277206 (tcGblEnv, details) = tm_internals_ tcm

278207

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−

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

326209-- best understanding (!)

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

210+setupEnv :: GhcMonad m => [TcModuleResult] -> m ()

211+setupEnv tmsIn = do

212+ -- if both a .hs-boot file and a .hs file appear here, we want to make sure that the .hs file

213+ -- takes precedence, so put the .hs-boot file earlier in the list

214+ let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule

215+ tms = sortBy (compare `on` Down . isSourceFile) tmsIn

336216

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

338−-- sorted.

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

340−setupFinderCache mss = do

341217 session <- getSession

342218

219+ let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms

220+

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

344222 let graph = mkModuleGraph mss

345223 setSession session { hsc_mod_graph = graph }

@@ -358,40 +236,26 @@ setupFinderCache mss = do

358236 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache

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

360238

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

240+ mapM_ loadModuleHome tms

241+

361242

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

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

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

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

370247loadModuleHome

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

248+ :: (GhcMonad m)

249+ => TcModuleResult

250+ -> m ()

251+loadModuleHome tmr = modifySession $ \e ->

252+ e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }

253+ where

254+ ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr

255+ mod_info = tmrModInfo tmr

256+ mod = ms_mod_name ms

257+

389258

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'

395259

396260-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's

397261-- name and its imports.

@@ -412,18 +276,30 @@ getImportsParsed dflags (L loc parsed) = do

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

413277 ])

414278

279+

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

416281getModSummaryFromBuffer

417282 :: GhcMonad m

418283 => FilePath

284+ -> SB.StringBuffer

419285 -> DynFlags

420286 -> GHC.ParsedSource

421287 -> ExceptT [FileDiagnostic] m ModSummary

422−getModSummaryFromBuffer fp dflags parsed = do

288+getModSummaryFromBuffer fp contents dflags parsed = do

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

424290

425− modLoc <- liftIO $ mkHomeModLocation dflags modName fp

426− let InstalledUnitId unitId = thisInstalledUnitId dflags

291+ let modLoc = ModLocation

292+ { ml_hs_file = Just fp

293+ , ml_hi_file = derivedFile "hi"

294+ , ml_obj_file = derivedFile "o"

295+#if MIN_GHC_API_VERSION(8,8,0)

296+ , ml_hie_file = derivedFile "hie"

297+#endif

298+ -- This does not consider the dflags configuration

299+ -- (-osuf and -hisuf, object and hi dir.s).

300+ -- However, we anyway don't want to generate them.

301+ }

302+ InstalledUnitId unitId = thisInstalledUnitId dflags

427303 return $ ModSummary

428304 { ms_mod = mkModule (fsToUnitId unitId) modName

429305 , ms_location = modLoc

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

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

436312 , ms_hspp_file = fp

437313 , ms_hspp_opts = dflags

438− , ms_hspp_buf = Nothing

314+ , ms_hspp_buf = Just contents

439315

440316 -- defaults:

441317 , ms_hsc_src = sourceType

@@ -448,71 +324,27 @@ getModSummaryFromBuffer fp dflags parsed = do

448324 , ms_parsed_mod = Nothing

449325 }

450326 where

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

327+ (sourceType, derivedFile) =

328+ let (stem, ext) = splitExtension fp in

329+ if "-boot" `isSuffixOf` ext

330+ then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")

331+ else (HsSrcFile , \newExt -> stem <.> newExt)

332+

333+

334+-- | Given a buffer, flags, file path and module summary, produce a

335+-- parsed module (or errors) and any parse warnings.

499336parseFileContents

500337 :: GhcMonad m

501338 => (GHC.ParsedSource -> IdePreprocessedSource)

502− -> DynFlags -- ^ flags to use

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

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

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

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

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

507−parseFileContents customPreprocessor dflags comp_pkgs filename contents = do

342+parseFileContents customPreprocessor filename mbContents = do

343+ (contents, dflags) <- preprocessor filename mbContents

508344 let loc = mkRealSrcLoc (mkFastString filename) 1 1

509345 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

513346 PFailed _ locErr msgErr ->

514347 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr

515−#endif

516348 POk pst rdr_module ->

517349 let hpm_annotations =

518350 (Map.fromListWith (++) $ annotations pst,

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

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

537369 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

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

539− let parsed' = removePackageImports comp_pkgs parsed

540371 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

541− ms <- getModSummaryFromBuffer filename dflags parsed'

372+ ms <- getModSummaryFromBuffer filename contents dflags parsed

542373 let pm =

543374 ParsedModule {

544375 pm_mod_summary = ms

545− , pm_parsed_source = parsed'

376+ , pm_parsed_source = parsed

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

547378 , pm_annotations = hpm_annotations

548379 }

549380 warnings = diagFromErrMsgs "parser" dflags warns

550381 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+11−18

@@ -3,18 +3,16 @@

44module Development.IDE.Core.Debouncer

55 ( Debouncer

6+ , newDebouncer

67 , registerEvent

7− , newAsyncDebouncer

8− , noopDebouncer

98 ) where

109

1110import Control.Concurrent.Extra

1211import Control.Concurrent.Async

1312import Control.Exception

1413import Control.Monad.Extra

15−import Data.Hashable

16−import Data.HashMap.Strict (HashMap)

17−import qualified Data.HashMap.Strict as Map

14+import Data.Map.Strict (Map)

15+import qualified Data.Map.Strict as Map

1816import System.Time.Extra

1917

2018-- | A debouncer can be used to avoid triggering many events

@@ -23,14 +21,13 @@ import System.Time.Extra

2321-- by delaying each event for a given time. If another event

2422-- is registered for the same key within that timeframe,

2523-- only the new event will fire.

26−--

27−-- We abstract over the debouncer used so we an use a proper debouncer in the IDE but disable

28−-- debouncing in the DAML CLI compiler.

29−newtype Debouncer k = Debouncer { registerEvent :: Seconds -> k -> IO () -> IO () }

24+newtype Debouncer k = Debouncer (Var (Map k (Async ())))

3025

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

26+-- | Create a new empty debouncer.

27+newDebouncer :: IO (Debouncer k)

28+newDebouncer = do

29+ m <- newVar Map.empty

30+ pure $ Debouncer m

3431

3532-- | Register an event that will fire after the given delay if no other event

3633-- for the same key gets registered until then.

@@ -38,15 +35,11 @@ newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty

3835-- If there is a pending event for the same key, the pending event will be killed.

3936-- Events are run unmasked so it is up to the user of `registerEvent`

4037-- to mask if required.

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

38+registerEvent :: Ord k => Debouncer k -> Seconds -> k -> IO () -> IO ()

39+registerEvent (Debouncer d) delay k fire = modifyVar_ d $ \m -> mask_ $ do

4340 whenJust (Map.lookup k m) cancel

4441 a <- asyncWithUnmask $ \unmask -> unmask $ do

4542 sleep delay

4643 fire

4744 modifyVar_ d (pure . Map.delete k)

4845 pure $ Map.insert k a m

49−

50−-- | Debouncer used in the DAML CLI compiler that emits events immediately.

51−noopDebouncer :: Debouncer k

52−noopDebouncer = Debouncer $ \_ _ a -> a

src/Development/IDE/Core/FileExists.hsdeleted−181

@@ -1,181 +0,0 @@

1−{-# LANGUAGE OverloadedLists #-}

2−{-# LANGUAGE TypeFamilies #-}

3−{-# LANGUAGE UndecidableInstances #-}

4−module Development.IDE.Core.FileExists

5− ( fileExistsRules

6− , modifyFileExists

7− , getFileExists

8− )

9−where

10−

11−import Control.Concurrent.Extra

12−import Control.Exception

13−import Control.Monad.Extra

14−import qualified Data.Aeson as A

15−import Data.Binary

16−import qualified Data.ByteString as BS

17−import Data.HashMap.Strict (HashMap)

18−import qualified Data.HashMap.Strict as HashMap

19−import Data.Maybe

20−import qualified Data.Text as T

21−import Development.IDE.Core.FileStore

22−import Development.IDE.Core.IdeConfiguration

23−import Development.IDE.Core.Shake

24−import Development.IDE.Types.Location

25−import Development.IDE.Types.Logger

26−import Development.Shake

27−import Development.Shake.Classes

28−import GHC.Generics

29−import Language.Haskell.LSP.Messages

30−import Language.Haskell.LSP.Types

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

32−import qualified System.Directory as Dir

33−

34−-- | A map for tracking the file existence

35−type FileExistsMap = (HashMap NormalizedFilePath Bool)

36−

37−-- | A wrapper around a mutable 'FileExistsMap'

38−newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap)

39−

40−instance IsIdeGlobal FileExistsMapVar

41−

42−-- | Grab the current global value of 'FileExistsMap' without acquiring a dependency

43−getFileExistsMapUntracked :: Action FileExistsMap

44−getFileExistsMapUntracked = do

45− FileExistsMapVar v <- getIdeGlobalAction

46− liftIO $ readVar v

47−

48−-- | Modify the global store of file exists

49−modifyFileExistsAction :: (FileExistsMap -> IO FileExistsMap) -> Action ()

50−modifyFileExistsAction f = do

51− FileExistsMapVar var <- getIdeGlobalAction

52− liftIO $ modifyVar_ var f

53−

54−-- | Modify the global store of file exists

55−modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO ()

56−modifyFileExists state changes = do

57− FileExistsMapVar var <- getIdeGlobalState state

58− changesMap <- evaluate $ HashMap.fromList changes

59−

60− -- Masked to ensure that the previous values are flushed together with the map update

61− mask $ \_ -> do

62− -- update the map

63− modifyVar_ var $ evaluate . HashMap.union changesMap

64− -- flush previous values

65− mapM_ (deleteValue state GetFileExists . fst) changes

66−

67−-------------------------------------------------------------------------------------

68−

69−type instance RuleResult GetFileExists = Bool

70−

71−data GetFileExists = GetFileExists

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

73−

74−instance NFData GetFileExists

75−instance Hashable GetFileExists

76−instance Binary GetFileExists

77−

78−-- | Returns True if the file exists

79−-- Note that a file is not considered to exist unless it is saved to disk.

80−-- In particular, VFS existence is not enough.

81−-- Consider the following example:

82−-- 1. The file @A.hs@ containing the line @import B@ is added to the files of interest

83−-- Since @B.hs@ is neither open nor exists, GetLocatedImports finds Nothing

84−-- 2. The editor creates a new buffer @B.hs@

85−-- Unless the editor also sends a @DidChangeWatchedFile@ event, ghcide will not pick it up

86−-- Most editors, e.g. VSCode, only send the event when the file is saved to disk.

87−getFileExists :: NormalizedFilePath -> Action Bool

88−getFileExists fp = use_ GetFileExists fp

89−

90−-- | Installs the 'getFileExists' rules.

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

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

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

94−fileExistsRules getLspId ClientCapabilities{_workspace} vfs = do

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

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

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

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

99− case () of

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

101− , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles

102− , Just True <- _dynamicRegistration

103− -> fileExistsRulesFast getLspId vfs

104− | otherwise -> do

105− logger <- logger <$> getShakeExtrasRules

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

107− fileExistsRulesSlow vfs

108−

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

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

111−fileExistsRulesFast getLspId vfs =

112− defineEarlyCutoff $ \GetFileExists file -> do

113− isWf <- isWorkspaceFile file

114− if isWf

115− then fileExistsFast getLspId vfs file

116− else fileExistsSlow vfs file

117−

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

119−fileExistsFast getLspId vfs file = do

120− fileExistsMap <- getFileExistsMapUntracked

121− let mbFilesWatched = HashMap.lookup file fileExistsMap

122− case mbFilesWatched of

123− Just fv -> pure (summarizeExists fv, ([], Just fv))

124− Nothing -> do

125− exist <- liftIO $ getFileExistsVFS vfs file

126− ShakeExtras { eventer } <- getShakeExtras

127−

128− -- add a listener for VFS Create/Delete file events,

129− -- taking the FileExistsMap lock to prevent race conditions

130− -- that would lead to multiple listeners for the same path

131− modifyFileExistsAction $ \x -> do

132− case HashMap.alterF (,Just exist) file x of

133− (Nothing, x') -> do

134− -- if the listener addition fails, we never recover. This is a bug.

135− addListener eventer file

136− return x'

137− (Just _, _) ->

138− -- if the key was already there, do nothing

139− return x

140−

141− pure (summarizeExists exist, ([], Just exist))

142− where

143− addListener eventer fp = do

144− reqId <- getLspId

145− let

146− req = RequestMessage "2.0" reqId ClientRegisterCapability regParams

147− fpAsId = T.pack $ fromNormalizedFilePath fp

148− regParams = RegistrationParams (List [registration])

149− registration = Registration fpAsId

150− WorkspaceDidChangeWatchedFiles

151− (Just (A.toJSON regOptions))

152− regOptions =

153− DidChangeWatchedFilesRegistrationOptions { _watchers = List [watcher] }

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

155− watcher = FileSystemWatcher { _globPattern = fromNormalizedFilePath fp

156− , _kind = Just watchKind

157− }

158−

159− eventer $ ReqRegisterCapability req

160−

161−summarizeExists :: Bool -> Maybe BS.ByteString

162−summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty

163−

164−fileExistsRulesSlow:: VFSHandle -> Rules ()

165−fileExistsRulesSlow vfs =

166− defineEarlyCutoff $ \GetFileExists file -> fileExistsSlow vfs file

167−

168−fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))

169−fileExistsSlow vfs file = do

170− alwaysRerun

171− exist <- liftIO $ getFileExistsVFS vfs file

172− pure (summarizeExists exist, ([], Just exist))

173−

174−getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool

175−getFileExistsVFS vfs file = do

176− -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute

177− -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly

178− -- cached 'No' rather than an exception in the wrong place

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

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

181− Dir.doesFileExist (fromNormalizedFilePath file)

src/Development/IDE/Core/FileStore.hs+69−21

@@ -4,25 +4,32 @@

44{-# LANGUAGE TypeFamilies #-}

66module Development.IDE.Core.FileStore(

7− getFileContents,

8− getVirtualFile,

7+ getFileExists, getFileContents,

98 setBufferModified,

109 setSomethingModified,

1110 fileStoreRules,

1211 VFSHandle,

1312 makeVFSHandle,

14− makeLSPVFSHandle

13+ makeLSPVFSHandle,

14+ getSourceFingerprint

1515 ) where

1616

17+import Foreign.Ptr

18+import Foreign.ForeignPtr

19+import Fingerprint

20+import StringBuffer

1721import Development.IDE.GHC.Orphans()

18−import Development.IDE.Core.Shake

22+import Development.IDE.GHC.Util

23+

1924import Control.Concurrent.Extra

2025import qualified Data.Map.Strict as Map

2126import Data.Maybe

2227import qualified Data.Text as T

2328import Control.Monad.Extra

29+import qualified System.Directory as Dir

2430import Development.Shake

2531import Development.Shake.Classes

32+import Development.IDE.Core.Shake

2633import Control.Exception

2734import GHC.Generics

2835import Data.Either.Extra

@@ -34,9 +41,7 @@ import qualified Data.Rope.UTF16 as Rope

3441

3542#ifdef mingw32_HOST_OS

3643import Data.Time

37−import qualified System.Directory as Dir

3844#else

39−import Foreign.Ptr

4045import Foreign.C.String

4146import Foreign.C.Types

4247import Foreign.Marshal (alloca)

@@ -71,8 +76,7 @@ makeVFSHandle = do

7176 modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $

7277 case content of

7378 Nothing -> Map.delete uri vfs

74− -- The second version number is only used in persistFileVFS which we do not use so we set it to 0.

75− Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) vfs

79+ Just content -> Map.insert uri (VirtualFile nextVersion (Rope.fromText content)) vfs

7680 }

7781

7882makeLSPVFSHandle :: LspFuncs c -> VFSHandle

@@ -83,7 +87,18 @@ makeLSPVFSHandle lspFuncs = VFSHandle

8387

8488

8589-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.

86−type instance RuleResult GetFileContents = (FileVersion, Maybe T.Text)

90+type instance RuleResult GetFileContents = (FileVersion, Maybe StringBuffer)

91+

92+-- | Does the file exist.

93+type instance RuleResult GetFileExists = Bool

94+

95+type instance RuleResult FingerprintSource = Fingerprint

96+

97+data GetFileExists = GetFileExists

98+ deriving (Eq, Show, Generic)

99+instance Hashable GetFileExists

100+instance NFData GetFileExists

101+instance Binary GetFileExists

87102

88103data GetFileContents = GetFileContents

89104 deriving (Eq, Show, Generic)

@@ -91,16 +106,40 @@ instance Hashable GetFileContents

91106instance NFData GetFileContents

92107instance Binary GetFileContents

93108

109+data FingerprintSource = FingerprintSource

110+ deriving (Eq, Show, Generic)

111+instance Hashable FingerprintSource

112+instance NFData FingerprintSource

113+instance Binary FingerprintSource

114+

115+fingerprintSourceRule :: Rules ()

116+fingerprintSourceRule =

117+ define $ \FingerprintSource file -> do

118+ (_, mbContent) <- getFileContents file

119+ content <- liftIO $ maybe (hGetStringBuffer $ fromNormalizedFilePath file) pure mbContent

120+ fingerprint <- liftIO $ fpStringBuffer content

121+ pure ([], Just fingerprint)

122+ where fpStringBuffer (StringBuffer buf len cur) = withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len

123+

124+getFileExistsRule :: VFSHandle -> Rules ()

125+getFileExistsRule vfs =

126+ defineEarlyCutoff $ \GetFileExists file -> do

127+ alwaysRerun

128+ res <- liftIO $ handle (\(_ :: IOException) -> return False) $

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

130+ Dir.doesFileExist (fromNormalizedFilePath file)

131+ return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))

132+

133+

94134getModificationTimeRule :: VFSHandle -> Rules ()

95135getModificationTimeRule vfs =

96136 defineEarlyCutoff $ \GetModificationTime file -> do

97137 let file' = fromNormalizedFilePath file

98− let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s))

138+ let wrap time = (Just time, ([], Just $ ModificationTime time))

99139 alwaysRerun

100140 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file

101141 case mbVirtual of

102− Just (virtualFileVersion -> ver) ->

103− pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))

142+ Just (VirtualFile ver _) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))

104143 Nothing -> liftIO $ fmap wrap (getModTime file')

105144 `catch` \(e :: IOException) -> do

106145 let err | isDoesNotExistError e = "File does not exist: " ++ file'

@@ -114,15 +153,11 @@ getModificationTimeRule vfs =

114153 -- time spent checking file modifications (which happens on every change)

115154 -- from > 0.5s to ~0.15s.

116155 -- We might also want to try speeding this up on Windows at some point.

117− -- TODO leverage DidChangeWatchedFile lsp notifications on clients that

118− -- support them, as done for GetFileExists

119− getModTime :: FilePath -> IO (Int,Int)

156+ getModTime :: FilePath -> IO BS.ByteString

120157 getModTime f =

121158#ifdef mingw32_HOST_OS

122159 do time <- Dir.getModificationTime f

123− let !day = fromInteger $ toModifiedJulianDay $ utctDay time

124− !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time

125− pure (day, dayTime)

160+ pure $! BS.pack $ show (toModifiedJulianDay $ utctDay time, diffTimeToPicoseconds $ utctDayTime time)

126161#else

127162 withCString f $ \f' ->

128163 alloca $ \secPtr ->

@@ -130,13 +165,16 @@ getModificationTimeRule vfs =

130165 Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr

131166 sec <- peek secPtr

132167 nsec <- peek nsecPtr

133− pure (fromEnum sec, fromIntegral nsec)

168+ pure $! BS.pack $ show sec <> "." <> show nsec

134169

135170-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow

136171-- as doing the FFI call ourselves :(.

137172foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int

138173#endif

139174

175+getSourceFingerprint :: NormalizedFilePath -> Action Fingerprint

176+getSourceFingerprint = use_ FingerprintSource

177+

140178getFileContentsRule :: VFSHandle -> Rules ()

141179getFileContentsRule vfs =

142180 define $ \GetFileContents file -> do

@@ -144,7 +182,7 @@ getFileContentsRule vfs =

144182 time <- use_ GetModificationTime file

145183 res <- liftIO $ ideTryIOException file $ do

146184 mbVirtual <- getVirtualFile vfs $ filePathToUri' file

147− pure $ Rope.toText . _text <$> mbVirtual

185+ pure $ textToStringBuffer . Rope.toText . _text <$> mbVirtual

148186 case res of

149187 Left err -> return ([err], Nothing)

150188 Right contents -> return ([], Just (time, contents))

@@ -156,14 +194,24 @@ ideTryIOException fp act =

156194 <$> try act

157195

158196

159−getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe T.Text)

197+getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe StringBuffer)

160198getFileContents = use_ GetFileContents

161199

200+getFileExists :: NormalizedFilePath -> Action Bool

201+getFileExists =

202+ -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute

203+ -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly

204+ -- cached 'No' rather than an exception in the wrong place

205+ use_ GetFileExists

206+

207+

162208fileStoreRules :: VFSHandle -> Rules ()

163209fileStoreRules vfs = do

164210 addIdeGlobal vfs

165211 getModificationTimeRule vfs

166212 getFileContentsRule vfs

213+ getFileExistsRule vfs

214+ fingerprintSourceRule

167215

168216

169217-- | Notify the compiler service that a particular file has been modified.

src/Development/IDE/Core/IdeConfiguration.hsdeleted−71

@@ -1,71 +0,0 @@

1−{-# LANGUAGE DuplicateRecordFields #-}

2−module Development.IDE.Core.IdeConfiguration

3− ( IdeConfiguration(..)

4− , registerIdeConfiguration

5− , parseConfiguration

6− , parseWorkspaceFolder

7− , isWorkspaceFile

8− , modifyWorkspaceFolders

9− )

10−where

11−

12−import Control.Concurrent.Extra

13−import Control.Monad

14−import Data.HashSet (HashSet, singleton)

15−import Data.Text (Text, isPrefixOf)

16−import Development.IDE.Core.Shake

17−import Development.IDE.Types.Location

18−import Development.Shake

19−import Language.Haskell.LSP.Types

20−import System.FilePath (isRelative)

21−

22−-- | Lsp client relevant configuration details

23−data IdeConfiguration = IdeConfiguration

24− { workspaceFolders :: HashSet NormalizedUri

25− }

26− deriving (Show)

27−

28−newtype IdeConfigurationVar = IdeConfigurationVar {unIdeConfigurationRef :: Var IdeConfiguration}

29−

30−instance IsIdeGlobal IdeConfigurationVar

31−

32−registerIdeConfiguration :: ShakeExtras -> IdeConfiguration -> IO ()

33−registerIdeConfiguration extras =

34− addIdeGlobalExtras extras . IdeConfigurationVar <=< newVar

35−

36−getIdeConfiguration :: Action IdeConfiguration

37−getIdeConfiguration =

38− getIdeGlobalAction >>= liftIO . readVar . unIdeConfigurationRef

39−

40−parseConfiguration :: InitializeParams -> IdeConfiguration

41−parseConfiguration InitializeParams {..} =

42− IdeConfiguration { .. }

43− where

44− workspaceFolders =

45− foldMap (singleton . toNormalizedUri) _rootUri

46− <> (foldMap . foldMap)

47− (singleton . parseWorkspaceFolder)

48− _workspaceFolders

49−

50−parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri

51−parseWorkspaceFolder =

52− toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text)

53−

54−modifyWorkspaceFolders

55− :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()

56−modifyWorkspaceFolders ide f = do

57− IdeConfigurationVar var <- getIdeGlobalState ide

58− IdeConfiguration ws <- readVar var

59− writeVar var (IdeConfiguration (f ws))

60−

61−isWorkspaceFile :: NormalizedFilePath -> Action Bool

62−isWorkspaceFile file =

63− if isRelative (fromNormalizedFilePath file)

64− then return True

65− else do

66− IdeConfiguration {..} <- getIdeConfiguration

67− let toText = getUri . fromNormalizedUri

68− return $

69− any

70− (\root -> toText root `isPrefixOf` toText (filePathToUri' file))

71− workspaceFolders

src/Development/IDE/Core/OfInterest.hs+24−24

@@ -1,17 +1,19 @@

22-- SPDX-License-Identifier: Apache-2.0

4−{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE TypeFamilies #-}

56{-# LANGUAGE FlexibleInstances #-}

7−-- | Utilities and state for the files of interest - those which are currently

8−-- open in the editor. The useful function is 'getFilesOfInterest'.

8+-- | A Shake implementation of the compiler service, built

9+-- using the "Shaker" abstraction layer for in-memory use.

10+--

911module Development.IDE.Core.OfInterest(

1012 ofInterestRules,

1113 getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,

1214 ) where

1315

14−import Control.Concurrent.Extra

16+import Control.Concurrent.Extra

1517import Data.Binary

1618import Data.Hashable

1719import Control.DeepSeq

@@ -19,22 +21,25 @@ import GHC.Generics

1921import Data.Typeable

2022import qualified Data.ByteString.UTF8 as BS

2123import Control.Exception

22−import Data.HashSet (HashSet)

23−import qualified Data.HashSet as HashSet

24+import Development.IDE.Types.Location

25+import Development.IDE.Types.Logger

26+import Data.Set (Set)

27+import qualified Data.Set as Set

2428import qualified Data.Text as T

2529import Data.Tuple.Extra

2630import Data.Functor

27−import Development.Shake

31+import Development.Shake

32+

33+import Development.IDE.Core.Shake

2834

29−import Development.IDE.Types.Location

30−import Development.IDE.Types.Logger

31−import Development.IDE.Core.Shake

3235

3336

34−newtype OfInterestVar = OfInterestVar (Var (HashSet NormalizedFilePath))

37+newtype OfInterestVar = OfInterestVar (Var (Set NormalizedFilePath))

3538instance IsIdeGlobal OfInterestVar

3639

37−type instance RuleResult GetFilesOfInterest = HashSet NormalizedFilePath

40+

41+type instance RuleResult GetFilesOfInterest = Set NormalizedFilePath

42+

3843

3944data GetFilesOfInterest = GetFilesOfInterest

4045 deriving (Eq, Show, Typeable, Generic)

@@ -43,18 +48,16 @@ instance NFData GetFilesOfInterest

4348instance Binary GetFilesOfInterest

4449

4550

46−-- | The rule that initialises the files of interest state.

4751ofInterestRules :: Rules ()

4852ofInterestRules = do

49− addIdeGlobal . OfInterestVar =<< liftIO (newVar HashSet.empty)

53+ addIdeGlobal . OfInterestVar =<< liftIO (newVar Set.empty)

5054 defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do

5155 alwaysRerun

5256 filesOfInterest <- getFilesOfInterestUntracked

5357 pure (Just $ BS.fromString $ show filesOfInterest, ([], Just filesOfInterest))

5458

5559

56−-- | Get the files that are open in the IDE.

57−getFilesOfInterest :: Action (HashSet NormalizedFilePath)

60+getFilesOfInterest :: Action (Set NormalizedFilePath)

5861getFilesOfInterest = useNoFile_ GetFilesOfInterest

5962

6063

@@ -62,21 +65,18 @@ getFilesOfInterest = useNoFile_ GetFilesOfInterest

6265------------------------------------------------------------

6366-- Exposed API

6467

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 ()

68+-- | Set the files-of-interest which will be built and kept-up-to-date.

69+setFilesOfInterest :: IdeState -> Set NormalizedFilePath -> IO ()

6870setFilesOfInterest state files = modifyFilesOfInterest state (const files)

6971

70−getFilesOfInterestUntracked :: Action (HashSet NormalizedFilePath)

72+getFilesOfInterestUntracked :: Action (Set NormalizedFilePath)

7173getFilesOfInterestUntracked = do

7274 OfInterestVar var <- getIdeGlobalAction

7375 liftIO $ readVar var

7476

75−-- | Modify the files-of-interest - not usually necessary or advisable.

76−-- The LSP client will keep this information up to date.

77−modifyFilesOfInterest :: IdeState -> (HashSet NormalizedFilePath -> HashSet NormalizedFilePath) -> IO ()

77+modifyFilesOfInterest :: IdeState -> (Set NormalizedFilePath -> Set NormalizedFilePath) -> IO ()

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 $ HashSet.toList files)

81+ logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ Set.toList files)

8282 void $ shakeRun state []

src/Development/IDE/Core/PositionMapping.hs+10−48

@@ -2,15 +2,10 @@

22-- SPDX-License-Identifier: Apache-2.0

33module Development.IDE.Core.PositionMapping

44 ( PositionMapping(..)

5− , fromCurrentPosition

6− , toCurrentPosition

7− , PositionDelta(..)

8− , addDelta

9− , mkDelta

105 , toCurrentRange

116 , fromCurrentRange

127 , applyChange

13− , zeroMapping

8+ , idMapping

149 -- toCurrent and fromCurrent are mainly exposed for testing

1510 , toCurrent

1611 , fromCurrent

@@ -19,25 +14,12 @@ module Development.IDE.Core.PositionMapping

1914import Control.Monad

2015import qualified Data.Text as T

2116import Language.Haskell.LSP.Types

22−import Data.List

2317

24−-- The position delta is the difference between two versions

25−data PositionDelta = PositionDelta

26− { toDelta :: !(Position -> Maybe Position)

27− , fromDelta :: !(Position -> Maybe Position)

18+data PositionMapping = PositionMapping

19+ { toCurrentPosition :: !(Position -> Maybe Position)

20+ , fromCurrentPosition :: !(Position -> Maybe Position)

2821 }

2922

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−

4123toCurrentRange :: PositionMapping -> Range -> Maybe Range

4224toCurrentRange mapping (Range a b) =

4325 Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b

@@ -46,33 +28,13 @@ fromCurrentRange :: PositionMapping -> Range -> Maybe Range

4628fromCurrentRange mapping (Range a b) =

4729 Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b

4830

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)

31+idMapping :: PositionMapping

32+idMapping = PositionMapping Just Just

7133

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

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

7638 }

7739applyChange posMapping _ = posMapping

7840

src/Development/IDE/Core/Preprocessor.hs+8−104

@@ -8,6 +8,7 @@ module Development.IDE.Core.Preprocessor

88import Development.IDE.GHC.CPP

99import Development.IDE.GHC.Orphans()

1010import Development.IDE.GHC.Compat

11+import GHC

1112import GhcMonad

1213import StringBuffer as SB

1314

@@ -18,26 +19,16 @@ import Data.Char

1819import DynFlags

1920import qualified HeaderInfo as Hdr

2021import Development.IDE.Types.Diagnostics

21−import Development.IDE.Types.Location

2222import Development.IDE.GHC.Error

23−import SysTools (Option (..), runUnlit, runPp)

23+import SysTools (Option (..), runUnlit)

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)

3627

3728

3829-- | Given a file and some contents, apply any necessary preprocessors,

3930-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.

40−preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)

31+preprocessor :: GhcMonad m => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)

4132preprocessor filename mbContents = do

4233 -- Perform unlit

4334 (isOnDisk, contents) <-

@@ -52,79 +43,12 @@ preprocessor filename mbContents = do

5243

5344 -- Perform cpp

5445 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents

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

46+ if not $ xopt LangExt.Cpp dflags then

7647 return (contents, dflags)

7748 else do

78− contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents

49+ contents <- liftIO $ runCpp dflags filename $ if isOnDisk then Nothing else Just contents

7950 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents

8051 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− }

12852

12953

13054isLiterate :: FilePath -> Bool

@@ -133,17 +57,13 @@ isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]

13357

13458-- | This reads the pragma information directly from the provided buffer.

13559parsePragmasIntoDynFlags

136− :: (ExceptionMonad m, HasDynFlags m, MonadIO m)

60+ :: GhcMonad m

13761 => FilePath

13862 -> SB.StringBuffer

13963 -> m (Either [FileDiagnostic] DynFlags)

14064parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do

141− dflags0 <- getDynFlags

65+ dflags0 <- getSessionDynFlags

14266 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−

14767 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts

14868 return dflags

14969

@@ -175,12 +95,11 @@ runLhs dflags filename contents = withTempDir $ \dir -> do

17595 escape (c:cs) = c : escape cs

17696 escape [] = []

17797

98+

17899-- | Run CPP on a file

179100runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer

180101runCpp dflags filename contents = withTempDir $ \dir -> do

181102 let out = dir </> takeFileName filename <.> "out"

182− dflags <- pure $ addOptP "-D__GHCIDE__" dflags

183−

184103 case contents of

185104 Nothing -> do

186105 -- Happy case, file is not modified, so run CPP on it in-place

@@ -213,18 +132,3 @@ runCpp dflags filename contents = withTempDir $ \dir -> do

213132 = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""

214133 | otherwise = x

215134 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+12−51

@@ -15,6 +15,7 @@ import Control.DeepSeq

1515import Data.Binary

1616import Development.IDE.Import.DependencyInformation

1717import Development.IDE.GHC.Util

18+import Development.IDE.Types.Location

1819import Data.Hashable

1920import Data.Typeable

2021import qualified Data.Set as S

@@ -24,9 +25,9 @@ import GHC.Generics (Generic)

2425import GHC

2526import Module (InstalledUnitId)

2627import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)

28+import Development.IDE.GHC.Compat

2729

2830import Development.IDE.Spans.Type

29−import Development.IDE.Import.FindImports (ArtifactsLocation)

3031

3132

3233-- NOTATION

@@ -57,27 +58,11 @@ instance Show TcModuleResult where

5758instance NFData TcModuleResult where

5859 rnf = rwhnf

5960

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−

7661-- | The type checked version of this file, requires TypeCheck+

7762type instance RuleResult TypeCheck = TcModuleResult

7863

7964-- | Information about what spans occur where, requires TypeCheck

80−type instance RuleResult GetSpanInfo = SpansInfo

65+type instance RuleResult GetSpanInfo = [SpanInfo]

8166

8267-- | Convert to Core, requires TypeCheck*

8368type instance RuleResult GenerateCore = (SafeHaskellMode, CgGuts, ModDetails)

@@ -90,24 +75,16 @@ type instance RuleResult GhcSession = HscEnvEq

9075

9176-- | Resolve the imports in a module to the file path of a module

9277-- in the same package or the package id of another package.

93−type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId)

78+type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe NormalizedFilePath)], S.Set InstalledUnitId)

9479

9580-- | This rule is used to report import cycles. It depends on GetDependencyInformation.

9681-- We cannot report the cycles directly from GetDependencyInformation since

9782-- we can only report diagnostics for the current file.

9883type instance RuleResult ReportImportCycles = ()

9984

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

85+-- | Read the given HIE file.

86+type instance RuleResult GetHieFile = HieFile

10587

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

11188

11289data GetParsedModule = GetParsedModule

11390 deriving (Eq, Show, Typeable, Generic)

@@ -169,26 +146,10 @@ instance Hashable GhcSession

169146instance NFData GhcSession

170147instance Binary GhcSession

171148

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

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

191152 deriving (Eq, Show, Typeable, Generic)

192−instance Hashable GetModSummary

193−instance NFData GetModSummary

194−instance Binary GetModSummary

153+instance Hashable GetHieFile

154+instance NFData GetHieFile

155+instance Binary GetHieFile

src/Development/IDE/Core/Rules.hs+123−426

@@ -1,18 +1,16 @@

22-- SPDX-License-Identifier: Apache-2.0

4−{-# LANGUAGE CPP #-}

5−{-# LANGUAGE TypeFamilies #-}

6−{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE FlexibleInstances #-}

76{-# LANGUAGE DuplicateRecordFields #-}

8−#include "ghc-api-version.h"

108-- | A Shake implementation of the compiler service, built

119-- using the "Shaker" abstraction layer for in-memory use.

1210--

1311module Development.IDE.Core.Rules(

1412 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),

15− Priority(..), GhcSessionIO(..), GhcSessionFun(..),

13+ Priority(..),

1614 priorityTypeCheck,

1715 priorityGenerateCore,

1816 priorityFilesOfInterest,

@@ -23,59 +21,51 @@ module Development.IDE.Core.Rules(

2321 getDefinition,

2422 getDependencies,

2523 getParsedModule,

24+ fileFromParsedModule,

2625 generateCore,

2726 ) where

2827

2928import Fingerprint

3029

31−import Data.Binary hiding (get, put)

32−import Data.Bifunctor (first, second)

33−import Control.Monad.Extra

30+import Data.Binary

31+import Control.Monad

3432import Control.Monad.Trans.Class

3533import Control.Monad.Trans.Maybe

3634import Development.IDE.Core.Compile

37−import Development.IDE.Core.OfInterest

3835import Development.IDE.Types.Options

3936import Development.IDE.Spans.Calculate

4037import Development.IDE.Import.DependencyInformation

4138import Development.IDE.Import.FindImports

42−import Development.IDE.Core.FileExists

43−import Development.IDE.Core.FileStore (getFileContents)

39+import Development.IDE.Core.FileStore

4440import Development.IDE.Types.Diagnostics

4541import Development.IDE.Types.Location

46−import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)

4742import Development.IDE.GHC.Util

48−import Development.IDE.GHC.WithDynFlags

43+import Data.Coerce

4944import Data.Either.Extra

5045import Data.Maybe

5146import Data.Foldable

5247import qualified Data.IntMap.Strict as IntMap

53−import Data.IntMap.Strict (IntMap)

48+import qualified Data.IntSet as IntSet

5449import Data.List

55−import Data.Ord

5650import qualified Data.Set as Set

5751import qualified Data.Text as T

5852import Development.IDE.GHC.Error

5953import Development.Shake hiding (Diagnostic)

6054import Development.IDE.Core.RuleTypes

61−import Development.IDE.Spans.Type

62−import qualified Data.ByteString.Char8 as BS

6355

56+import GHC hiding (parseModule, typecheckModule)

6457import qualified GHC.LanguageExtensions as LangExt

58+import Development.IDE.GHC.Compat

59+import UniqSupply

60+import NameCache

6561import HscTypes

66−import PackageConfig

67−import DynFlags (gopt_set, xopt)

62+import DynFlags (xopt)

6863import GHC.Generics(Generic)

6964

7065import qualified Development.IDE.Spans.AtPoint as AtPoint

7166import Development.IDE.Core.Service

7267import Development.IDE.Core.Shake

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

68+import Development.Shake.Classes

7969

8070-- | This is useful for rules to convert rules that can only produce errors or

8171-- a result into the more general IdeResult type that supports producing

@@ -89,14 +79,14 @@ useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v

8979useE k = MaybeT . use k

9080

9181useNoFileE :: IdeRule k v => k -> MaybeT Action v

92−useNoFileE k = useE k emptyFilePath

82+useNoFileE k = useE k ""

9383

9484usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]

9585usesE k = MaybeT . fmap sequence . uses k

9686

9787defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()

9888defineNoFile f = define $ \k file -> do

99− if file == emptyFilePath then do res <- f k; return ([], Just res) else

89+ if file == "" then do res <- f k; return ([], Just res) else

10090 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"

10191

10292

@@ -112,66 +102,19 @@ getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file

112102getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text]))

113103getAtPoint file pos = fmap join $ runMaybeT $ do

114104 opts <- lift getIdeOptions

105+ files <- transitiveModuleDeps <$> useE GetDependencies file

106+ tms <- usesE TypeCheck (file : files)

115107 spans <- useE GetSpanInfo file

116− return $ AtPoint.atPoint opts spans pos

108+ return $ AtPoint.atPoint opts (map tmrModule tms) spans pos

117109

118110-- | Goto Definition.

119111getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)

120112getDefinition file pos = fmap join $ runMaybeT $ do

121− opts <- lift getIdeOptions

122113 spans <- useE GetSpanInfo file

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

114+ pkgState <- hscEnv <$> useE GhcSession file

115+ opts <- lift getIdeOptions

116+ let getHieFile x = useNoFile (GetHieFile x)

117+ lift $ AtPoint.gotoDefinition getHieFile opts pkgState spans pos

175118

176119-- | Parse the contents of a daml file.

177120getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)

@@ -191,60 +134,26 @@ priorityFilesOfInterest :: Priority

191134priorityFilesOfInterest = Priority (-2)

192135

193136getParsedModuleRule :: Rules ()

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))

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)

235145

236146getLocatedImportsRule :: Rules ()

237147getLocatedImportsRule =

238148 define $ \GetLocatedImports file -> do

239− ms <- use_ GetModSummary file

149+ pm <- use_ GetParsedModule file

150+ let ms = pm_mod_summary pm

240151 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]

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

152+ env <- hscEnv <$> use_ GhcSession file

153+ let dflags = addRelativeImport file pm $ hsc_dflags env

245154 opt <- getIdeOptions

246155 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do

247− diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getFileExists modName mbPkgName isSource

156+ diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource

248157 case diagOrImp of

249158 Left diags -> pure (diags, Left (modName, Nothing))

250159 Right (FileImport path) -> pure ([], Left (modName, Just path))

@@ -258,109 +167,48 @@ getLocatedImportsRule =

258167 Nothing -> pure (concat diags, Nothing)

259168 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))

260169

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− )

269170

270171-- | Given a target file path, construct the raw dependency results by following

271172-- imports recursively.

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 })

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)

277178 where

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"

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 })

359207

360208getDependencyInformationRule :: Rules ()

361209getDependencyInformationRule =

362210 define $ \GetDependencyInformation file -> do

363− rawDepInfo <- rawDependencyInformation [file]

211+ rawDepInfo <- rawDependencyInformation file

364212 pure ([], Just $ processDependencyInformation rawDepInfo)

365213

366214reportImportCyclesRule :: Rules ()

@@ -381,20 +229,19 @@ reportImportCyclesRule =

381229 where cycleErrorInFile f (PartOfCycle imp fs)

382230 | f `elem` fs = Just (imp, fs)

383231 cycleErrorInFile _ _ = Nothing

384− toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic

232+ toDiag imp mods = (fp ,) $ Diagnostic

385233 { _range = (_range :: Location -> Range) loc

386234 , _severity = Just DsError

387235 , _source = Just "Import cycle detection"

388236 , _message = "Cyclic module dependency between " <> showCycle mods

389237 , _code = Nothing

390238 , _relatedInformation = Nothing

391− , _tags = Nothing

392239 }

393240 where loc = srcSpanToLocation (getLoc imp)

394− fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp)

241+ fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)

395242 getModuleName file = do

396− ms <- use_ GetModSummary file

397− pure (moduleNameString . moduleName . ms_mod $ ms)

243+ pm <- use_ GetParsedModule file

244+ pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)

398245 showCycle mods = T.intercalate ", " (map T.pack mods)

399246

400247-- returns all transitive dependencies in topological order.

@@ -402,7 +249,7 @@ reportImportCyclesRule =

402249getDependenciesRule :: Rules ()

403250getDependenciesRule =

404251 defineEarlyCutoff $ \GetDependencies file -> do

405− depInfo <- use_ GetDependencyInformation file

252+ depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file

406253 let allFiles = reachableModules depInfo

407254 _ <- uses_ ReportImportCycles allFiles

408255 opts <- getIdeOptions

@@ -414,101 +261,48 @@ getSpanInfoRule :: Rules ()

414261getSpanInfoRule =

415262 define $ \GetSpanInfo file -> do

416263 tc <- use_ TypeCheck file

417− packageState <- hscEnv <$> use_ GhcSession file

418− deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file

419− let tdeps = transitiveModuleDeps deps

420−

421−-- When possible, rely on the haddocks embedded in our interface files

422−-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'

423−#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)

424− let parsedDeps = []

425−#else

426− parsedDeps <- uses_ GetParsedModule tdeps

427−#endif

428−

429− ifaces <- uses_ GetModIface tdeps

430264 (fileImports, _) <- use_ GetLocatedImports file

431− let imports = second (fmap artifactFilePath) <$> fileImports

432− x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps (map hirModIface ifaces)

265+ packageState <- hscEnv <$> use_ GhcSession file

266+ x <- liftIO $ getSrcSpanInfos packageState fileImports tc

433267 return ([], Just x)

434268

435269-- Typechecks a module.

436270typeCheckRule :: Rules ()

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

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

503297 deps <- use_ GetDependencies file

504298 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)

505299 setPriority priorityGenerateCore

506300 packageState <- hscEnv <$> use_ GhcSession file

507− liftIO $ compileModule runSimplifier packageState [(tmrModSummary x, tmrModInfo x) | x <- tms] tm

301+ liftIO $ compileModule packageState tms tm

508302

509303generateCoreRule :: Rules ()

510304generateCoreRule =

511− define $ \GenerateCore -> generateCore (RunSimplifier True)

305+ define $ \GenerateCore -> generateCore

512306

513307generateByteCodeRule :: Rules ()

514308generateByteCodeRule =

@@ -517,7 +311,7 @@ generateByteCodeRule =

517311 (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)

518312 session <- hscEnv <$> use_ GhcSession file

519313 (_, guts, _) <- use_ GenerateCore file

520− liftIO $ generateByteCode session [(tmrModSummary x, tmrModInfo x) | x <- tms] tm guts

314+ liftIO $ generateByteCode session tms tm guts

521315

522316-- A local rule type to get caching. We want to use newCache, but it has

523317-- thread killed exception issues, so we lift it to a full rule.

@@ -529,7 +323,7 @@ instance Hashable GhcSessionIO

529323instance NFData GhcSessionIO

530324instance Binary GhcSessionIO

531325

532−newtype GhcSessionFun = GhcSessionFun (FilePath -> Action (IdeResult HscEnvEq))

326+newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq)

533327instance Show GhcSessionFun where show _ = "GhcSessionFun"

534328instance NFData GhcSessionFun where rnf !_ = ()

535329

@@ -538,119 +332,20 @@ loadGhcSession :: Rules ()

538332loadGhcSession = do

539333 defineNoFile $ \GhcSessionIO -> do

540334 opts <- getIdeOptions

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

335+ liftIO $ GhcSessionFun <$> optGhcSession opts

546336 defineEarlyCutoff $ \GhcSession file -> do

547337 GhcSessionFun fun <- useNoFile_ GhcSessionIO

548− alwaysRerun

549338 val <- fun $ fromNormalizedFilePath file

550−

551− -- TODO: What was this doing before?

552339 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)

340+ return ("" <$ optShakeFiles opts, ([], Just val))

648341

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))

342+

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

654349

655350-- | A rule that wires per-file rules together

656351mainRule :: Rules ()

@@ -665,7 +360,9 @@ mainRule = do

665360 generateCoreRule

666361 generateByteCodeRule

667362 loadGhcSession

668− getHiFileRule

669− getModIfaceRule

670− isFileOfInterestRule

671− getModSummaryRule

363+ getHieFileRule

364+

365+------------------------------------------------------------

366+

367+fileFromParsedModule :: ParsedModule -> NormalizedFilePath

368+fileFromParsedModule = toNormalizedFilePath . ms_hspp_file . pm_mod_summary

src/Development/IDE/Core/Service.hs+3−10

@@ -23,16 +23,13 @@ import Control.Concurrent.Async

2323import Data.Maybe

2424import Development.IDE.Types.Options (IdeOptions(..))

2525import Control.Monad

26−import Development.IDE.Core.Debouncer

27−import Development.IDE.Core.FileStore (VFSHandle, fileStoreRules)

28−import Development.IDE.Core.FileExists (fileExistsRules)

26+import Development.IDE.Core.FileStore

2927import Development.IDE.Core.OfInterest

3028import Development.IDE.Types.Logger

3129import Development.Shake

3230import Data.Either.Extra

3331import qualified Language.Haskell.LSP.Messages as LSP

3432import qualified Language.Haskell.LSP.Types as LSP

35−import qualified Language.Haskell.LSP.Types.Capabilities as LSP

3633

3734import Development.IDE.Core.Shake

3835

@@ -45,21 +42,18 @@ instance IsIdeGlobal GlobalIdeOptions

4542-- Exposed API

4643

4744-- | Initialise the Compiler Service.

48−initialise :: LSP.ClientCapabilities

49− -> Rules ()

45+initialise :: Rules ()

5046 -> IO LSP.LspId

5147 -> (LSP.FromServerMessage -> IO ())

5248 -> Logger

53− -> Debouncer LSP.NormalizedUri

5449 -> IdeOptions

5550 -> VFSHandle

5651 -> IO IdeState

57−initialise caps mainRule getLspId toDiags logger debouncer options vfs =

52+initialise mainRule getLspId toDiags logger options vfs =

5853 shakeOpen

5954 getLspId

6055 toDiags

6156 logger

62− debouncer

6357 (optShakeProfiling options)

6458 (optReportProgress options)

6559 shakeOptions

@@ -69,7 +63,6 @@ initialise caps mainRule getLspId toDiags logger debouncer options vfs =

6963 addIdeGlobal $ GlobalIdeOptions options

7064 fileStoreRules vfs

7165 ofInterestRules

72− fileExistsRules getLspId caps vfs

7366 mainRule

7467

7568writeProfile :: IdeState -> FilePath -> IO ()

src/Development/IDE/Core/Shake.hs+152−214

@@ -19,28 +19,25 @@

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, shakeExtras,

23− ShakeExtras(..), getShakeExtras, getShakeExtrasRules,

22+ IdeState,

2423 IdeRule, IdeResult, GetModificationTime(..),

2524 shakeOpen, shakeShut,

2625 shakeRun,

2726 shakeProfile,

2827 use, useWithStale, useNoFile, uses, usesWithStale,

2928 use_, useNoFile_, uses_,

30− define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,

29+ define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks, fingerprintToBS,

3130 getDiagnostics, unsafeClearDiagnostics,

32− getHiddenDiagnostics,

33− IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,

31+ IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,

3432 garbageCollect,

3533 setPriority,

3634 sendEvent,

3735 ideLogger,

3836 actionLogger,

39− FileVersion(..), modificationTime,

37+ FileVersion(..),

4038 Priority(..),

4139 updatePositionMapping,

42− deleteValue,

43− OnDiskRule(..),

40+ OnDiskRule(..)

4441 ) where

4542

4643import Development.Shake hiding (ShakeValue, doesFileExist)

@@ -49,27 +46,30 @@ import Development.Shake.Classes

4946import Development.Shake.Rule

5047import qualified Data.HashMap.Strict as HMap

5148import qualified Data.Map.Strict as Map

49+import qualified Data.Map.Merge.Strict as Map

5250import qualified Data.ByteString.Char8 as BS

51+import qualified Data.ByteString.Internal as BS

5352import Data.Dynamic

5453import Data.Maybe

5554import Data.Map.Strict (Map)

56−import Data.List.Extra (partition, takeEnd)

55+import Data.List.Extra

5756import qualified Data.Set as Set

5857import qualified Data.Text as T

59−import Data.Traversable (for)

6058import Data.Tuple.Extra

6159import Data.Unique

6260import Development.IDE.Core.Debouncer

6361import Development.IDE.Core.PositionMapping

6462import Development.IDE.Types.Logger hiding (Priority)

63+import Foreign.Ptr

64+import Foreign.Storable

65+import GHC.Fingerprint

6566import Language.Haskell.LSP.Diagnostics

6667import qualified Data.SortedList as SL

6768import Development.IDE.Types.Diagnostics

6869import Development.IDE.Types.Location

6970import Development.IDE.Types.Options

70−import Control.Concurrent.Async

7171import Control.Concurrent.Extra

72−import Control.Exception.Extra

72+import Control.Exception

7373import Control.DeepSeq

7474import System.Time.Extra

7575import Data.Typeable

@@ -93,17 +93,12 @@ data ShakeExtras = ShakeExtras

9393 ,globals :: Var (HMap.HashMap TypeRep Dynamic)

9494 ,state :: Var Values

9595 ,diagnostics :: Var DiagnosticStore

96− ,hiddenDiagnostics :: Var DiagnosticStore

97− ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])

96+ ,publishedDiagnostics :: Var (Map NormalizedUri [Diagnostic])

9897 -- ^ This represents the set of diagnostics that we have published.

9998 -- Due to debouncing not every change might get published.

100− ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))

99+ ,positionMapping :: Var (Map NormalizedUri (Map TextDocumentVersion PositionMapping))

101100 -- ^ Map from a text document version to a PositionMapping that describes how to map

102101 -- 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

107102 }

108103

109104getShakeExtras :: Action ShakeExtras

@@ -116,29 +111,22 @@ getShakeExtrasRules = do

116111 Just x <- getShakeExtraRules @ShakeExtras

117112 return x

118113

114+

115+

119116class Typeable a => IsIdeGlobal a where

120117

121118addIdeGlobal :: IsIdeGlobal a => a -> Rules ()

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) =

119+addIdeGlobal x@(typeOf -> ty) = do

120+ ShakeExtras{globals} <- getShakeExtrasRules

128121 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of

129− Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty

122+ Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty

130123 Nothing -> return $! HMap.insert ty (toDyn x) mp

131124

132125

133126getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a

134127getIdeGlobalExtras ShakeExtras{globals} = do

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

128+ Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals

129+ return $ fromDyn x $ error "Serious error, corrupt globals"

142130

143131getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a

144132getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras

@@ -161,7 +149,7 @@ instance Eq Key where

161149 | otherwise = False

162150

163151instance Hashable Key where

164− hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)

152+ hashWithSalt salt (Key key) = hashWithSalt salt key

165153

166154-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,

167155-- and a value is in the Maybe. For operations that throw an error you

@@ -171,6 +159,9 @@ instance Hashable Key where

171159-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh

172160-- errors but still failed.

173161--

162+-- A rule on a file should only return diagnostics for that given file. It should

163+-- not propagate diagnostic errors through multiple phases.

164+type IdeResult v = ([FileDiagnostic], Maybe v)

174165

175166data Value v

176167 = Succeeded TextDocumentVersion v

@@ -205,14 +196,14 @@ valueVersion = \case

205196 Failed -> Nothing

206197

207198mappingForVersion

208− :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))

199+ :: Map NormalizedUri (Map TextDocumentVersion PositionMapping)

209200 -> NormalizedFilePath

210201 -> TextDocumentVersion

211202 -> PositionMapping

212203mappingForVersion allMappings file ver =

213− maybe zeroMapping snd $

204+ fromMaybe idMapping $

214205 Map.lookup ver =<<

215− HMap.lookup (filePathToUri' file) allMappings

206+ Map.lookup (filePathToUri' file) allMappings

216207

217208type IdeRule k v =

218209 ( Shake.RuleResult k ~ v

@@ -234,15 +225,15 @@ data IdeState = IdeState

234225

235226

236227-- This is debugging code that generates a series of profiles, if the Boolean is true

237−shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO ([a], Maybe FilePath)

228+shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO [a]

238229shakeRunDatabaseProfile mbProfileDir shakeDb acts = do

239230 (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts

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)

231+ whenJust mbProfileDir $ \dir -> do

232+ count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)

233+ let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"

234+ shakeProfileDatabase shakeDb $ dir </> file

235+ return res

236+ where

246237

247238{-# NOINLINE profileStartTime #-}

248239profileStartTime :: String

@@ -262,16 +253,6 @@ setValues state key file val = modifyVar_ state $ \vals -> do

262253 -- Force to make sure the old HashMap is not retained

263254 evaluate $ HMap.insert (file, Key key) (fmap toDyn val) vals

264255

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−

275256-- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.

276257getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))

277258getValues state key file = do

@@ -298,40 +279,33 @@ seqValue v b = case v of

298279shakeOpen :: IO LSP.LspId

299280 -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler

300281 -> Logger

301− -> Debouncer NormalizedUri

302282 -> Maybe FilePath

303283 -> IdeReportProgress

304284 -> ShakeOptions

305285 -> Rules ()

306286 -> IO IdeState

307−shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) opts rules = do

308− inProgress <- newVar HMap.empty

287+shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do

309288 shakeExtras <- do

310289 globals <- newVar HMap.empty

311290 state <- newVar HMap.empty

312291 diagnostics <- newVar mempty

313− hiddenDiagnostics <- newVar mempty

314292 publishedDiagnostics <- newVar mempty

315− positionMapping <- newVar HMap.empty

293+ debouncer <- newDebouncer

294+ positionMapping <- newVar Map.empty

316295 pure ShakeExtras{..}

317296 (shakeDb, shakeClose) <-

318297 shakeOpenDatabase

319298 opts

320299 { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts

321− -- we don't actually use the progress value, but Shake conveniently spawns/kills this thread whenever

322− -- we call into Shake, so abuse it for that purpose

323− , shakeProgress = const $ if reportProgress then lspShakeProgress getLspId eventer inProgress else pure ()

300+ , shakeProgress = if reportProgress then lspShakeProgress getLspId eventer else const (pure ())

324301 }

325302 rules

326303 shakeAbort <- newMVar $ return ()

327304 shakeDb <- shakeDb

328305 return IdeState{..}

329306

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

307+lspShakeProgress :: IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> IO Progress -> IO ()

308+lspShakeProgress getLspId sendMsg prog = do

335309 lspId <- getLspId

336310 u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique

337311 sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest

@@ -359,9 +333,9 @@ lspShakeProgress getLspId sendMsg inProgress = do

359333 sample = 0.1

360334 loop id prev = do

361335 sleep sample

362− current <- readVar inProgress

363− let done = length $ filter (== 0) $ HMap.elems current

364− let todo = HMap.size current

336+ p <- prog

337+ let done = countSkipped p + countBuilt p

338+ let todo = done + countUnknown p + countTodo p

365339 let next = Just $ T.pack $ show done <> "/" <> show todo

366340 when (next /= prev) $

367341 sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification

@@ -387,11 +361,11 @@ shakeShut IdeState{..} = withMVar shakeAbort $ \stop -> do

387361

388362-- | This is a variant of withMVar where the first argument is run unmasked and if it throws

389363-- an exception, the previous value is restored while the second argument is executed masked.

390−withMVar' :: MVar a -> (a -> IO ()) -> IO (a, c) -> IO c

364+withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c

391365withMVar' var unmasked masked = mask $ \restore -> do

392366 a <- takeMVar var

393− restore (unmasked a) `onException` putMVar var a

394− (a', c) <- masked

367+ b <- restore (unmasked a) `onException` putMVar var a

368+ (a', c) <- masked b

395369 putMVar var a'

396370 pure c

397371

@@ -403,44 +377,29 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =

403377 (\stop -> do

404378 (stopTime,_) <- duration stop

405379 logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"

406− )

380+ bar <- newBarrier

381+ start <- offsetTime

382+ pure (start, bar))

407383 -- It is crucial to be masked here, otherwise we can get killed

408384 -- between spawning the new thread and updating shakeAbort.

409385 -- See https://github.com/digital-asset/ghcide/issues/79

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))

386+ (\(start, bar) -> do

387+ thread <- forkFinally (shakeRunDatabaseProfile shakeProfileDir shakeDb acts) $ \res -> do

388+ runTime <- start

389+ let res' = case res of

390+ Left e -> "exception: " <> displayException e

391+ Right _ -> "completed"

392+ logDebug logger $ T.pack $

393+ "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ ")"

394+ signalBarrier bar res

395+ -- important: we send an async exception to the thread, then wait for it to die, before continuing

396+ pure (killThread thread >> void (waitBarrier bar), either throwIO return =<< waitBarrier bar))

433397

434398getDiagnostics :: IdeState -> IO [FileDiagnostic]

435399getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do

436400 val <- readVar diagnostics

437401 return $ getAllDiagnostics val

438402

439−getHiddenDiagnostics :: IdeState -> IO [FileDiagnostic]

440−getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do

441− val <- readVar hiddenDiagnostics

442− return $ getAllDiagnostics val

443−

444403-- | FIXME: This function is temporary! Only required because the files of interest doesn't work

445404unsafeClearDiagnostics :: IdeState -> IO ()

446405unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =

@@ -449,16 +408,15 @@ unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =

449408-- | Clear the results for all files that do not match the given predicate.

450409garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()

451410garbageCollect keep = do

452− ShakeExtras{state, diagnostics,hiddenDiagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras

411+ ShakeExtras{state, diagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras

453412 liftIO $

454413 do newState <- modifyVar state $ \values -> do

455414 values <- evaluate $ HMap.filterWithKey (\(file, _) _ -> keep file) values

456415 return $! dupe values

457416 modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags

458− modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags

459− modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags

417+ modifyVar_ publishedDiagnostics $ \diags -> return $! Map.filterWithKey (\uri _ -> keep (fromUri uri)) diags

460418 let versionsForFile =

461− HMap.fromListWith Set.union $

419+ Map.fromListWith Set.union $

462420 mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $

463421 HMap.toList newState

464422 modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings

@@ -476,25 +434,25 @@ useWithStale :: IdeRule k v

476434useWithStale key file = head <$> usesWithStale key [file]

477435

478436useNoFile :: IdeRule k v => k -> Action (Maybe v)

479−useNoFile key = use key emptyFilePath

437+useNoFile key = use key ""

480438

481439use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v

482440use_ key file = head <$> uses_ key [file]

483441

484442useNoFile_ :: IdeRule k v => k -> Action v

485−useNoFile_ key = use_ key emptyFilePath

443+useNoFile_ key = use_ key ""

486444

487445uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]

488446uses_ key files = do

489447 res <- uses key files

490448 case sequence res of

491− Nothing -> liftIO $ throwIO $ BadDependency (show key)

449+ Nothing -> liftIO $ throwIO BadDependency

492450 Just v -> return v

493451

494452

495453-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency

496454-- which short-circuits the rest of the action

497−data BadDependency = BadDependency String deriving Show

455+data BadDependency = BadDependency deriving Show

498456instance Exception BadDependency

499457

500458isBadDependency :: SomeException -> Bool

@@ -513,10 +471,12 @@ instance Show k => Show (Q k) where

513471

514472-- | Invariant: the 'v' must be in normal form (fully evaluated).

515473-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database

516−newtype A v = A (Value v)

474+-- Note (MK) I am not sure why we need the ShakeValue here, maybe we

475+-- can just remove it?

476+data A v = A (Value v) ShakeValue

517477 deriving Show

518478

519−instance NFData (A v) where rnf (A v) = v `seq` ()

479+instance NFData (A v) where rnf (A v x) = v `seq` rnf x

520480

521481-- In the Shake database we only store one type of key/result pairs,

522482-- namely Q (question) / A (answer).

@@ -526,70 +486,59 @@ type instance RuleResult (Q k) = A (RuleResult k)

526486-- | Return up2date results. Stale results will be ignored.

527487uses :: IdeRule k v

528488 => k -> [NormalizedFilePath] -> Action [Maybe v]

529−uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files)

489+uses key files = map (\(A value _) -> currentValue value) <$> apply (map (Q . (key,)) files)

530490

531491-- | Return the last computed result which might be stale.

532492usesWithStale :: IdeRule k v

533493 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]

534494usesWithStale key files = do

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−

495+ values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)

496+ mapM (uncurry lastValue) (zip files values)

546497

547498defineEarlyCutoff

548499 :: IdeRule k v

549500 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))

550501 -> Rules ()

551502defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do

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

503+ extras@ShakeExtras{state} <- getShakeExtras

504+ val <- case old of

505+ Just old | mode == RunDependenciesSame -> do

506+ v <- liftIO $ getValues state key file

507+ case v of

508+ -- No changes in the dependencies and we have

509+ -- an existing result.

510+ Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)

511+ _ -> return Nothing

512+ _ -> return Nothing

513+ case val of

514+ Just res -> return res

515+ Nothing -> do

516+ (bs, (diags, res)) <- actionCatch

517+ (do v <- op key file; liftIO $ evaluate $ force $ v) $

518+ \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))

519+ modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file

520+ (bs, res) <- case res of

521+ Nothing -> do

522+ staleV <- liftIO $ getValues state key file

523+ pure $ case staleV of

524+ Nothing -> (toShakeValue ShakeResult bs, Failed)

525+ Just v -> case v of

526+ Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)

527+ Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)

528+ Failed -> (toShakeValue ShakeResult bs, Failed)

529+ Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)

530+ liftIO $ setValues state key file res

531+ updateFileDiagnostics file (Key key) extras $ map snd diags

532+ let eq = case (bs, fmap decodeShakeValue old) of

533+ (ShakeResult a, Just (ShakeResult b)) -> a == b

534+ (ShakeStale a, Just (ShakeStale b)) -> a == b

535+ -- If we do not have a previous result

536+ -- or we got ShakeNoCutoff we always return False.

537+ _ -> False

538+ return $ RunResult

539+ (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)

540+ (encodeShakeValue bs) $

541+ A res bs

593542

594543

595544-- | Rule type, input file

@@ -640,7 +589,7 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $

640589 case mbOld of

641590 Nothing -> do

642591 (diags, mbHash) <- runAct

643− updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags

592+ updateFileDiagnostics file (Key key) extras $ map snd diags

644593 pure $ RunResult ChangedRecomputeDiff (fromMaybe "" mbHash) (isJust mbHash)

645594 Just old -> do

646595 current <- validateHash <$> (actionCatch getHash $ \(_ :: SomeException) -> pure "")

@@ -651,21 +600,27 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $

651600 pure $ RunResult ChangedNothing (fromMaybe "" current) (isJust current)

652601 else do

653602 (diags, mbHash) <- runAct

654− updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags

603+ updateFileDiagnostics file (Key key) extras $ map snd diags

655604 let change

656605 | mbHash == Just old = ChangedRecomputeSame

657606 | otherwise = ChangedRecomputeDiff

658607 pure $ RunResult change (fromMaybe "" mbHash) (isJust mbHash)

659608

609+fingerprintToBS :: Fingerprint -> BS.ByteString

610+fingerprintToBS (Fingerprint a b) = BS.unsafeCreate 8 $ \ptr -> do

611+ ptr <- pure $ castPtr ptr

612+ pokeElemOff ptr 0 a

613+ pokeElemOff ptr 1 b

614+

660615needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()

661616needOnDisk k file = do

662617 successfull <- apply1 (QDisk k file)

663− liftIO $ unless successfull $ throwIO $ BadDependency (show k)

618+ liftIO $ unless successfull $ throwIO BadDependency

664619

665620needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()

666621needOnDisks k files = do

667622 successfulls <- apply $ map (QDisk k) files

668− liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k)

623+ liftIO $ unless (and successfulls) $ throwIO BadDependency

669624

670625toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue

671626toShakeValue = maybe ShakeNoCutoff

@@ -701,38 +656,29 @@ updateFileDiagnostics ::

701656 NormalizedFilePath

702657 -> Key

703658 -> ShakeExtras

704− -> [(ShowDiagnostic,Diagnostic)] -- ^ current results

659+ -> [Diagnostic] -- ^ current results

705660 -> Action ()

706−updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do

707− modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp

708− let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current

661+updateFileDiagnostics fp k ShakeExtras{diagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do

662+ modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp

709663 mask_ $ do

710664 -- Mask async exceptions to ensure that updated diagnostics are always

711665 -- published. Otherwise, we might never publish certain diagnostics if

712666 -- an exception strikes between modifyVar but before

713667 -- publishDiagnosticsNotification.

714668 newDiags <- modifyVar diagnostics $ \old -> do

715− let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)

716− (T.pack $ show k) (map snd currentShown) old

669+ let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime) (T.pack $ show k) current old

717670 let newDiags = getFileDiagnostics fp newDiagsStore

718671 _ <- evaluate newDiagsStore

719672 _ <- evaluate newDiags

720− pure (newDiagsStore, newDiags)

721− modifyVar_ hiddenDiagnostics $ \old -> do

722− let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)

723− (T.pack $ show k) (map snd currentHidden) old

724− let newDiags = getFileDiagnostics fp newDiagsStore

725− _ <- evaluate newDiagsStore

726− _ <- evaluate newDiags

727− return newDiagsStore

673+ pure $! (newDiagsStore, newDiags)

728674 let uri = filePathToUri' fp

729675 let delay = if null newDiags then 0.1 else 0

730676 registerEvent debouncer delay uri $ do

731677 mask_ $ modifyVar_ publishedDiagnostics $ \published -> do

732− let lastPublish = HMap.lookupDefault [] uri published

678+ let lastPublish = Map.findWithDefault [] uri published

733679 when (lastPublish /= newDiags) $

734680 eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags

735− pure $! HMap.insert uri newDiags published

681+ pure $! Map.insert uri newDiags published

736682

737683publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage

738684publishDiagnosticsNotification uri diags =

@@ -743,7 +689,7 @@ publishDiagnosticsNotification uri diags =

743689newtype Priority = Priority Double

744690

745691setPriority :: Priority -> Action ()

746−setPriority (Priority p) = reschedule p

692+setPriority (Priority p) = deprioritize p

747693

748694sendEvent :: LSP.FromServerMessage -> Action ()

749695sendEvent e = do

@@ -768,22 +714,19 @@ instance Binary GetModificationTime

768714-- | Get the modification time of a file.

769715type instance RuleResult GetModificationTime = FileVersion

770716

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)

717+-- | We store the modification time as a ByteString since we need

718+-- a ByteString anyway for Shake and we do not care about how times

719+-- are represented.

720+data FileVersion = VFSVersion Int | ModificationTime BS.ByteString

776721 deriving (Show, Generic)

777722

778723instance NFData FileVersion

779724

780725vfsVersion :: FileVersion -> Maybe Int

781726vfsVersion (VFSVersion i) = Just i

782−vfsVersion ModificationTime{} = Nothing

727+vfsVersion (ModificationTime _) = Nothing

728+

783729

784−modificationTime :: FileVersion -> Maybe (Int, Int)

785−modificationTime VFSVersion{} = Nothing

786−modificationTime (ModificationTime large small) = Just (large, small)

787730

788731getDiagnosticsFromStore :: StoreItem -> [Diagnostic]

789732getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags

@@ -808,7 +751,7 @@ getAllDiagnostics ::

808751 DiagnosticStore ->

809752 [FileDiagnostic]

810753getAllDiagnostics =

811− concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList

754+ concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList

812755

813756getFileDiagnostics ::

814757 NormalizedFilePath ->

@@ -816,34 +759,29 @@ getFileDiagnostics ::

816759 [LSP.Diagnostic]

817760getFileDiagnostics fp ds =

818761 maybe [] getDiagnosticsFromStore $

819− HMap.lookup (filePathToUri' fp) ds

762+ Map.lookup (filePathToUri' fp) ds

820763

821764filterDiagnostics ::

822765 (NormalizedFilePath -> Bool) ->

823766 DiagnosticStore ->

824767 DiagnosticStore

825768filterDiagnostics keep =

826− HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri)

769+ Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)

827770

828771filterVersionMap

829− :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)

830− -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)

831− -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)

772+ :: Map NormalizedUri (Set.Set TextDocumentVersion)

773+ -> Map NormalizedUri (Map TextDocumentVersion a)

774+ -> Map NormalizedUri (Map TextDocumentVersion a)

832775filterVersionMap =

833− HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep

776+ Map.merge Map.dropMissing Map.dropMissing $

777+ Map.zipWithMatched $ \_ versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep

834778

835779updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()

836−updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do

780+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do

837781 modifyVar_ positionMapping $ \allMappings -> do

838782 let uri = toNormalizedUri _uri

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

783+ let mappingForUri = Map.findWithDefault Map.empty uri allMappings

784+ let updatedMapping =

785+ Map.insert _version idMapping $

786+ Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri

787+ pure $! Map.insert uri updatedMapping allMappings

src/Development/IDE/GHC/CPP.hs+3−34

@@ -19,8 +19,7 @@

1919--

2020-----------------------------------------------------------------------------

2121

22−module Development.IDE.GHC.CPP(doCpp, addOptP)

23−where

22+module Development.IDE.GHC.CPP(doCpp) where

2423

2524import Development.IDE.GHC.Compat

2625import Packages

@@ -29,15 +28,9 @@ import Module

2928import DynFlags

3029import Panic

3130import FileCleanup

32−#if MIN_GHC_API_VERSION(8,8,2)

33−import LlvmCodeGen (llvmVersionList)

34−#elif MIN_GHC_API_VERSION(8,8,0)

31+#if MIN_GHC_API_VERSION(8,8,0)

3532import LlvmCodeGen (LlvmVersion (..))

3633#endif

37−#if MIN_GHC_API_VERSION (8,10,0)

38−import Fingerprint

39−import ToolSettings

40−#endif

4134

4235import System.Directory

4336import System.FilePath

@@ -64,11 +57,7 @@ doCpp dflags raw input_fn output_fn = do

6457 let verbFlags = getVerbFlags dflags

6558

6659 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

7060 | otherwise = SysTools.runCc

71−#endif

7261 dflags (SysTools.Option "-E" : args)

7362

7463 let target_defs =

@@ -148,11 +137,7 @@ getBackendDefs :: DynFlags -> IO [String]

148137getBackendDefs dflags | hscTarget dflags == HscLlvm = do

149138 llvmVer <- figureLlvmVersion dflags

150139 return $ case llvmVer of

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)

140+#if MIN_GHC_API_VERSION(8,8,0)

156141 Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]

157142 Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]

158143#else

@@ -167,22 +152,6 @@ getBackendDefs dflags | hscTarget dflags == HscLlvm = do

167152getBackendDefs _ =

168153 return []

169154

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−

186155-- ---------------------------------------------------------------------------

187156-- Macros (cribbed from Cabal)

188157

src/Development/IDE/GHC/Compat.hs+27−251

@@ -2,106 +2,62 @@

22-- SPDX-License-Identifier: Apache-2.0

44{-# LANGUAGE CPP #-}

5−{-# LANGUAGE PatternSynonyms #-}

65#include "ghc-api-version.h"

87-- | Attempt at hiding the GHC version differences we can.

98module Development.IDE.GHC.Compat(

10− getHeaderImports,

119 HieFileResult(..),

12− HieFile,

13− hieExportNames,

14− hie_module,

10+ HieFile(..),

1511 mkHieFile,

1612 writeHieFile,

1713 readHieFile,

18− supportsHieFiles,

19− setDefaultHieDir,

20− dontWriteHieFiles,

21−#if !MIN_GHC_API_VERSION(8,8,0)

22− ml_hie_file,

23−#endif

2414 hPutStringBuffer,

2515 includePathsGlobal,

2616 includePathsQuote,

2717 addIncludePathsQuote,

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

18+ ghcEnumerateExtensions

4419 ) where

4520

4621import StringBuffer

4722import DynFlags

48−import FieldLabel

49−import Fingerprint (Fingerprint)

50−import qualified Module

51−import Packages

52−

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)

23+import GHC.LanguageExtensions.Type

6424

65−#if MIN_GHC_API_VERSION(8,10,0)

66−import HscTypes (mi_mod_hash)

25+#if MIN_GHC_API_VERSION(8,8,0)

26+import Data.List.Extra (enumerate)

6727#endif

6828

6929#if MIN_GHC_API_VERSION(8,8,0)

70−import Control.Applicative ((<|>))

71−import Development.IDE.GHC.HieAst (mkHieFile)

30+import HieAst

7231import HieBin

7332import HieTypes

74−

75−supportsHieFiles :: Bool

76−supportsHieFiles = True

77−

78−hieExportNames :: HieFile -> [(SrcSpan, Name)]

79−hieExportNames = nameListFromAvails . hie_exports

80−

8133#else

82−

83−#if MIN_GHC_API_VERSION(8,6,0)

84−import BinIface

85−import Data.IORef

86−import IfaceEnv

87−#endif

88−

89−import Binary

90−import Control.Exception (catch)

91−import Data.ByteString (ByteString)

92−import GhcPlugins hiding (ModLocation)

34+import GHC

35+import GhcPlugins

9336import NameCache

37+import Avail

9438import TcRnTypes

9539import System.IO

9640import Foreign.ForeignPtr

97−import MkIface

9841

9942

43+#if !MIN_GHC_API_VERSION(8,8,0)

10044hPutStringBuffer :: Handle -> StringBuffer -> IO ()

10145hPutStringBuffer hdl (StringBuffer buf len cur)

10246 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->

10347 hPutBuf hdl ptr len

48+#endif

10449

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 }

10561#endif

10662

10763#if !MIN_GHC_API_VERSION(8,6,0)

@@ -119,191 +75,11 @@ addIncludePathsQuote path x = x{includePaths = f $ includePaths x}

11975addIncludePathsQuote path x = x{includePaths = path : includePaths x}

12076#endif

12177

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 <-

78+ghcEnumerateExtensions :: [Extension]

18079#if MIN_GHC_API_VERSION(8,8,0)

181− GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c ""

80+ghcEnumerateExtensions = enumerate

81+#elif MIN_GHC_API_VERSION(8,6,0)

82+ghcEnumerateExtensions = [Cpp .. StarIsType]

18283#else

183− GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c

84+ghcEnumerateExtensions = [Cpp .. EmptyDataDeriving]

18485#endif

185−

186−pattern IEThingAll :: LIEWrappedName (IdP pass) -> IE pass

187−pattern IEThingAll a <-

188−#if MIN_GHC_API_VERSION(8,6,0)

189− GHC.IEThingAll _ a

190−#else

191− GHC.IEThingAll a

192−#endif

193−

194−setDefaultHieDir :: FilePath -> DynFlags -> DynFlags

195−setDefaultHieDir _f d =

196−#if MIN_GHC_API_VERSION(8,8,0)

197− d { hieDir = hieDir d <|> Just _f}

198−#else

199− d

200−#endif

201−

202−dontWriteHieFiles :: DynFlags -> DynFlags

203−dontWriteHieFiles d =

204−#if MIN_GHC_API_VERSION(8,8,0)

205− gopt_unset d Opt_WriteHie

206−#else

207− d

208−#endif

209−

210−nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)]

211−nameListFromAvails as =

212− map (\n -> (nameSrcSpan n, n)) (concatMap availNames as)

213−

214−#if !MIN_GHC_API_VERSION(8,8,0)

215−-- Reimplementations of functions for HIE files for GHC 8.6

216−

217−mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> ByteString -> Hsc HieFile

218−mkHieFile ms ts _ _ = return (HieFile (ms_mod ms) es)

219− where

220− es = nameListFromAvails (mkIfaceExports (tcg_exports ts))

221−

222−ml_hie_file :: GHC.ModLocation -> FilePath

223−ml_hie_file ml = ml_hi_file ml ++ ".hie"

224−

225−data HieFile = HieFile {hie_module :: Module, hie_exports :: [(SrcSpan, Name)]}

226−

227−hieExportNames :: HieFile -> [(SrcSpan, Name)]

228−hieExportNames = hie_exports

229−

230−instance Binary HieFile where

231− put_ bh (HieFile m es) = do

232− put_ bh m

233− put_ bh es

234−

235− get bh = do

236− mod <- get bh

237− es <- get bh

238− return (HieFile mod es)

239−

240−data HieFileResult = HieFileResult { hie_file_result :: HieFile }

241−

242−writeHieFile :: FilePath -> HieFile -> IO ()

243−readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())

244−supportsHieFiles :: Bool

245−

246−#if MIN_GHC_API_VERSION(8,6,0)

247−

248−writeHieFile fp hie = do

249− bh <- openBinMem (1024 * 1024)

250− putWithUserData (const $ return ()) bh hie

251− writeBinMem bh fp

252−

253−readHieFile nc fp = do

254− bh <- readBinMem fp

255− nc' <- newIORef nc

256− hie_file <- getWithUserData (NCU (atomicModifyIORef' nc')) bh

257− return (HieFileResult hie_file, ())

258−

259−supportsHieFiles = True

260−

261−#else

262−

263−supportsHieFiles = False

264−

265−writeHieFile _ _ = return ()

266−

267−readHieFile _ _ = return undefined

268−

269−#endif

270−

271−#endif

272−

273−getHeaderImports

274− :: DynFlags

275− -> StringBuffer

276− -> FilePath

277− -> FilePath

278− -> IO

279− ( Either

280− ErrorMessages

281− ( [(Maybe FastString, Located ModuleName)]

282− , [(Maybe FastString, Located ModuleName)]

283− , Located ModuleName

284− )

285− )

286−#if MIN_GHC_API_VERSION(8,8,0)

287−getHeaderImports = Hdr.getImports

288−#else

289−getHeaderImports a b c d =

290− catch (Right <$> Hdr.getImports a b c d)

291− (return . Left . srcErrorMessages)

292−#endif

293−

294−getModuleHash :: ModIface -> Fingerprint

295−#if MIN_GHC_API_VERSION(8,10,0)

296−getModuleHash = mi_mod_hash . mi_final_exts

297−#else

298−getModuleHash = mi_mod_hash

299−#endif

300−

301−getConArgs :: ConDecl pass -> HsConDeclDetails pass

302−#if MIN_GHC_API_VERSION(8,6,0)

303−getConArgs = GHC.getConArgs

304−#else

305−getConArgs = GHC.getConDetails

306−#endif

307−

308−getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName

309−getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i))

src/Development/IDE/GHC/Error.hs+4−37

@@ -9,19 +9,12 @@ module Development.IDE.GHC.Error

99 , diagFromStrings

1010 , diagFromGhcException

1111 , catchSrcErrors

12− , mergeDiagnostics

1312

1413 -- * utilities working with spans

1514 , srcSpanToLocation

16− , srcSpanToRange

1715 , srcSpanToFilename

1816 , zeroSpan

1917 , realSpan

20− , isInsideSrcSpan

21− , noSpan

22−

23− -- * utilities working with severities

24− , toDSeverity

2518 ) where

2619

2720import Development.IDE.Types.Diagnostics as D

@@ -37,12 +30,11 @@ import Panic

3730import ErrUtils

3831import SrcLoc

3932import qualified Outputable as Out

40−import Exception (ExceptionMonad)

4133

4234

4335

4436diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic

45−diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename loc,ShowDiag,)

37+diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,)

4638 Diagnostic

4739 { _range = srcSpanToRange loc

4840 , _severity = Just sev

@@ -50,39 +42,18 @@ diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename

5042 , _message = msg

5143 , _code = Nothing

5244 , _relatedInformation = Nothing

53− , _tags = Nothing

5445 }

5546

5647-- | Produce a GHC-style error from a source span and a message.

5748diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]

5849diagFromErrMsg diagSource dflags e =

59− [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $

60− ErrUtils.formatErrDoc dflags $ ErrUtils.errMsgDoc e

50+ [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $ ErrUtils.pprLocErrMsg e

6151 | Just sev <- [toDSeverity $ errMsgSeverity e]]

6252

6353

6454diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]

6555diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList

6656

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

8657

8758-- | Convert a GHC SrcSpan to a DAML compiler Range

8859srcSpanToRange :: SrcSpan -> Range

@@ -103,11 +74,7 @@ srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real

10374srcSpanToLocation :: SrcSpan -> Location

10475srcSpanToLocation src =

10576 -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code

106− Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ srcSpanToFilename src) (srcSpanToRange src)

107−

108−isInsideSrcSpan :: Position -> SrcSpan -> Bool

109−p `isInsideSrcSpan` r = sp <= p && p <= ep

110− where Range sp ep = srcSpanToRange r

77+ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath $ srcSpanToFilename src) (srcSpanToRange src)

11178

11279-- | Convert a GHC severity to a DAML compiler Severity. Severities below

11380-- "Warning" level are dropped (returning Nothing).

@@ -150,7 +117,7 @@ realSpan = \case

150117

151118-- | Run something in a Ghc monad and catch the errors (SourceErrors and

152119-- compiler-internal exceptions like Panic or InstallationError).

153−catchSrcErrors :: (HasDynFlags m, ExceptionMonad m) => T.Text -> m a -> m (Either [FileDiagnostic] a)

120+catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)

154121catchSrcErrors fromWhere ghcM = do

155122 dflags <- getDynFlags

156123 handleGhcException (ghcExceptionToDiagnostics dflags) $

src/Development/IDE/GHC/Orphans.hs+3−10

@@ -1,10 +1,8 @@

22-- SPDX-License-Identifier: Apache-2.0

4−{-# LANGUAGE CPP #-}

54{-# LANGUAGE FlexibleInstances #-}

65{-# OPTIONS_GHC -Wno-orphans #-}

7−#include "ghc-api-version.h"

97-- | Orphan instances for GHC.

108-- Note that the 'NFData' instances may not be law abiding.

@@ -33,7 +31,7 @@ instance NFData Linkable where rnf = rwhnf

3331instance Show InstalledUnitId where

3432 show = installedUnitIdString

3533

36−instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS

34+instance NFData InstalledUnitId where rnf = rwhnf

3735

3836instance NFData SB.StringBuffer where rnf = rwhnf

3937

@@ -42,8 +40,8 @@ instance Show Module where

4240

4341instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint

4442

45−instance (NFData l, NFData e) => NFData (GenLocated l e) where

46− rnf (L l e) = rnf l `seq` rnf e

43+instance NFData (GenLocated SrcSpan ModuleName) where

44+ rnf = rwhnf

4745

4846instance Show ModSummary where

4947 show = show . ms_mod

@@ -54,11 +52,6 @@ instance Show ParsedModule where

5452instance NFData ModSummary where

5553 rnf = rwhnf

5654

57−#if !MIN_GHC_API_VERSION(8,10,0)

58−instance NFData FastString where

59− rnf = rwhnf

60−#endif

61−

6255instance NFData ParsedModule where

6356 rnf = rwhnf

6457

src/Development/IDE/GHC/Util.hs+70−151

@@ -1,83 +1,65 @@

22-- SPDX-License-Identifier: Apache-2.0

4−-- | General utility functions, mostly focused around GHC operations.

4+{-# OPTIONS_GHC -Wno-missing-fields #-} -- to enable prettyPrint

5+{-# LANGUAGE CPP #-}

6+#include "ghc-api-version.h"

8+-- | GHC utility functions. Importantly, code using our GHC should never:

9+--

10+-- * Call runGhc, use runGhcFast instead. It's faster and doesn't require config we don't have.

11+--

12+-- * Call setSessionDynFlags, use modifyDynFlags instead. It's faster and avoids loading packages.

513module Development.IDE.GHC.Util(

6− -- * HcsEnv and environment

7− HscEnvEq(GhcVersionMismatch, compileTime, runTime), hscEnv, newHscEnvEq,

14+ lookupPackageConfig,

815 modifyDynFlags,

9− evalGhcEnv,

10− runGhcEnv,

11− deps,

12− -- * GHC wrappers

16+ fakeDynFlags,

1317 prettyPrint,

14− printRdrName,

15− printName,

16− ParseResult(..), runParser,

17− lookupPackageConfig,

18+ runGhcEnv,

1819 textToStringBuffer,

19− stringBufferToByteString,

2020 moduleImportPath,

21− cgGutsToCoreModule,

22− fingerprintToBS,

23− fingerprintFromStringBuffer,

24− -- * General utilities

21+ HscEnvEq, hscEnv, newHscEnvEq,

2522 readFileUtf8,

26− hDuplicateTo',

27− setDefaultHieDir,

28− dontWriteHieFiles

23+ hDuplicateTo,

24+ cgGutsToCoreModule

2925 ) where

3026

27+import Config

3128import Control.Concurrent

3229import Data.List.Extra

33−import Data.ByteString.Internal (ByteString(..))

3430import Data.Maybe

3531import Data.Typeable

36−import qualified Data.ByteString.Internal as BS

32+#if MIN_GHC_API_VERSION(8,6,0)

3733import Fingerprint

34+#endif

35+import GHC

3836import GhcMonad

39−import Control.Exception

37+import GhcPlugins hiding (Unique)

4038import Data.IORef

41−import Data.Version (showVersion, Version)

39+import Control.Exception

4240import FileCleanup

43−import Foreign.Ptr

44−import Foreign.ForeignPtr

45−import Foreign.Storable

4641import GHC.IO.BufferedIO (BufferedIO)

4742import GHC.IO.Device as IODevice

4843import GHC.IO.Encoding

4944import GHC.IO.Exception

5045import GHC.IO.Handle.Types

5146import GHC.IO.Handle.Internals

47+import Platform

5248import Data.Unique

5349import Development.Shake.Classes

5450import qualified Data.Text as T

5551import qualified Data.Text.Encoding as T

5652import qualified Data.Text.Encoding.Error as T

5753import qualified Data.ByteString as BS

58−import Lexer

5954import StringBuffer

6055import 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)

7156

72−import Development.IDE.GHC.Compat as GHC

7357import Development.IDE.Types.Location

7458

7559

7660----------------------------------------------------------------------

7761-- GHC setup

7862

79−-- | Used to modify dyn flags in preference to calling 'setSessionDynFlags',

80−-- since that function also reloads packages (which is very slow).

8163modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()

8264modifyDynFlags f = do

8365 newFlags <- f <$> getSessionDynFlags

@@ -86,7 +68,6 @@ modifyDynFlags f = do

8668 modifySession $ \h ->

8769 h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} }

8870

89−-- | Given a 'UnitId' try and find the associated 'PackageConfig' in the environment.

9071lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig

9172lookupPackageConfig unitId env =

9273 lookupPackage' False pkgConfigMap unitId

@@ -97,134 +78,86 @@ lookupPackageConfig unitId env =

9778 getPackageConfigMap $ hsc_dflags env

9879

9980

100−-- | Convert from the @text@ package to the @GHC@ 'StringBuffer'.

101−-- Currently implemented somewhat inefficiently (if it ever comes up in a profile).

81+-- would be nice to do this more efficiently...

10282textToStringBuffer :: T.Text -> StringBuffer

10383textToStringBuffer = stringToStringBuffer . T.unpack

10484

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

11585

116−-- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.

11786prettyPrint :: Outputable a => a -> String

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

87+prettyPrint = showSDoc fakeDynFlags . ppr

12588

126−-- | Pretty print a 'Name' wrapping operators in parens

127−printName :: Name -> String

128−printName = printRdrName . nameRdrName

129−

130−-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required

131−-- pieces, but designed to be more efficient than a standard 'runGhc'.

132−evalGhcEnv :: HscEnv -> Ghc b -> IO b

133−evalGhcEnv env act = snd <$> runGhcEnv env act

134−

135−-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required

136−-- pieces, but designed to be more efficient than a standard 'runGhc'.

137−runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a)

89+runGhcEnv :: HscEnv -> Ghc a -> IO a

13890runGhcEnv env act = do

13991 filesToClean <- newIORef emptyFilesToClean

14092 dirsToClean <- newIORef mempty

14193 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}

14294 ref <- newIORef env{hsc_dflags=dflags}

143− res <- unGhc act (Session ref) `finally` do

95+ unGhc act (Session ref) `finally` do

14496 cleanTempFiles dflags

14597 cleanTempDirs dflags

146− (,res) <$> readIORef ref

14798

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

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

152124-- The call to takeDirectory is required since DAML does not require that

153125-- the file name matches the module name in the last component.

154126-- Once that has changed we can get rid of this.

155−moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn

127+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm

156128 -- This happens for single-component modules since takeDirectory "A" == "."

157129 | modDir == "." = Just pathDir

158130 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir

159131 where

132+ ms = GHC.pm_mod_summary pm

133+ mod' = GHC.ms_mod ms

160134 -- A for module A.B

161135 modDir =

162136 takeDirectory $

163− fromNormalizedFilePath $ toNormalizedFilePath' $

164− moduleNameSlashes mn

137+ fromNormalizedFilePath $ toNormalizedFilePath $

138+ moduleNameSlashes $ GHC.moduleName mod'

165139

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− }

140+-- | An HscEnv with equality.

141+data HscEnvEq = HscEnvEq Unique HscEnv

176142

177−-- | Unwrap an 'HsEnvEq'.

178143hscEnv :: HscEnvEq -> HscEnv

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{} = []

144+hscEnv (HscEnvEq _ x) = x

195145

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

146+newHscEnvEq :: HscEnv -> IO HscEnvEq

147+newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e

199148

200149instance Show HscEnvEq where

201− show (HscEnvEq a _ _) = "HscEnvEq " ++ show (hashUnique a)

202− show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)

150+ show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)

203151

204152instance Eq HscEnvEq where

205− HscEnvEq a _ _ == HscEnvEq b _ _ = a == b

206− GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d

207− _ == _ = False

153+ HscEnvEq a _ == HscEnvEq b _ = a == b

208154

209155instance NFData HscEnvEq where

210− rnf (HscEnvEq a b c) = rnf (hashUnique a) `seq` b `seq` c `seq` ()

211− rnf GhcVersionMismatch{} = rnf runTime

156+ rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()

212157

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.

224158readFileUtf8 :: FilePath -> IO T.Text

225159readFileUtf8 f = T.decodeUtf8With T.lenientDecode <$> BS.readFile f

226160

227−-- | Convert from a 'CgGuts' to a 'CoreModule'.

228161cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule

229162cgGutsToCoreModule safeMode guts modDetails = CoreModule

230163 (cg_module guts)

@@ -232,24 +165,10 @@ cgGutsToCoreModule safeMode guts modDetails = CoreModule

232165 (cg_binds guts)

233166 safeMode

234167

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.

251−hDuplicateTo' :: Handle -> Handle -> IO ()

252−hDuplicateTo' h1@(FileHandle path m1) h2@(FileHandle _ m2) = do

168+-- This is a slightly modified version of hDuplicateTo in GHC.

169+-- See the inline comment for more details.

170+hDuplicateTo :: Handle -> Handle -> IO ()

171+hDuplicateTo h1@(FileHandle path m1) h2@(FileHandle _ m2) = do

253172 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do

254173 -- The implementation in base has this call to hClose_help.

255174 -- _ <- hClose_help h2_

@@ -262,7 +181,7 @@ hDuplicateTo' h1@(FileHandle path m1) h2@(FileHandle _ m2) = do

262181 -- if it happens just in the right moment.

263182 withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do

264183 dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer)

265−hDuplicateTo' h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2) = do

184+hDuplicateTo h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2) = do

266185 withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do

267186 _ <- hClose_help w2_

268187 withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do

@@ -271,7 +190,7 @@ hDuplicateTo' h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2) = do

271190 _ <- hClose_help r2_

272191 withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do

273192 dupHandleTo path h1 (Just w1) r2_ r1_ Nothing

274−hDuplicateTo' h1 _ =

193+hDuplicateTo h1 _ =

275194 ioe_dupHandlesNotCompatible h1

276195

277196-- | This is copied unmodified from GHC since it is not exposed.

src/Development/IDE/GHC/WithDynFlags.hsdeleted−30

@@ -1,30 +0,0 @@

1−module Development.IDE.GHC.WithDynFlags

2−( WithDynFlags

3−, evalWithDynFlags

4−) where

5−

6−import Control.Monad.Trans.Reader (ask, ReaderT(..))

7−import GHC (DynFlags)

8−import Control.Monad.IO.Class (MonadIO)

9−import Exception (ExceptionMonad(..))

10−import Control.Monad.Trans.Class (MonadTrans(..))

11−import GhcPlugins (HasDynFlags(..))

12−

13−-- | A monad transformer implementing the 'HasDynFlags' effect

14−newtype WithDynFlags m a = WithDynFlags {withDynFlags :: ReaderT DynFlags m a}

15− deriving (Applicative, Functor, Monad, MonadIO, MonadTrans)

16−

17−evalWithDynFlags :: DynFlags -> WithDynFlags m a -> m a

18−evalWithDynFlags dflags = flip runReaderT dflags . withDynFlags

19−

20−instance Monad m => HasDynFlags (WithDynFlags m) where

21− getDynFlags = WithDynFlags ask

22−

23−instance ExceptionMonad m => ExceptionMonad (WithDynFlags m) where

24− gmask f = WithDynFlags $ ReaderT $ \env ->

25− gmask $ \restore ->

26− let restore' = lift . restore . flip runReaderT env . withDynFlags

27− in runReaderT (withDynFlags $ f restore') env

28−

29− gcatch (WithDynFlags act) handle = WithDynFlags $ ReaderT $ \env ->

30− gcatch (runReaderT act env) (flip runReaderT env . withDynFlags . handle)

src/Development/IDE/Import/DependencyInformation.hs+34−121

@@ -9,33 +9,26 @@ module Development.IDE.Import.DependencyInformation

99 , ModuleParseError(..)

1010 , TransitiveDependencies(..)

1111 , FilePathId(..)

12− , NamedModuleDep(..)

1312

1413 , PathIdMap

1514 , emptyPathIdMap

1615 , getPathId

17− , lookupPathToId

1816 , insertImport

1917 , pathToId

2018 , idToPath

2119 , reachableModules

20+

2221 , processDependencyInformation

2322 , transitiveDeps

24−

25− , BootIdMap

26− , insertBootId

2723 ) where

2824

2925import Control.DeepSeq

3026import Data.Bifunctor

3127import Data.Coerce

3228import Data.List

33−import Data.Tuple.Extra hiding (first, second)

3429import Development.IDE.GHC.Orphans()

3530import Data.Either

3631import Data.Graph

37−import Data.HashMap.Strict (HashMap)

38−import qualified Data.HashMap.Strict as HMS

3932import Data.List.NonEmpty (NonEmpty(..), nonEmpty)

4033import qualified Data.List.NonEmpty as NonEmpty

4134import Data.IntMap (IntMap)

@@ -43,14 +36,16 @@ import qualified Data.IntMap.Strict as IntMap

4336import qualified Data.IntMap.Lazy as IntMapLazy

4437import Data.IntSet (IntSet)

4538import qualified Data.IntSet as IntSet

39+import Data.Map (Map)

40+import qualified Data.Map.Strict as MS

4641import Data.Maybe

4742import Data.Set (Set)

4843import qualified Data.Set as Set

44+import Data.Tuple.Extra (fst3)

4945import GHC.Generics (Generic)

5046

5147import Development.IDE.Types.Diagnostics

5248import Development.IDE.Types.Location

53−import Development.IDE.Import.FindImports (ArtifactsLocation(..))

5449

5550import GHC

5651import Module

@@ -62,100 +57,69 @@ data ModuleImports = ModuleImports

6257 -- that module on disk (if we found it)

6358 , packageImports :: !(Set InstalledUnitId)

6459 -- ^ Transitive package dependencies unioned for all imports.

65− } deriving Show

60+ }

6661

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.

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

7066newtype FilePathId = FilePathId { getFilePathId :: Int }

7167 deriving (Show, NFData, Eq, Ord)

7268

73−-- | Map from 'FilePathId'

74−type FilePathIdMap = IntMap

75−

76−-- | Set of 'FilePathId's

77−type FilePathIdSet = IntSet

78−

7969data PathIdMap = PathIdMap

80− { idToPathMap :: !(FilePathIdMap ArtifactsLocation)

81− , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)

70+ { idToPathMap :: !(IntMap NormalizedFilePath)

71+ , pathToIdMap :: !(Map NormalizedFilePath FilePathId)

8272 }

8373 deriving (Show, Generic)

8474

8575instance NFData PathIdMap

8676

8777emptyPathIdMap :: PathIdMap

88−emptyPathIdMap = PathIdMap IntMap.empty HMS.empty

78+emptyPathIdMap = PathIdMap IntMap.empty MS.empty

8979

90−getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap)

80+getPathId :: NormalizedFilePath -> PathIdMap -> (FilePathId, PathIdMap)

9181getPathId path m@PathIdMap{..} =

92− case HMS.lookup (artifactFilePath path) pathToIdMap of

82+ case MS.lookup path pathToIdMap of

9383 Nothing ->

94− let !newId = FilePathId $ HMS.size pathToIdMap

84+ let !newId = FilePathId $ MS.size pathToIdMap

9585 in (newId, insertPathId path newId m)

9686 Just id -> (id, m)

9787

98−insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap

88+insertPathId :: NormalizedFilePath -> FilePathId -> PathIdMap -> PathIdMap

9989insertPathId path id PathIdMap{..} =

100− PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert (artifactFilePath path) id pathToIdMap)

90+ PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (MS.insert path id pathToIdMap)

10191

10292insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation

10393insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }

10494

10595pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId

106−pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path

107−

108−lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId

109−lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap

96+pathToId PathIdMap{pathToIdMap} path = pathToIdMap MS.! path

11097

11198idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath

112−idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId

113−

114−idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation

115−idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id

116−

117−type BootIdMap = FilePathIdMap FilePathId

118−

119−insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap

120−insertBootId k = IntMap.insert (getFilePathId k)

99+idToPath PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id

121100

122101-- | Unprocessed results that we find by following imports recursively.

123102data RawDependencyInformation = RawDependencyInformation

124− { rawImports :: !(FilePathIdMap (Either ModuleParseError ModuleImports))

103+ { rawImports :: !(IntMap (Either ModuleParseError ModuleImports))

125104 , rawPathIdMap :: !PathIdMap

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)

105+ }

106+

107+pkgDependencies :: RawDependencyInformation -> IntMap (Set InstalledUnitId)

134108pkgDependencies RawDependencyInformation{..} =

135109 IntMap.map (either (const Set.empty) packageImports) rawImports

136110

137111data DependencyInformation =

138112 DependencyInformation

139− { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError))

113+ { depErrorNodes :: !(IntMap (NonEmpty NodeError))

140114 -- ^ Nodes that cannot be processed correctly.

141− , depModuleNames :: !(FilePathIdMap ShowableModuleName)

142− , depModuleDeps :: !(FilePathIdMap FilePathIdSet)

115+ , depModuleDeps :: !(IntMap IntSet)

143116 -- ^ For a non-error node, this contains the set of module immediate dependencies

144117 -- in the same package.

145− , depPkgDeps :: !(FilePathIdMap (Set InstalledUnitId))

118+ , depPkgDeps :: !(IntMap (Set InstalledUnitId))

146119 -- ^ For a non-error node, this contains the set of immediate pkg deps.

147120 , depPathIdMap :: !PathIdMap

148− -- ^ Map from FilePath to FilePathId

149− , depBootMap :: !BootIdMap

150− -- ^ Map from hs-boot file to the corresponding hs file

151121 } deriving (Show, Generic)

152122

153−newtype ShowableModuleName =

154− ShowableModuleName {showableModuleName :: ModuleName}

155− deriving NFData

156−

157−instance Show ShowableModuleName where show = moduleNameString . showableModuleName

158−

159123reachableModules :: DependencyInformation -> [NormalizedFilePath]

160124reachableModules DependencyInformation{..} =

161125 map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps

@@ -222,32 +186,23 @@ processDependencyInformation rawDepInfo@RawDependencyInformation{..} =

222186 DependencyInformation

223187 { depErrorNodes = IntMap.fromList errorNodes

224188 , depModuleDeps = moduleDeps

225− , depModuleNames = IntMap.fromList $ coerce moduleNames

226189 , depPkgDeps = pkgDependencies rawDepInfo

227190 , depPathIdMap = rawPathIdMap

228− , depBootMap = rawBootMap

229191 }

230192 where resultGraph = buildResultGraph rawImports

231193 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph

232− moduleNames :: [(FilePathId, ModuleName)]

233− moduleNames =

234− [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports]

235194 successEdges :: [(FilePathId, FilePathId, [FilePathId])]

236195 successEdges =

237− map

238− (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports))

239− successNodes

196+ map (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports)) successNodes

240197 moduleDeps =

241− IntMap.fromList $

242− map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs))

243− successEdges

198+ IntMap.fromList $ map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs)) successEdges

244199

245200-- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:

246201-- 1. Mark each node that is part of an import cycle as an error node.

247202-- 2. Mark each node that has a parse error as an error node.

248203-- 3. Mark each node whose immediate children could not be located as an error.

249204-- 4. Recursively propagate errors to parents if they are not already error nodes.

250−buildResultGraph :: FilePathIdMap (Either ModuleParseError ModuleImports) -> FilePathIdMap NodeResult

205+buildResultGraph :: IntMap (Either ModuleParseError ModuleImports) -> IntMap NodeResult

251206buildResultGraph g = propagatedErrors

252207 where

253208 sccs = stronglyConnComp (graphEdges g)

@@ -294,7 +249,7 @@ buildResultGraph g = propagatedErrors

294249 Right ModuleImports{moduleImports} ->

295250 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports

296251

297−graphEdges :: FilePathIdMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]

252+graphEdges :: IntMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]

298253graphEdges g =

299254 map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g

300255 where deps :: Either e ModuleImports -> [FilePathId]

@@ -306,71 +261,29 @@ partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest

306261partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest

307262partitionSCC [] = ([], [])

308263

309−

310264transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies

311265transitiveDeps DependencyInformation{..} file = do

312266 let !fileId = pathToId depPathIdMap file

313267 reachableVs <-

314− -- Delete the starting node

315268 IntSet.delete (getFilePathId fileId) .

316269 IntSet.fromList . map (fst3 . fromVertex) .

317270 reachable g <$> toVertex (getFilePathId fileId)

318− let transitiveModuleDepIds =

319− filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs

271+ let transitiveModuleDepIds = filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs

320272 let transitivePkgDeps =

321273 Set.toList $ Set.unions $

322274 map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $

323275 getFilePathId fileId : 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− ]

276+ let transitiveModuleDeps = map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds

331277 pure TransitiveDependencies {..}

332− where

333− (g, fromVertex, toVertex) = graphFromEdges edges

334− edges = map (\(f, fs) -> (f, f, IntSet.toList fs ++ boot_edge f)) $ IntMap.toList depModuleDeps

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

278+ where (g, fromVertex, toVertex) = graphFromEdges (map (\(f, fs) -> (f, f, IntSet.toList fs)) $ IntMap.toList depModuleDeps)

279+ vs = topSort g

343280

344281data TransitiveDependencies = TransitiveDependencies

345282 { transitiveModuleDeps :: [NormalizedFilePath]

346283 -- ^ Transitive module dependencies in topological order.

347284 -- The module itself is not included.

348− , transitiveNamedModuleDeps :: [NamedModuleDep]

349− -- ^ Transitive module dependencies in topological order.

350− -- The module itself is not included.

351285 , transitivePkgDeps :: [InstalledUnitId]

352286 -- ^ Transitive pkg dependencies in unspecified order.

353287 } deriving (Eq, Show, Generic)

354288

355289instance NFData TransitiveDependencies

356−

357−data NamedModuleDep = NamedModuleDep {

358− nmdFilePath :: !NormalizedFilePath,

359− nmdModuleName :: !ModuleName,

360− nmdModLocation :: !ModLocation

361− }

362− deriving Generic

363−

364−instance Eq NamedModuleDep where

365− a == b = nmdFilePath a == nmdFilePath b

366−

367−instance NFData NamedModuleDep where

368− rnf NamedModuleDep{..} =

369− rnf nmdFilePath `seq`

370− rnf nmdModuleName `seq`

371− -- 'ModLocation' lacks an 'NFData' instance

372− rwhnf nmdModLocation

373−

374−instance Show NamedModuleDep where

375− show NamedModuleDep{..} = show nmdFilePath

376−

src/Development/IDE/Import/FindImports.hs+17−63

@@ -7,19 +7,16 @@

77module Development.IDE.Import.FindImports

88 ( locateModule

99 , Import(..)

10− , ArtifactsLocation(..)

11− , modSummaryToArtifactsLocation

12− , isBootLocation

13− , mkImportDirs

1410 ) where

1511

1612import Development.IDE.GHC.Error as ErrUtils

1713import Development.IDE.GHC.Orphans()

1814import Development.IDE.Types.Diagnostics

1915import Development.IDE.Types.Location

20−import Development.IDE.GHC.Compat

2116-- GHC imports

17+import DynFlags

2218import FastString

19+import GHC

2320import qualified Module as M

2421import Packages

2522import Outputable (showSDoc, ppr, pprPanic)

@@ -30,107 +27,64 @@ import Control.DeepSeq

3027import Control.Monad.Extra

3128import Control.Monad.IO.Class

3229import System.FilePath

33−import DriverPhases

34−import Data.Maybe

3530

3631data Import

37− = FileImport !ArtifactsLocation

32+ = FileImport !NormalizedFilePath

3833 | PackageImport !M.InstalledUnitId

3934 deriving (Show)

4035

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−

5436instance NFData Import where

5537 rnf (FileImport x) = rnf x

5638 rnf (PackageImport x) = rnf x

5739

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−

6440

6541-- | locate a module in the file system. Where we go from *daml to Haskell

6642locateModuleFile :: MonadIO m

67− => [[FilePath]]

43+ => DynFlags

6844 -> [String]

6945 -> (NormalizedFilePath -> m Bool)

7046 -> Bool

7147 -> ModuleName

7248 -> m (Maybe NormalizedFilePath)

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)

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

7854 where

7955 maybeBoot ext

8056 | isSource = ext ++ "-boot"

8157 | otherwise = ext

8258

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−

9059-- | locate a module in either the file system or the package database. Where we go from *daml to

9160-- Haskell

9261locateModule

9362 :: MonadIO m

9463 => DynFlags

95− -> [(M.InstalledUnitId, DynFlags)] -- Sets import directories to look in

9664 -> [String]

9765 -> (NormalizedFilePath -> m Bool)

9866 -> Located ModuleName

9967 -> Maybe FastString

10068 -> Bool

10169 -> m (Either [FileDiagnostic] Import)

102−locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do

70+locateModule dflags exts doesExist modName mbPkgName isSource = do

10371 case mbPkgName of

10472 -- "this" means that we should only look in the current package

10573 Just "this" -> do

106− lookupLocal [importPaths dflags]

74+ mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName

75+ case mbFile of

76+ Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []

77+ Just file -> return $ Right $ FileImport file

10778 -- if a package name is given we only go look for a package

108− Just pkgName

109− | Just dirs <- lookup (PackageName pkgName) import_paths

110− -> lookupLocal [dirs]

111− | otherwise -> lookupInPackageDB dflags

79+ Just _pkgName -> lookupInPackageDB dflags

11280 Nothing -> do

11381 -- first try to find the module as a file. If we can't find it try to find it in the package

11482 -- database.

115− -- Here the importPaths for the current modules are added to the front of the import paths from the other components.

116− -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in

117− -- each component will end up being found in the wrong place and cause a multi-cradle match failure.

118− mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts doesExist isSource $ unLoc modName

83+ mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName

11984 case mbFile of

12085 Nothing -> lookupInPackageDB dflags

121− Just file -> toModLocation file

86+ Just file -> return $ Right $ FileImport file

12287 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−

13488 lookupInPackageDB dfs =

13589 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of

13690 LookupFound _m pkgConfig -> return $ Right $ PackageImport $ unitId pkgConfig

src/Development/IDE/LSP/CodeAction.hsnew file+285

@@ -0,0 +1,285 @@

2+-- SPDX-License-Identifier: Apache-2.0

4+{-# LANGUAGE DuplicateRecordFields #-}

5+{-# LANGUAGE CPP #-}

6+#include "ghc-api-version.h"

8+-- | Go to the definition of a variable.

9+module Development.IDE.LSP.CodeAction

10+ ( setHandlersCodeAction

11+ , setHandlersCodeLens

12+ ) where

13+

14+import Language.Haskell.LSP.Types

15+import Development.IDE.GHC.Compat

16+import Development.IDE.Core.Rules

17+import Development.IDE.Core.Shake

18+import Development.IDE.LSP.Server

19+import Development.IDE.Types.Location

20+import qualified Data.HashMap.Strict as Map

21+import qualified Data.HashSet as Set

22+import qualified Language.Haskell.LSP.Core as LSP

23+import Language.Haskell.LSP.VFS

24+import Language.Haskell.LSP.Messages

25+import qualified Data.Rope.UTF16 as Rope

26+import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))

27+import Data.Char

28+import Data.Maybe

29+import Data.List.Extra

30+import qualified Data.Text as T

31+

32+-- | Generate code actions.

33+codeAction

34+ :: LSP.LspFuncs ()

35+ -> IdeState

36+ -> CodeActionParams

37+ -> IO (List CAResult)

38+codeAction lsp _ CodeActionParams{_textDocument=TextDocumentIdentifier uri,_context=CodeActionContext{_diagnostics=List xs}} = do

39+ -- disable logging as its quite verbose

40+ -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg

41+ contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri

42+ let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents

43+ pure $ List

44+ [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing

45+ | x <- xs, (title, tedit) <- suggestAction text x

46+ , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

47+ ]

48+

49+-- | Generate code lenses.

50+codeLens

51+ :: LSP.LspFuncs ()

52+ -> IdeState

53+ -> CodeLensParams

54+ -> IO (List CodeLens)

55+codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do

56+ diag <- getDiagnostics ideState

57+ case uriToFilePath' uri of

58+ Just (toNormalizedFilePath -> filePath) -> do

59+ pure $ List

60+ [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing

61+ | (dFile, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag

62+ , dFile == filePath

63+ , (title, tedit) <- suggestTopLevelBinding False dDiag

64+ , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

65+ ]

66+ Nothing -> pure $ List []

67+

68+-- | Generate code lenses.

69+executeAddSignatureCommand

70+ :: LSP.LspFuncs ()

71+ -> IdeState

72+ -> ExecuteCommandParams

73+ -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

74+executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}

75+ | _command == "typesignature.add"

76+ , Just (List [edit]) <- _arguments

77+ , Success wedit <- fromJSON edit

78+ = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))

79+ | otherwise

80+ = return (Null, Nothing)

81+

82+suggestAction :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

83+suggestAction contents diag@Diagnostic{_range=_range@Range{..},..}

84+

85+-- File.hs:16:1: warning:

86+-- The import of `Data.List' is redundant

87+-- except perhaps to import instances from `Data.List'

88+-- To import instances alone, use: import Data.List()

89+ | "The import of " `T.isInfixOf` _message

90+ || "The qualified import of " `T.isInfixOf` _message

91+ , " is redundant" `T.isInfixOf` _message

92+ = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]

93+

94+-- File.hs:52:41: error:

95+-- * Variable not in scope:

96+-- suggestAcion :: Maybe T.Text -> Range -> Range

97+-- * Perhaps you meant ‘suggestAction’ (line 83)

98+-- File.hs:94:37: error:

99+-- Not in scope: ‘T.isPrfixOf’

100+-- Perhaps you meant one of these:

101+-- ‘T.isPrefixOf’ (imported from Data.Text),

102+-- ‘T.isInfixOf’ (imported from Data.Text),

103+-- ‘T.isSuffixOf’ (imported from Data.Text)

104+-- Module ‘Data.Text’ does not export ‘isPrfixOf’.

105+ | renameSuggestions@(_:_) <- extractRenamableTerms _message

106+ = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]

107+

108+-- Foo.hs:3:8: error:

109+-- * Found type wildcard `_' standing for `p -> p1 -> p'

110+

111+ | "Found type wildcard" `T.isInfixOf` _message

112+ , " standing for " `T.isInfixOf` _message

113+ , typeSignature <- extractWildCardTypeSignature _message

114+ = [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]

115+

116+-- File.hs:22:8: error:

117+-- Illegal lambda-case (use -XLambdaCase)

118+-- File.hs:22:6: error:

119+-- Illegal view pattern: x -> foo

120+-- Use ViewPatterns to enable view patterns

121+-- File.hs:26:8: error:

122+-- Illegal `..' in record pattern

123+-- Use RecordWildCards to permit this

124+-- File.hs:53:28: error:

125+-- Illegal tuple section: use TupleSections

126+-- File.hs:238:29: error:

127+-- * Can't make a derived instance of `Data FSATrace':

128+-- You need DeriveDataTypeable to derive an instance for this class

129+-- * In the data declaration for `FSATrace'

130+-- C:\Neil\shake\src\Development\Shake\Command.hs:515:31: error:

131+-- * Illegal equational constraint a ~ ()

132+-- (Use GADTs or TypeFamilies to permit this)

133+-- * In the context: a ~ ()

134+-- While checking an instance declaration

135+-- In the instance declaration for `Unit (m a)'

136+ | exts@(_:_) <- filter (`Set.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message

137+ = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts]

138+

139+-- src/Development/IDE/Core/Compile.hs:58:1: error:

140+-- Could not find module ‘Data.Cha’

141+-- Perhaps you meant Data.Char (from base-4.12.0.0)

142+ | "Could not find module" `T.isInfixOf` _message

143+ , "Perhaps you meant" `T.isInfixOf` _message = let

144+ findSuggestedModules = map (head . T.words) . drop 2 . T.lines

145+ proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])

146+ in map proposeModule $ nubOrd $ findSuggestedModules _message

147+

148+-- ...Development/IDE/LSP/CodeAction.hs:103:9: warning:

149+-- * Found hole: _ :: Int -> String

150+-- * In the expression: _

151+-- In the expression: _ a

152+-- In an equation for ‘foo’: foo a = _ a

153+-- * Relevant bindings include

154+-- a :: Int

155+-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:5)

156+-- foo :: Int -> String

157+-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)

158+-- Valid hole fits include

159+-- foo :: Int -> String

160+-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)

161+-- show :: forall a. Show a => a -> String

162+-- with show @Int

163+-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37

164+-- (and originally defined in ‘GHC.Show’))

165+-- mempty :: forall a. Monoid a => a

166+-- with mempty @(Int -> String)

167+-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37

168+-- (and originally defined in ‘GHC.Base’)) (lsp-ui)

169+

170+ | topOfHoleFitsMarker `T.isInfixOf` _message = let

171+ findSuggestedHoleFits :: T.Text -> [T.Text]

172+ findSuggestedHoleFits = extractFitNames . selectLinesWithFits . dropPreceding . T.lines

173+ proposeHoleFit name = ("replace hole `" <> holeName <> "` with " <> name, [TextEdit _range name])

174+ holeName = T.strip $ last $ T.splitOn ":" $ head . T.splitOn "::" $ head $ filter ("Found hole" `T.isInfixOf`) $ T.lines _message

175+ dropPreceding = dropWhile (not . (topOfHoleFitsMarker `T.isInfixOf`))

176+ selectLinesWithFits = filter ("::" `T.isInfixOf`)

177+ extractFitNames = map (T.strip . head . T.splitOn " :: ")

178+ in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message

179+

180+ | tlb@[_] <- suggestTopLevelBinding True diag = tlb

181+

182+suggestAction _ _ = []

183+

184+suggestTopLevelBinding :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]

185+suggestTopLevelBinding isQuickFix Diagnostic{_range=_range@Range{..},..}

186+ | "Top-level binding with no type signature" `T.isInfixOf` _message = let

187+ filterNewlines = T.concat . T.lines

188+ unifySpaces = T.unwords . T.words

189+ signature = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message

190+ startOfLine = Position (_line _start) 0

191+ beforeLine = Range startOfLine startOfLine

192+ title = if isQuickFix then "add signature: " <> signature else signature

193+ action = TextEdit beforeLine $ signature <> "\n"

194+ in [(title, [action])]

195+suggestTopLevelBinding _ _ = []

196+

197+topOfHoleFitsMarker :: T.Text

198+topOfHoleFitsMarker =

199+#if MIN_GHC_API_VERSION(8,6,0)

200+ "Valid hole fits include"

201+#else

202+ "Valid substitutions include"

203+#endif

204+

205+mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit

206+mkRenameEdit contents range name =

207+ if fromMaybe False maybeIsInfixFunction

208+ then TextEdit range ("`" <> name <> "`")

209+ else TextEdit range name

210+ where

211+ maybeIsInfixFunction = do

212+ curr <- textInRange range <$> contents

213+ pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr

214+

215+extractWildCardTypeSignature :: T.Text -> T.Text

216+extractWildCardTypeSignature =

217+ -- inferring when parens are actually needed around the type signature would

218+ -- require understanding both the precedence of the context of the _ and of

219+ -- the signature itself. Inserting them unconditionally is ugly but safe.

220+ ("(" `T.append`) . (`T.append` ")") .

221+ T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') .

222+ snd . T.breakOnEnd "standing for "

223+

224+extractRenamableTerms :: T.Text -> [T.Text]

225+extractRenamableTerms msg

226+ -- Account for both "Variable not in scope" and "Not in scope"

227+ | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg

228+ | otherwise = []

229+ where

230+ extractSuggestions = map getEnclosed

231+ . concatMap singleSuggestions

232+ . filter isKnownSymbol

233+ . T.lines

234+ singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited

235+ isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t

236+ getEnclosed = T.dropWhile (== '‘')

237+ . T.dropWhileEnd (== '’')

238+ . T.dropAround (\c -> c /= '‘' && c /= '’')

239+

240+-- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace

241+-- between the end of the range and the next newline), extend the range to take up the whole line.

242+extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range

243+extendToWholeLineIfPossible contents range@Range{..} =

244+ let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents

245+ extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line

246+ in if extend then Range _start (Position (_line _end + 1) 0) else range

247+

248+-- | All the GHC extensions

249+ghcExtensions :: Set.HashSet T.Text

250+ghcExtensions = Set.fromList $ map (T.pack . show) ghcEnumerateExtensions

251+

252+splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)

253+splitTextAtPosition (Position row col) x

254+ | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x

255+ , (preCol, postCol) <- T.splitAt col mid

256+ = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)

257+ | otherwise = (x, T.empty)

258+

259+textInRange :: Range -> T.Text -> T.Text

260+textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =

261+ case compare startRow endRow of

262+ LT ->

263+ let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine

264+ (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of

265+ [] -> ("", [])

266+ firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)

267+ maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines

268+ in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)

269+ EQ ->

270+ let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)

271+ in T.take (endCol - startCol) (T.drop startCol line)

272+ GT -> ""

273+ where

274+ linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)

275+

276+setHandlersCodeAction :: PartialHandlers

277+setHandlersCodeAction = PartialHandlers $ \WithMessage{..} x -> return x{

278+ LSP.codeActionHandler = withResponse RspCodeAction codeAction

279+ }

280+

281+setHandlersCodeLens :: PartialHandlers

282+setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{

283+ LSP.codeLensHandler = withResponse RspCodeLens codeLens,

284+ LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand

285+ }

src/Development/IDE/LSP/Definition.hsnew file+43

@@ -0,0 +1,43 @@

2+-- SPDX-License-Identifier: Apache-2.0

5+-- | Go to the definition of a variable.

6+module Development.IDE.LSP.Definition

7+ ( setHandlersDefinition

8+ ) where

10+import Language.Haskell.LSP.Types

11+import Development.IDE.Types.Location

12+

13+import Development.IDE.Types.Logger

14+import Development.IDE.Core.Rules

15+import Development.IDE.Core.Service

16+import Development.IDE.LSP.Server

17+import qualified Language.Haskell.LSP.Core as LSP

18+import Language.Haskell.LSP.Messages

19+

20+import qualified Data.Text as T

21+

22+-- | Go to the definition of a variable.

23+gotoDefinition

24+ :: IdeState

25+ -> TextDocumentPositionParams

26+ -> IO LocationResponseParams

27+gotoDefinition ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do

28+ mbResult <- case uriToFilePath' uri of

29+ Just path -> do

30+ logInfo (ideLogger ide) $

31+ "Definition request at position " <> T.pack (showPosition pos) <>

32+ " in file: " <> T.pack path

33+ runAction ide $ getDefinition (toNormalizedFilePath path) pos

34+ Nothing -> pure Nothing

35+ pure $ case mbResult of

36+ Nothing -> MultiLoc []

37+ Just loc -> SingleLoc loc

38+

39+

40+setHandlersDefinition :: PartialHandlers

41+setHandlersDefinition = PartialHandlers $ \WithMessage{..} x -> return x{

42+ LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition

43+ }

src/Development/IDE/LSP/Hover.hsnew file+47

@@ -0,0 +1,47 @@

2+-- SPDX-License-Identifier: Apache-2.0

5+-- | Display information on hover.

6+module Development.IDE.LSP.Hover

7+ ( setHandlersHover

8+ ) where

10+import Language.Haskell.LSP.Types

11+import Development.IDE.Types.Location

12+import Development.IDE.Core.Service

13+import Development.IDE.LSP.Server

14+import Development.IDE.Types.Logger

15+import qualified Language.Haskell.LSP.Core as LSP

16+import Language.Haskell.LSP.Messages

17+

18+import qualified Data.Text as T

19+

20+import Development.IDE.Core.Rules

21+

22+-- | Display information on hover.

23+onHover

24+ :: IdeState

25+ -> TextDocumentPositionParams

26+ -> IO (Maybe Hover)

27+onHover ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do

28+ mbResult <- case uriToFilePath' uri of

29+ Just (toNormalizedFilePath -> filePath) -> do

30+ logInfo (ideLogger ide) $

31+ "Hover request at position " <> T.pack (showPosition pos) <>

32+ " in file: " <> T.pack (fromNormalizedFilePath filePath)

33+ runAction ide $ getAtPoint filePath pos

34+ Nothing -> pure Nothing

35+

36+ case mbResult of

37+ Just (mbRange, contents) ->

38+ pure $ Just $ Hover

39+ (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents)

40+ mbRange

41+

42+ Nothing -> pure Nothing

43+

44+setHandlersHover :: PartialHandlers

45+setHandlersHover = PartialHandlers $ \WithMessage{..} x -> return x{

46+ LSP.hoverHandler = withResponse RspHover $ const onHover

47+ }

src/Development/IDE/LSP/HoverDefinition.hsdeleted−62

@@ -1,62 +0,0 @@

2−-- SPDX-License-Identifier: Apache-2.0

3−

4−

5−-- | Display information on hover.

6−module Development.IDE.LSP.HoverDefinition

7− ( setHandlersHover

8− , setHandlersDefinition

9− -- * For haskell-language-server

10− , hover

11− , gotoDefinition

12− ) where

13−

14−import Development.IDE.Core.Rules

15−import Development.IDE.Core.Service

16−import Development.IDE.LSP.Server

17−import Development.IDE.Types.Location

18−import Development.IDE.Types.Logger

19−import Development.Shake

20−import qualified Language.Haskell.LSP.Core as LSP

21−import Language.Haskell.LSP.Messages

22−import Language.Haskell.LSP.Types

23−

24−import qualified Data.Text as T

25−

26−gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)

27−hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))

28−gotoDefinition = request "Definition" getDefinition (MultiLoc []) SingleLoc

29−hover = request "Hover" getAtPoint Nothing foundHover

30−

31−foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover

32−foundHover (mbRange, contents) =

33− Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange

34−

35−setHandlersDefinition, setHandlersHover :: PartialHandlers c

36−setHandlersDefinition = PartialHandlers $ \WithMessage{..} x ->

37− return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition}

38−setHandlersHover = PartialHandlers $ \WithMessage{..} x ->

39− return x{LSP.hoverHandler = withResponse RspHover $ const hover}

40−

41−-- | Respond to and log a hover or go-to-definition request

42−request

43− :: T.Text

44− -> (NormalizedFilePath -> Position -> Action (Maybe a))

45− -> b

46− -> (a -> b)

47− -> IdeState

48− -> TextDocumentPositionParams

49− -> IO (Either ResponseError b)

50−request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do

51− mbResult <- case uriToFilePath' uri of

52− Just path -> logAndRunRequest label getResults ide pos path

53− Nothing -> pure Nothing

54− pure $ Right $ maybe notFound found mbResult

55−

56−logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b

57−logAndRunRequest label getResults ide pos path = do

58− let filePath = toNormalizedFilePath' path

59− logInfo (ideLogger ide) $

60− label <> " request at position " <> T.pack (showPosition pos) <>

61− " in file: " <> T.pack path

62− runAction ide $ getResults filePath pos

src/Development/IDE/LSP/LanguageServer.hs+32−58

@@ -28,30 +28,27 @@ 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

33−import Development.IDE.LSP.HoverDefinition

31+import Development.IDE.LSP.Definition

32+import Development.IDE.LSP.Hover

33+import Development.IDE.LSP.CodeAction

3434import Development.IDE.LSP.Notifications

35−import Development.IDE.LSP.Outline

35+import Development.IDE.Core.Service

3636import Development.IDE.Types.Logger

3737import Development.IDE.Core.FileStore

3838import Language.Haskell.LSP.Core (LspFuncs(..))

3939import Language.Haskell.LSP.Messages

4040

4141runLanguageServer

42− :: forall config. (Show config)

43− => LSP.Options

44− -> PartialHandlers config

45− -> (InitializeRequest -> Either T.Text config)

46− -> (DidChangeConfigurationNotification -> Either T.Text config)

42+ :: LSP.Options

43+ -> PartialHandlers

4744 -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)

4845 -> IO ()

49−runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do

46+runLanguageServer options userHandlers getIdeState = do

5047 -- Move stdout to another file descriptor and duplicate stderr

5148 -- to stdout. This guards against stray prints from corrupting the JSON-RPC

5249 -- message stream.

5350 newStdout <- hDuplicate stdout

54− stderr `Ghcide.hDuplicateTo'` stdout

51+ stderr `Ghcide.hDuplicateTo` stdout

5552 hSetBuffering stderr NoBuffering

5653 hSetBuffering stdout NoBuffering

5754

@@ -63,7 +60,7 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

6360

6461 -- Send everything over a channel, since you need to wait until after initialise before

6562 -- LspFuncs is available

66− clientMsgChan :: Chan (Message config) <- newChan

63+ clientMsgChan :: Chan Message <- newChan

6764

6865 -- These barriers are signaled when the threads reading from these chans exit.

6966 -- This should not happen but if it does, we will make sure that the whole server

@@ -82,7 +79,6 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

8279 let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do

8380 atomically $ modifyTVar pendingRequests (Set.insert _id)

8481 writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f

85− let withInitialize f = Just $ \r -> writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x)

8682 let cancelRequest reqId = atomically $ do

8783 queued <- readTVar pendingRequests

8884 -- We want to avoid that the list of cancelled requests

@@ -99,20 +95,19 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

9995 cancelled <- readTVar cancelledRequests

10096 unless (reqId `Set.member` cancelled) retry

10197 let PartialHandlers parts =

102− initializeRequestHandler <>

10398 setHandlersIgnore <> -- least important

10499 setHandlersDefinition <> setHandlersHover <>

105− setHandlersOutline <>

100+ setHandlersCodeAction <> setHandlersCodeLens <> -- useful features someone may override

106101 userHandlers <>

107102 setHandlersNotifications <> -- absolutely critical, join them with user notifications

108103 cancelHandler cancelRequest

109104 -- Cancel requests are special since they need to be handled

110105 -- out of order to be useful. Existing handlers are run afterwards.

111− handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def

106+ handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def

112107

113108 let initializeCallbacks = LSP.InitializeCallbacks

114− { LSP.onInitialConfiguration = onInitialConfig

115− , LSP.onConfigurationChange = onConfigChange

109+ { LSP.onInitialConfiguration = const $ Right ()

110+ , LSP.onConfigurationChange = const $ Right ()

116111 , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan

117112 }

118113

@@ -127,11 +122,9 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

127122 , void $ waitBarrier clientMsgBarrier

128123 ]

129124 where

130− handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan (Message config) -> LSP.LspFuncs config -> IO (Maybe err)

125+ handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs () -> IO (Maybe err)

131126 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do

132−

133127 ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities

134−

135128 _ <- flip forkFinally (const exitClientMsg) $ forever $ do

136129 msg <- readChan clientMsgChan

137130 case msg of

@@ -142,25 +135,17 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

142135 "Message: " ++ show x ++ "\n" ++

143136 "Exception: " ++ show e

144137 Response x@RequestMessage{_id, _params} wrap act ->

145− checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

146− \case

147− Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)

148− Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)

138+ checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

139+ \res -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing

149140 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->

150141 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

151142 \(res, newReq) -> 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

143+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing

144+ case newReq of

145+ Nothing -> return ()

146+ Just (rm, newReqParams) -> do

156147 reqId <- getNextReqId

157148 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

164149 pure Nothing

165150

166151 checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =

@@ -175,39 +160,28 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

175160 Left () -> do

176161 logDebug (ideLogger ide) $ T.pack $

177162 "Cancelled request " <> show _id

178− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left

179− $ ResponseError RequestCancelled "" Nothing

163+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $

164+ Just $ ResponseError RequestCancelled "" Nothing

180165 Right res -> k res

181166 ) $ \(e :: SomeException) -> do

182167 logError (ideLogger ide) $ T.pack $

183168 "Unexpected exception on request, please report!\n" ++

184169 "Message: " ++ show msg ++ "\n" ++

185170 "Exception: " ++ show e

186− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left

187− $ ResponseError InternalError (T.pack $ show e) Nothing

171+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $

172+ Just $ ResponseError InternalError (T.pack $ show e) Nothing

188173

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)

200174

201175-- | Things that get sent to us, but we don't deal with.

202176-- Set them to avoid a warning in VS Code output.

203−setHandlersIgnore :: PartialHandlers config

177+setHandlersIgnore :: PartialHandlers

204178setHandlersIgnore = PartialHandlers $ \_ x -> return x

205179 {LSP.initializedHandler = none

206180 ,LSP.responseHandler = none

207181 }

208182 where none = Just $ const $ return ()

209183

210−cancelHandler :: (LspId -> IO ()) -> PartialHandlers config

184+cancelHandler :: (LspId -> IO ()) -> PartialHandlers

211185cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x

212186 {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do

213187 cancelRequest _id

@@ -217,18 +191,18 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x

217191

218192-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety

219193-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)

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))

194+data Message

195+ = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO resp)

222196 -- | Used for cases in which we need to send not only a response,

223197 -- but also an additional request to the client.

224198 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.

225− | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))

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 ())

199+ | 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)))

200+ | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ())

201+

229202

230203modifyOptions :: LSP.Options -> LSP.Options

231204modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS

205+ , LSP.executeCommandCommands = Just ["typesignature.add"]

232206 }

233207 where

234208 tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}

src/Development/IDE/LSP/Notifications.hs+13−39

@@ -2,37 +2,32 @@

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 Development.IDE.LSP.Server

12−import qualified Language.Haskell.LSP.Core as LSP

1311import Language.Haskell.LSP.Types

14−import qualified Language.Haskell.LSP.Types as LSP

12+import Development.IDE.LSP.Server

13+import qualified Language.Haskell.LSP.Core as LSP

14+import qualified Language.Haskell.LSP.Types as LSP

1515

16−import Development.IDE.Core.IdeConfiguration

17−import Development.IDE.Core.Service

18−import Development.IDE.Types.Location

19−import Development.IDE.Types.Logger

16+import Development.IDE.Types.Logger

17+import Development.IDE.Core.Service

18+import Development.IDE.Types.Location

2019

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

20+import Control.Monad.Extra

21+import qualified Data.Set as S

2622

27−import Development.IDE.Core.FileStore (setSomethingModified)

28−import Development.IDE.Core.FileExists (modifyFileExists)

29−import Development.IDE.Core.OfInterest

23+import Development.IDE.Core.FileStore

24+import Development.IDE.Core.OfInterest

3025

3126

3227whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()

33−whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'

28+whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath

3429

35−setHandlersNotifications :: PartialHandlers c

30+setHandlersNotifications :: PartialHandlers

3631setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x

3732 {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $

3833 \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do

@@ -57,25 +52,4 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x

5752 whenUriFile _uri $ \file -> do

5853 modifyFilesOfInterest ide (S.delete file)

5954 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))

8155 }

src/Development/IDE/LSP/Outline.hsdeleted−234

@@ -1,234 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DuplicateRecordFields #-}

3−#include "ghc-api-version.h"

4−

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+10−11

@@ -16,32 +16,31 @@ import qualified Language.Haskell.LSP.Core as LSP

1616import qualified Language.Haskell.LSP.Messages as LSP

1717import Development.IDE.Core.Service

1818

19−data WithMessage c = WithMessage

19+

20+data WithMessage = WithMessage

2021 {withResponse :: forall m req resp . (Show m, Show req) =>

2122 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

22− (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work

23+ (LSP.LspFuncs () -> IdeState -> req -> IO resp) -> -- actual work

2324 Maybe (LSP.Handler (RequestMessage m req resp))

2425 ,withNotification :: forall m req . (Show m, Show req) =>

2526 Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler

26− (LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work

27+ (LSP.LspFuncs () -> IdeState -> req -> IO ()) -> -- actual work

2728 Maybe (LSP.Handler (NotificationMessage m req))

28− ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody .

29+ ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.

2930 (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>

3031 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

3132 (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req

32− (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work

33+ (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work

3334 Maybe (LSP.Handler (RequestMessage m req resp))

34− , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())

35− -> Maybe (LSP.Handler InitializeRequest)

3635 }

3736

38−newtype PartialHandlers c = PartialHandlers (WithMessage c -> LSP.Handlers -> IO LSP.Handlers)

37+newtype PartialHandlers = PartialHandlers (WithMessage -> LSP.Handlers -> IO LSP.Handlers)

3938

40−instance Default (PartialHandlers c) where

39+instance Default PartialHandlers where

4140 def = PartialHandlers $ \_ x -> pure x

4241

43−instance Semigroup (PartialHandlers c) where

42+instance Semigroup PartialHandlers where

4443 PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w

4544

46−instance Monoid (PartialHandlers c) where

45+instance Monoid PartialHandlers where

4746 mempty = def

src/Development/IDE/Plugin.hsdeleted−60

@@ -1,60 +0,0 @@

1−

2−module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules,makeLspCommandId,getPid) where

3−

4−import Data.Default

5−import qualified Data.Text as T

6−import Development.Shake

7−import Development.IDE.LSP.Server

8−

9−import Language.Haskell.LSP.Types

10−import Development.IDE.Compat

11−import Development.IDE.Core.Rules

12−import qualified Language.Haskell.LSP.Core as LSP

13−import Language.Haskell.LSP.Messages

14−

15−

16−data Plugin c = Plugin

17− {pluginRules :: Rules ()

18− ,pluginHandler :: PartialHandlers c

19− }

20−

21−instance Default (Plugin c) where

22− def = Plugin mempty def

23−

24−instance Semigroup (Plugin c) where

25− Plugin x1 y1 <> Plugin x2 y2 = Plugin (x1<>x2) (y1<>y2)

26−

27−instance Monoid (Plugin c) where

28− mempty = def

29−

30−

31−codeActionPlugin :: (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c

32−codeActionPlugin = codeActionPluginWithRules mempty

33−

34−codeActionPluginWithRules :: Rules () -> (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c

35−codeActionPluginWithRules rr f = Plugin rr $ PartialHandlers $ \WithMessage{..} x -> return x{

36− LSP.codeActionHandler = withResponse RspCodeAction g

37− }

38− where

39− g lsp state (CodeActionParams a b c _) = fmap List <$> f lsp state a b c

40−

41−-- | Prefix to uniquely identify commands sent to the client. This

42−-- has two parts

43−--

44−-- - A representation of the process id to make sure that a client has

45−-- unique commands if it is running multiple servers, since some

46−-- clients have a global command table and get confused otherwise.

47−--

48−-- - A string to identify ghcide, to ease integration into

49−-- haskell-language-server, which routes commands to plugins based

50−-- on that.

51−makeLspCommandId :: T.Text -> IO T.Text

52−makeLspCommandId command = do

53− pid <- getPid

54− return $ pid <> ":ghcide:" <> command

55−

56−-- | Get the operating system process id for the running server

57−-- instance. This should be the same for the lifetime of the instance,

58−-- and different from that of any other currently running instance.

59−getPid :: IO T.Text

60−getPid = T.pack . show <$> getProcessID

src/Development/IDE/Plugin/CodeAction.hsdeleted−570

@@ -1,570 +0,0 @@

2−-- SPDX-License-Identifier: Apache-2.0

3−

4−{-# LANGUAGE DuplicateRecordFields #-}

5−{-# LANGUAGE CPP #-}

6−#include "ghc-api-version.h"

7−

8−-- | Go to the definition of a variable.

9−module Development.IDE.Plugin.CodeAction

10− (

11− plugin

12−

13− -- * For haskell-language-server

14− , codeAction

15− , codeLens

16− , rulePackageExports

17− , executeAddSignatureCommand

18− ) where

19−

20−import Language.Haskell.LSP.Types

21−import Control.Monad (join)

22−import Development.IDE.Plugin

23−import Development.IDE.GHC.Compat

24−import Development.IDE.Core.Rules

25−import Development.IDE.Core.RuleTypes

26−import Development.IDE.Core.Service

27−import Development.IDE.Core.Shake

28−import Development.IDE.GHC.Error

29−import Development.IDE.GHC.Util

30−import Development.IDE.LSP.Server

31−import Development.IDE.Plugin.CodeAction.PositionIndexed

32−import Development.IDE.Plugin.CodeAction.RuleTypes

33−import Development.IDE.Plugin.CodeAction.Rules

34−import Development.IDE.Types.Location

35−import Development.IDE.Types.Options

36−import Development.Shake (Rules)

37−import qualified Data.HashMap.Strict as Map

38−import qualified Language.Haskell.LSP.Core as LSP

39−import Language.Haskell.LSP.VFS

40−import Language.Haskell.LSP.Messages

41−import qualified Data.Rope.UTF16 as Rope

42−import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))

43−import Control.Monad.Trans.Maybe

44−import Data.Char

45−import Data.Maybe

46−import Data.List.Extra

47−import qualified Data.Text as T

48−import Data.Tuple.Extra ((&&&))

49−import HscTypes

50−import Parser

51−import Text.Regex.TDFA ((=~), (=~~))

52−import Text.Regex.TDFA.Text()

53−import Outputable (ppr, showSDocUnsafe)

54−import DynFlags (xFlags, FlagSpec(..))

55−import GHC.LanguageExtensions.Type (Extension)

56−

57−plugin :: Plugin c

58−plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens

59−

60−rules :: Rules ()

61−rules = rulePackageExports

62−

63−-- | Generate code actions.

64−codeAction

65− :: LSP.LspFuncs c

66− -> IdeState

67− -> TextDocumentIdentifier

68− -> Range

69− -> CodeActionContext

70− -> IO (Either ResponseError [CAResult])

71−codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do

72− -- disable logging as its quite verbose

73− -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg

74− contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri

75− let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents

76− mbFile = toNormalizedFilePath' <$> uriToFilePath uri

77− (ideOptions, parsedModule, join -> env) <- runAction state $

78− (,,) <$> getIdeOptions

79− <*> getParsedModule `traverse` mbFile

80− <*> use GhcSession `traverse` mbFile

81− pkgExports <- runAction state $ (useNoFile_ . PackageExports) `traverse` env

82− let dflags = hsc_dflags . hscEnv <$> env

83− pure $ Right

84− [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing

85− | x <- xs, (title, tedit) <- suggestAction dflags (fromMaybe mempty pkgExports) ideOptions ( join parsedModule ) text x

86− , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

87− ]

88−

89−-- | Generate code lenses.

90−codeLens

91− :: LSP.LspFuncs c

92− -> IdeState

93− -> CodeLensParams

94− -> IO (Either ResponseError (List CodeLens))

95−codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do

96− commandId <- makeLspCommandId "typesignature.add"

97− fmap (Right . List) $ case uriToFilePath' uri of

98− Just (toNormalizedFilePath' -> filePath) -> do

99− _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath

100− diag <- getDiagnostics ideState

101− hDiag <- getHiddenDiagnostics ideState

102− pure

103− [ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing

104− | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag

105− , dFile == filePath

106− , (title, tedit) <- suggestSignature False dDiag

107− , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

108− ]

109− Nothing -> pure []

110−

111−-- | Execute the "typesignature.add" command.

112−executeAddSignatureCommand

113− :: LSP.LspFuncs c

114− -> IdeState

115− -> ExecuteCommandParams

116− -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

117−executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}

118− -- _command is prefixed with a process ID, because certain clients

119− -- have a global command registry, and all commands must be

120− -- unique. And there can be more than one ghcide instance running

121− -- at a time against the same client.

122− | T.isSuffixOf "typesignature.add" _command

123− , Just (List [edit]) <- _arguments

124− , Success wedit <- fromJSON edit

125− = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))

126− | otherwise

127− = return (Right Null, Nothing)

128−

129−suggestAction

130− :: Maybe DynFlags

131− -> PackageExportsMap

132− -> IdeOptions

133− -> Maybe ParsedModule

134− -> Maybe T.Text

135− -> Diagnostic

136− -> [(T.Text, [TextEdit])]

137−suggestAction dflags packageExports ideOptions parsedModule text diag = concat

138− [ suggestAddExtension diag

139− , suggestExtendImport dflags text diag

140− , suggestFillHole diag

141− , suggestFillTypeWildcard diag

142− , suggestFixConstructorImport text diag

143− , suggestModuleTypo diag

144− , suggestReplaceIdentifier text diag

145− , suggestSignature True diag

146− ] ++ concat

147− [ suggestNewDefinition ideOptions pm text diag

148− ++ suggestRemoveRedundantImport pm text diag

149− ++ suggestNewImport packageExports pm diag

150− | Just pm <- [parsedModule]]

151−

152−

153−suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

154−suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..}

155−-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant

156− | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"

157− , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports

158− , Just c <- contents

159− , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)

160− , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)

161− , not (null ranges')

162− = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]

163−

164−-- File.hs:16:1: warning:

165−-- The import of `Data.List' is redundant

166−-- except perhaps to import instances from `Data.List'

167−-- To import instances alone, use: import Data.List()

168− | _message =~ ("The( qualified)? import of [^ ]* is redundant" :: String)

169− = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]

170− | otherwise = []

171−

172−suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

173−suggestReplaceIdentifier contents Diagnostic{_range=_range,..}

174−-- File.hs:52:41: error:

175−-- * Variable not in scope:

176−-- suggestAcion :: Maybe T.Text -> Range -> Range

177−-- * Perhaps you meant ‘suggestAction’ (line 83)

178−-- File.hs:94:37: error:

179−-- Not in scope: ‘T.isPrfixOf’

180−-- Perhaps you meant one of these:

181−-- ‘T.isPrefixOf’ (imported from Data.Text),

182−-- ‘T.isInfixOf’ (imported from Data.Text),

183−-- ‘T.isSuffixOf’ (imported from Data.Text)

184−-- Module ‘Data.Text’ does not export ‘isPrfixOf’.

185− | renameSuggestions@(_:_) <- extractRenamableTerms _message

186− = [ ("Replace with ‘" <> name <> "’", [mkRenameEdit contents _range name]) | name <- renameSuggestions ]

187− | otherwise = []

188−

189−suggestNewDefinition :: IdeOptions -> ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

190−suggestNewDefinition ideOptions parsedModule contents Diagnostic{_message, _range}

191−-- * Variable not in scope:

192−-- suggestAcion :: Maybe T.Text -> Range -> Range

193− | Just [name, typ] <- matchRegex message "Variable not in scope: ([^ ]+) :: ([^*•]+)"

194− = newDefinitionAction ideOptions parsedModule _range name typ

195− | Just [name, typ] <- matchRegex message "Found hole: _([^ ]+) :: ([^*•]+) Or perhaps"

196− , [(label, newDefinitionEdits)] <- newDefinitionAction ideOptions parsedModule _range name typ

197− = [(label, mkRenameEdit contents _range name : newDefinitionEdits)]

198− | otherwise = []

199− where

200− message = unifySpaces _message

201−

202−newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text -> [(T.Text, [TextEdit])]

203−newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ

204− | Range _ lastLineP : _ <-

205− [ srcSpanToRange l

206− | (L l _) <- hsmodDecls

207− , _start `isInsideSrcSpan` l]

208− , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0}

209− = [ ("Define " <> sig

210− , [TextEdit (Range nextLineP nextLineP) (T.unlines ["", sig, name <> " = error \"not implemented\""])]

211− )]

212− | otherwise = []

213− where

214− colon = if optNewColonConvention then " : " else " :: "

215− sig = name <> colon <> T.dropWhileEnd isSpace typ

216− ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls}} = parsedModule

217−

218−

219−suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]

220−suggestFillTypeWildcard Diagnostic{_range=_range,..}

221−-- Foo.hs:3:8: error:

222−-- * Found type wildcard `_' standing for `p -> p1 -> p'

223−

224− | "Found type wildcard" `T.isInfixOf` _message

225− , " standing for " `T.isInfixOf` _message

226− , typeSignature <- extractWildCardTypeSignature _message

227− = [("Use type signature: ‘" <> typeSignature <> "’", [TextEdit _range typeSignature])]

228− | otherwise = []

229−

230−suggestAddExtension :: Diagnostic -> [(T.Text, [TextEdit])]

231−suggestAddExtension Diagnostic{_range=_range,..}

232−-- File.hs:22:8: error:

233−-- Illegal lambda-case (use -XLambdaCase)

234−-- File.hs:22:6: error:

235−-- Illegal view pattern: x -> foo

236−-- Use ViewPatterns to enable view patterns

237−-- File.hs:26:8: error:

238−-- Illegal `..' in record pattern

239−-- Use RecordWildCards to permit this

240−-- File.hs:53:28: error:

241−-- Illegal tuple section: use TupleSections

242−-- File.hs:238:29: error:

243−-- * Can't make a derived instance of `Data FSATrace':

244−-- You need DeriveDataTypeable to derive an instance for this class

245−-- * In the data declaration for `FSATrace'

246−-- C:\Neil\shake\src\Development\Shake\Command.hs:515:31: error:

247−-- * Illegal equational constraint a ~ ()

248−-- (Use GADTs or TypeFamilies to permit this)

249−-- * In the context: a ~ ()

250−-- While checking an instance declaration

251−-- In the instance declaration for `Unit (m a)'

252− | exts@(_:_) <- filter (`Map.member` ghcExtensions) $ T.split (not . isAlpha) $ T.replace "-X" "" _message

253− = [("Add " <> x <> " extension", [TextEdit (Range (Position 0 0) (Position 0 0)) $ "{-# LANGUAGE " <> x <> " #-}\n"]) | x <- exts]

254− | otherwise = []

255−

256−-- | All the GHC extensions

257−ghcExtensions :: Map.HashMap T.Text Extension

258−ghcExtensions = Map.fromList . map ( ( T.pack . flagSpecName ) &&& flagSpecFlag ) $ xFlags

259−

260−suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]

261−suggestModuleTypo Diagnostic{_range=_range,..}

262−-- src/Development/IDE/Core/Compile.hs:58:1: error:

263−-- Could not find module ‘Data.Cha’

264−-- Perhaps you meant Data.Char (from base-4.12.0.0)

265− | "Could not find module" `T.isInfixOf` _message

266− , "Perhaps you meant" `T.isInfixOf` _message = let

267− findSuggestedModules = map (head . T.words) . drop 2 . T.lines

268− proposeModule mod = ("replace with " <> mod, [TextEdit _range mod])

269− in map proposeModule $ nubOrd $ findSuggestedModules _message

270− | otherwise = []

271−

272−suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])]

273−suggestFillHole Diagnostic{_range=_range,..}

274−-- ...Development/IDE/LSP/CodeAction.hs:103:9: warning:

275−-- * Found hole: _ :: Int -> String

276−-- * In the expression: _

277−-- In the expression: _ a

278−-- In an equation for ‘foo’: foo a = _ a

279−-- * Relevant bindings include

280−-- a :: Int

281−-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:5)

282−-- foo :: Int -> String

283−-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)

284−-- Valid hole fits include

285−-- foo :: Int -> String

286−-- (bound at ...Development/IDE/LSP/CodeAction.hs:103:1)

287−-- show :: forall a. Show a => a -> String

288−-- with show @Int

289−-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37

290−-- (and originally defined in ‘GHC.Show’))

291−-- mempty :: forall a. Monoid a => a

292−-- with mempty @(Int -> String)

293−-- (imported from ‘Prelude’ at ...Development/IDE/LSP/CodeAction.hs:7:8-37

294−-- (and originally defined in ‘GHC.Base’)) (lsp-ui)

295−

296− | topOfHoleFitsMarker `T.isInfixOf` _message = let

297− findSuggestedHoleFits :: T.Text -> [T.Text]

298− findSuggestedHoleFits = extractFitNames . selectLinesWithFits . dropPreceding . T.lines

299− proposeHoleFit name = ("replace hole `" <> holeName <> "` with " <> name, [TextEdit _range name])

300− holeName = T.strip $ last $ T.splitOn ":" $ head . T.splitOn "::" $ head $ filter ("Found hole" `T.isInfixOf`) $ T.lines _message

301− dropPreceding = dropWhile (not . (topOfHoleFitsMarker `T.isInfixOf`))

302− selectLinesWithFits = filter ("::" `T.isInfixOf`)

303− extractFitNames = map (T.strip . head . T.splitOn " :: ")

304− in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message

305−

306− | otherwise = []

307−

308−suggestExtendImport :: Maybe DynFlags -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

309−suggestExtendImport (Just dflags) contents Diagnostic{_range=_range,..}

310− | Just [binding, mod, srcspan] <-

311− matchRegex _message

312− "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\$(.*)\$.$"

313− , Just c <- contents

314− , POk _ (L _ name) <- runParser dflags (T.unpack binding) parseIdentifier

315− = let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of

316− [s] -> let x = srcSpanToRange s

317− in x{_end = (_end x){_character = succ (_character (_end x))}}

318− _ -> error "bug in srcspan parser"

319− importLine = textInRange range c

320− in [("Add " <> binding <> " to the import list of " <> mod

321− , [TextEdit range (addBindingToImportList (T.pack $ printRdrName name) importLine)])]

322− | otherwise = []

323−suggestExtendImport Nothing _ _ = []

324−

325−suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

326−suggestFixConstructorImport _ Diagnostic{_range=_range,..}

327− -- ‘Success’ is a data constructor of ‘Result’

328− -- To import it use

329− -- import Data.Aeson.Types( Result( Success ) )

330− -- or

331− -- import Data.Aeson.Types( Result(..) ) (lsp-ui)

332− | Just [constructor, typ] <-

333− matchRegex _message

334− "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use"

335− = let fixedImport = typ <> "(" <> constructor <> ")"

336− in [("Fix import of " <> fixedImport, [TextEdit _range fixedImport])]

337− | otherwise = []

338−

339−suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]

340−suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}

341− | _message =~

342− ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) = let

343− signature = removeInitialForAll

344− $ T.takeWhile (\x -> x/='*' && x/='•')

345− $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message

346− startOfLine = Position (_line _start) startCharacter

347− beforeLine = Range startOfLine startOfLine

348− title = if isQuickFix then "add signature: " <> signature else signature

349− action = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " "

350− in [(title, [action])]

351− where removeInitialForAll :: T.Text -> T.Text

352− removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))

353− | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))

354− | otherwise = nm <> ty

355− startCharacter

356− | "Polymorphic local binding" `T.isPrefixOf` _message

357− = _character _start

358− | otherwise

359− = 0

360−

361−suggestSignature _ _ = []

362−

363−-------------------------------------------------------------------------------------------------

364−

365−suggestNewImport :: PackageExportsMap -> ParsedModule -> Diagnostic -> [(T.Text, [TextEdit])]

366−suggestNewImport packageExportsMap ParsedModule {pm_parsed_source = L _ HsModule {..}} Diagnostic{_message}

367− | msg <- unifySpaces _message

368− , Just name <- extractNotInScopeName msg

369− , Just insertLine <- case hsmodImports of

370− [] -> case srcSpanStart $ getLoc (head hsmodDecls) of

371− RealSrcLoc s -> Just $ srcLocLine s - 1

372− _ -> Nothing

373− _ -> case srcSpanEnd $ getLoc (last hsmodImports) of

374− RealSrcLoc s -> Just $ srcLocLine s

375− _ -> Nothing

376− , insertPos <- Position insertLine 0

377− , extendImportSuggestions <- matchRegex msg

378− "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"

379− = [(imp, [TextEdit (Range insertPos insertPos) (imp <> "\n")])

380− | imp <- constructNewImportSuggestions packageExportsMap name extendImportSuggestions

381− ]

382−suggestNewImport _ _ _ = []

383−

384−constructNewImportSuggestions

385− :: PackageExportsMap -> NotInScope -> Maybe [T.Text] -> [T.Text]

386−constructNewImportSuggestions exportsMap thingMissing notTheseModules = nubOrd

387− [ renderNewImport identInfo m

388− | (identInfo, m) <- fromMaybe [] $ Map.lookup name exportsMap

389− , canUseIdent thingMissing identInfo

390− , m `notElem` fromMaybe [] notTheseModules

391− ]

392− where

393− renderNewImport identInfo m

394− | Just q <- qual = "import qualified " <> m <> " as " <> q

395− | otherwise = "import " <> m <> " (" <> importWhat identInfo <> ")"

396−

397− (qual, name) = case T.splitOn "." (notInScope thingMissing) of

398− [n] -> (Nothing, n)

399− segments -> (Just (T.concat $ init segments), last segments)

400− importWhat IdentInfo {parent, rendered}

401− | Just p <- parent = p <> "(" <> rendered <> ")"

402− | otherwise = rendered

403−

404−canUseIdent :: NotInScope -> IdentInfo -> Bool

405−canUseIdent NotInScopeDataConstructor{} = isDatacon

406−canUseIdent _ = const True

407−

408−data NotInScope

409− = NotInScopeDataConstructor T.Text

410− | NotInScopeTypeConstructorOrClass T.Text

411− | NotInScopeThing T.Text

412− deriving Show

413−

414−notInScope :: NotInScope -> T.Text

415−notInScope (NotInScopeDataConstructor t) = t

416−notInScope (NotInScopeTypeConstructorOrClass t) = t

417−notInScope (NotInScopeThing t) = t

418−

419−extractNotInScopeName :: T.Text -> Maybe NotInScope

420−extractNotInScopeName x

421− | Just [name] <- matchRegex x "Data constructor not in scope: ([^ ]+)"

422− = Just $ NotInScopeDataConstructor name

423− | Just [name] <- matchRegex x "Not in scope: data constructor [^‘]*‘([^’]*)’"

424− = Just $ NotInScopeDataConstructor name

425− | Just [name] <- matchRegex x "ot in scope: type constructor or class [^‘]*‘([^’]*)’"

426− = Just $ NotInScopeTypeConstructorOrClass name

427− | Just [name] <- matchRegex x "ot in scope: \$([^‘ ]+)\$"

428− = Just $ NotInScopeThing name

429− | Just [name] <- matchRegex x "ot in scope: ([^‘ ]+)"

430− = Just $ NotInScopeThing name

431− | Just [name] <- matchRegex x "ot in scope:[^‘]*‘([^’]*)’"

432− = Just $ NotInScopeThing name

433− | otherwise

434− = Nothing

435−

436−-------------------------------------------------------------------------------------------------

437−

438−topOfHoleFitsMarker :: T.Text

439−topOfHoleFitsMarker =

440−#if MIN_GHC_API_VERSION(8,6,0)

441− "Valid hole fits include"

442−#else

443− "Valid substitutions include"

444−#endif

445−

446−mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit

447−mkRenameEdit contents range name =

448− if maybeIsInfixFunction == Just True

449− then TextEdit range ("`" <> name <> "`")

450− else TextEdit range name

451− where

452− maybeIsInfixFunction = do

453− curr <- textInRange range <$> contents

454− pure $ "`" `T.isPrefixOf` curr && "`" `T.isSuffixOf` curr

455−

456−extractWildCardTypeSignature :: T.Text -> T.Text

457−extractWildCardTypeSignature =

458− -- inferring when parens are actually needed around the type signature would

459− -- require understanding both the precedence of the context of the _ and of

460− -- the signature itself. Inserting them unconditionally is ugly but safe.

461− ("(" `T.append`) . (`T.append` ")") .

462− T.takeWhile (/='’') . T.dropWhile (=='‘') . T.dropWhile (/='‘') .

463− snd . T.breakOnEnd "standing for "

464−

465−extractRenamableTerms :: T.Text -> [T.Text]

466−extractRenamableTerms msg

467− -- Account for both "Variable not in scope" and "Not in scope"

468− | "ot in scope:" `T.isInfixOf` msg = extractSuggestions msg

469− | otherwise = []

470− where

471− extractSuggestions = map getEnclosed

472− . concatMap singleSuggestions

473− . filter isKnownSymbol

474− . T.lines

475− singleSuggestions = T.splitOn "), " -- Each suggestion is comma delimited

476− isKnownSymbol t = " (imported from" `T.isInfixOf` t || " (line " `T.isInfixOf` t

477− getEnclosed = T.dropWhile (== '‘')

478− . T.dropWhileEnd (== '’')

479− . T.dropAround (\c -> c /= '‘' && c /= '’')

480−

481−-- | If a range takes up a whole line (it begins at the start of the line and there's only whitespace

482−-- between the end of the range and the next newline), extend the range to take up the whole line.

483−extendToWholeLineIfPossible :: Maybe T.Text -> Range -> Range

484−extendToWholeLineIfPossible contents range@Range{..} =

485− let newlineAfter = maybe False (T.isPrefixOf "\n" . T.dropWhile (\x -> isSpace x && x /= '\n') . snd . splitTextAtPosition _end) contents

486− extend = newlineAfter && _character _start == 0 -- takes up an entire line, so remove the whole line

487− in if extend then Range _start (Position (_line _end + 1) 0) else range

488−

489−splitTextAtPosition :: Position -> T.Text -> (T.Text, T.Text)

490−splitTextAtPosition (Position row col) x

491− | (preRow, mid:postRow) <- splitAt row $ T.splitOn "\n" x

492− , (preCol, postCol) <- T.splitAt col mid

493− = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)

494− | otherwise = (x, T.empty)

495−

496−-- | Returns [start .. end[

497−textInRange :: Range -> T.Text -> T.Text

498−textInRange (Range (Position startRow startCol) (Position endRow endCol)) text =

499− case compare startRow endRow of

500− LT ->

501− let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine

502− (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of

503− [] -> ("", [])

504− firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)

505− maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines

506− in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)

507− EQ ->

508− let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)

509− in T.take (endCol - startCol) (T.drop startCol line)

510− GT -> ""

511− where

512− linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)

513−

514−-- | Returns the ranges for a binding in an import declaration

515−rangesForBinding :: ImportDecl GhcPs -> String -> [Range]

516−rangesForBinding ImportDecl{ideclHiding = Just (False, L _ lies)} b =

517− concatMap (map srcSpanToRange . rangesForBinding' b') lies

518− where

519− b' = wrapOperatorInParens (unqualify b)

520−

521− wrapOperatorInParens x = if isAlpha (head x) then x else "(" <> x <> ")"

522−

523− unqualify x = snd $ breakOnEnd "." x

524−

525−rangesForBinding _ _ = []

526−

527−rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]

528−rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]

529−rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]

530−rangesForBinding' b (L l (IEThingAll x)) | showSDocUnsafe (ppr x) == b = [l]

531−rangesForBinding' b (L l (IEThingWith thing _ inners labels))

532− | showSDocUnsafe (ppr thing) == b = [l]

533− | otherwise =

534− [ l' | L l' x <- inners, showSDocUnsafe (ppr x) == b] ++

535− [ l' | L l' x <- labels, showSDocUnsafe (ppr x) == b]

536−rangesForBinding' _ _ = []

537−

538−-- | Extends an import list with a new binding.

539−-- Assumes an import statement of the form:

540−-- import (qualified) A (..) ..

541−-- Places the new binding first, preserving whitespace.

542−-- Copes with multi-line import lists

543−addBindingToImportList :: T.Text -> T.Text -> T.Text

544−addBindingToImportList binding importLine = case T.breakOn "(" importLine of

545− (pre, T.uncons -> Just (_, rest)) ->

546− case T.uncons (T.dropWhile isSpace rest) of

547− Just (')', _) -> T.concat [pre, "(", binding, rest]

548− _ -> T.concat [pre, "(", binding, ", ", rest]

549− _ ->

550− error

551− $ "importLine does not have the expected structure: "

552− <> T.unpack importLine

553−

554−-- | Returns Just (the submatches) for the first capture, or Nothing.

555−matchRegex :: T.Text -> T.Text -> Maybe [T.Text]

556−matchRegex message regex = case unifySpaces message =~~ regex of

557− Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings

558− Nothing -> Nothing

559−

560−setHandlersCodeLens :: PartialHandlers c

561−setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{

562− LSP.codeLensHandler = withResponse RspCodeLens codeLens,

563− LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand

564− }

565−

566−filterNewlines :: T.Text -> T.Text

567−filterNewlines = T.concat . T.lines

568−

569−unifySpaces :: T.Text -> T.Text

570−unifySpaces = T.unwords . T.words

src/Development/IDE/Plugin/CodeAction/PositionIndexed.hsdeleted−112

@@ -1,112 +0,0 @@

1−-- | Position indexed streams of characters

2−module Development.IDE.Plugin.CodeAction.PositionIndexed

3− ( PositionIndexed

4− , PositionIndexedString

5− , indexedByPosition

6− , indexedByPositionStartingFrom

7− , extendAllToIncludeCommaIfPossible

8− , mergeRanges

9− )

10−where

11−

12−import Data.Char

13−import Data.List

14−import Language.Haskell.LSP.Types

15−

16−type PositionIndexed a = [(Position, a)]

17−

18−type PositionIndexedString = PositionIndexed Char

19−

20−-- | Add position indexing to a String.

21−--

22−-- > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡

23−-- > [ ((0,0),'h')

24−-- > , ((0,1),'e')

25−-- > , ((0,2),'y')

26−-- > , ((0,3),'\n')

27−-- > , ((1,0),' ')

28−-- > , ((1,1),'h')

29−-- > , ((1,2),'o')

30−-- > ]

31−indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString

32−indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where

33− f (_, []) = Nothing

34− f (p@(Position l _), '\n' : rest) =

35− Just ((p, '\n'), (Position (l + 1) 0, rest))

36− f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest))

37−

38−-- | Add position indexing to a String.

39−--

40−-- > indexedByPosition = indexedByPositionStartingFrom (Position 0 0)

41−indexedByPosition :: String -> PositionIndexedString

42−indexedByPosition = indexedByPositionStartingFrom (Position 0 0)

43−

44−-- | Returns a tuple (before, contents, after) if the range is present.

45−-- The range is present only if both its start and end positions are present

46−unconsRange

47− :: Range

48− -> PositionIndexed a

49− -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a)

50−unconsRange Range {..} indexedString

51− | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString

52− , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest

53− = Just (before, mid, after)

54− | otherwise

55− = Nothing

56−

57−-- | Strips out all the positions included in the range.

58−-- Returns 'Nothing' if the start or end of the range are not included in the input.

59−stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a)

60−stripRange r s = case unconsRange r s of

61− Just (b, _, a) -> Just (b ++ a)

62− Nothing -> Nothing

63−

64−-- | Returns the smallest possible set of disjoint ranges that is equivalent to the input.

65−-- Assumes input ranges are sorted on the start positions.

66−mergeRanges :: [Range] -> [Range]

67−mergeRanges (r : r' : rest)

68− |

69− -- r' is contained in r

70− _end r > _end r' = mergeRanges (r : rest)

71− |

72− -- r and r' are overlapping

73− _end r > _start r' = mergeRanges (r { _end = _end r' } : rest)

74−

75− | otherwise = r : mergeRanges (r' : rest)

76−mergeRanges other = other

77−

78−-- | Returns a sorted list of ranges with extended selections including preceding or trailing commas

79−--

80−-- @

81−-- a, |b|, c ===> a|, b|, c

82−-- a, b, |c| ===> a, b|, c|

83−-- a, |b|, |c| ===> a|, b||, c|

84−-- @

85−extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]

86−extendAllToIncludeCommaIfPossible indexedString =

87− mergeRanges . go indexedString . sortOn _start

88− where

89− go _ [] = []

90− go input (r : rr)

91− | r' : _ <- extendToIncludeCommaIfPossible input r

92− , Just input' <- stripRange r' input

93− = r' : go input' rr

94− | otherwise

95− = go input rr

96−

97−extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]

98−extendToIncludeCommaIfPossible indexedString range

99− | Just (before, _, after) <- unconsRange range indexedString

100− , after' <- dropWhile (isSpace . snd) after

101− , before' <- dropWhile (isSpace . snd) (reverse before)

102− =

103− -- a, |b|, c ===> a|, b|, c

104− [ range { _start = start' } | (start', ',') : _ <- [before'] ]

105− ++

106− -- a, |b|, c ===> a, |b, |c

107− [ range { _end = end' }

108− | (_, ',') : rest <- [after']

109− , let (end', _) : _ = dropWhile (isSpace . snd) rest

110− ]

111− | otherwise

112− = [range]

src/Development/IDE/Plugin/CodeAction/RuleTypes.hsdeleted−61

@@ -1,61 +0,0 @@

1−{-# LANGUAGE TypeFamilies #-}

2−module Development.IDE.Plugin.CodeAction.RuleTypes

3− (PackageExports(..), PackageExportsMap

4− ,IdentInfo(..)

5− ,mkIdentInfos

6− ) where

7−

8−import Avail (AvailInfo(..))

9−import Data.Hashable (Hashable)

10−import Control.DeepSeq (NFData)

11−import Data.Binary (Binary)

12−import Data.Text (pack, Text)

13−import Development.IDE.GHC.Util

14−import Development.Shake (RuleResult)

15−import Data.HashMap.Strict (HashMap)

16−import Data.Typeable (Typeable)

17−import GHC.Generics (Generic)

18−import Name

19−import FieldLabel (flSelector)

20−

21−type Identifier = Text

22−type ModuleName = Text

23−

24−data IdentInfo = IdentInfo

25− { name :: !Identifier

26− , rendered :: Text

27− , parent :: !(Maybe Text)

28− , isDatacon :: !Bool

29− }

30− deriving (Eq, Generic, Show)

31−

32−instance NFData IdentInfo

33−

34−mkIdentInfos :: AvailInfo -> [IdentInfo]

35−mkIdentInfos (Avail n) =

36− [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)]

37−mkIdentInfos (AvailTC parent (n:nn) flds)

38− -- Following the GHC convention that parent == n if parent is exported

39− | n == parent

40− = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) True

41− | n <- nn ++ map flSelector flds

42− ] ++

43− [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing False]

44− where

45− parentP = pack $ prettyPrint parent

46−

47−mkIdentInfos (AvailTC _ nn flds)

48− = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing True

49− | n <- nn ++ map flSelector flds

50− ]

51−

52−-- Rule type for caching Package Exports

53−type instance RuleResult PackageExports = PackageExportsMap

54−type PackageExportsMap = HashMap Identifier [(IdentInfo,ModuleName)]

55−

56−newtype PackageExports = PackageExports HscEnvEq

57− deriving (Eq, Show, Typeable, Generic)

58−

59−instance Hashable PackageExports

60−instance NFData PackageExports

61−instance Binary PackageExports

src/Development/IDE/Plugin/CodeAction/Rules.hsdeleted−61

@@ -1,61 +0,0 @@

1−module Development.IDE.Plugin.CodeAction.Rules

2− ( rulePackageExports

3− )

4−where

5−

6−import Data.HashMap.Strict ( fromListWith )

7−import Data.Text ( Text

8− , pack

9− )

10−import Data.Traversable ( forM )

11−import Development.IDE.Core.Rules

12−import Development.IDE.GHC.Util

13−import Development.IDE.Plugin.CodeAction.RuleTypes

14−import Development.Shake

15−import GHC ( DynFlags(pkgState) )

16−import HscTypes ( IfaceExport

17− , hsc_dflags

18− , mi_exports

19− )

20−import LoadIface

21−import Maybes

22−import Module ( Module(..)

23− , ModuleName

24− , moduleNameString

25− )

26−import Packages ( explicitPackages

27− , exposedModules

28− , packageConfigId

29− )

30−import TcRnMonad ( WhereFrom(ImportByUser)

31− , initIfaceLoad

32− )

33−

34−rulePackageExports :: Rules ()

35−rulePackageExports = defineNoFile $ \(PackageExports session) -> do

36− let env = hscEnv session

37− pkgst = pkgState (hsc_dflags env)

38− depends = explicitPackages pkgst

39− targets =

40− [ (pkg, mn)

41− | d <- depends

42− , Just pkg <- [lookupPackageConfig d env]

43− , (mn, _) <- exposedModules pkg

44− ]

45−

46− results <- forM targets $ \(pkg, mn) -> do

47− modIface <- liftIO $ initIfaceLoad env $ loadInterface

48− ""

49− (Module (packageConfigId pkg) mn)

50− (ImportByUser False)

51− case modIface of

52− Failed _err -> return mempty

53− Succeeded mi -> do

54− let avails = mi_exports mi

55− return $ concatMap (unpackAvail mn) avails

56− return $ fromListWith (++) $ concat results

57−

58−unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])]

59−unpackAvail mod =

60− map (\id@IdentInfo {..} -> (name, [(id, pack $ moduleNameString mod)]))

61− . mkIdentInfos

src/Development/IDE/Plugin/Completions.hsdeleted−103

@@ -1,103 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE TypeFamilies #-}

3−#include "ghc-api-version.h"

4−

5−module Development.IDE.Plugin.Completions(plugin) where

6−

7−import Control.Applicative

8−import Language.Haskell.LSP.Messages

9−import Language.Haskell.LSP.Types

10−import qualified Language.Haskell.LSP.Core as LSP

11−import qualified Language.Haskell.LSP.VFS as VFS

12−import Language.Haskell.LSP.Types.Capabilities

13−import Development.Shake.Classes

14−import Development.Shake

15−import GHC.Generics

16−

17−import Development.IDE.Plugin

18−import Development.IDE.Core.Service

19−import Development.IDE.Plugin.Completions.Logic

20−import Development.IDE.Types.Location

21−import Development.IDE.Core.PositionMapping

22−import Development.IDE.Core.RuleTypes

23−import Development.IDE.Core.Shake

24−import Development.IDE.GHC.Util

25−import Development.IDE.LSP.Server

26−

27−#if !MIN_GHC_API_VERSION(8,6,0) || defined(GHC_LIB)

28−import Data.Maybe

29−import Development.IDE.Import.DependencyInformation

30−#endif

31−

32−plugin :: Plugin c

33−plugin = Plugin produceCompletions setHandlersCompletion

34−

35−produceCompletions :: Rules ()

36−produceCompletions =

37− define $ \ProduceCompletions file -> do

38−

39−-- When possible, rely on the haddocks embedded in our interface files

40−-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'

41−#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)

42− let parsedDeps = []

43−#else

44− deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file

45− parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)

46−#endif

47− tm <- fmap fst <$> useWithStale TypeCheck file

48− packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file

49− case (tm, packageState) of

50− (Just tm', Just packageState') -> do

51− cdata <- liftIO $ cacheDataProducer packageState'

52− (tmrModule tm') parsedDeps

53− return ([], Just cdata)

54− _ -> return ([], Nothing)

55−

56−

57−-- | Produce completions info for a file

58−type instance RuleResult ProduceCompletions = CachedCompletions

59−

60−data ProduceCompletions = ProduceCompletions

61− deriving (Eq, Show, Typeable, Generic)

62−instance Hashable ProduceCompletions

63−instance NFData ProduceCompletions

64−instance Binary ProduceCompletions

65−

66−

67−-- | Generate code actions.

68−getCompletionsLSP

69− :: LSP.LspFuncs c

70− -> IdeState

71− -> CompletionParams

72− -> IO (Either ResponseError CompletionResponseResult)

73−getCompletionsLSP lsp ide

74− CompletionParams{_textDocument=TextDocumentIdentifier uri

75− ,_position=position

76− ,_context=completionContext} = do

77− contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri

78− fmap Right $ case (contents, uriToFilePath' uri) of

79− (Just cnts, Just path) -> do

80− let npath = toNormalizedFilePath' path

81− (ideOpts, compls) <- runAction ide $ do

82− opts <- getIdeOptions

83− compls <- useWithStale ProduceCompletions npath

84− pm <- useWithStale GetParsedModule npath

85− pure (opts, liftA2 (,) compls pm)

86− case compls of

87− Just ((cci', _), (pm, mapping)) -> do

88− let !position' = fromCurrentPosition mapping position

89− pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'

90− case (pfix, completionContext) of

91− (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})

92− -> return (Completions $ List [])

93− (Just pfix', _) -> do

94− let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing

95− Completions . List <$> getCompletions ideOpts cci' pm pfix' fakeClientCapabilities (WithSnippets True)

96− _ -> return (Completions $ List [])

97− _ -> return (Completions $ List [])

98− _ -> return (Completions $ List [])

99−

100−setHandlersCompletion :: PartialHandlers c

101−setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{

102− LSP.completionHandler = withResponse RspCompletion getCompletionsLSP

103− }

src/Development/IDE/Plugin/Completions/Logic.hsdeleted−530

@@ -1,530 +0,0 @@

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.hsdeleted−58

@@ -1,58 +0,0 @@

1−module Development.IDE.Plugin.Completions.Types (

2− module Development.IDE.Plugin.Completions.Types

3−) where

4−

5−import Control.DeepSeq

6−import qualified Data.Map as Map

7−import qualified Data.Text as T

8−import GHC

9−

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+53−87

@@ -8,24 +8,26 @@ module Development.IDE.Spans.AtPoint (

88 , gotoDefinition

99 ) where

1010

11+import Development.IDE.Spans.Documentation

1112import Development.IDE.GHC.Error

1213import Development.IDE.GHC.Orphans()

1314import Development.IDE.Types.Location

1415

1516-- DAML compiler and infrastructure

17+import Development.Shake

18+import Development.IDE.GHC.Util

1619import Development.IDE.GHC.Compat

1720import Development.IDE.Types.Options

18−import Development.IDE.Spans.Type as SpanInfo

19−import Development.IDE.Spans.Common (spanDocToMarkdown)

21+import Development.IDE.Spans.Type as SpanInfo

2022

2123-- GHC API imports

24+import Avail

25+import GHC

2226import DynFlags

2327import FastString

2428import Name

2529import Outputable hiding ((<>))

2630import SrcLoc

27−import Type

28−import VarSet

2931

3032import Control.Monad.Extra

3133import Control.Monad.Trans.Maybe

@@ -37,134 +39,98 @@ import qualified Data.Text as T

3739-- | Locate the definition of the name at a given position.

3840gotoDefinition

3941 :: MonadIO m

40− => (Module -> m (Maybe (HieFile, FilePath)))

42+ => (FilePath -> m (Maybe HieFile))

4143 -> IdeOptions

44+ -> HscEnv

4245 -> [SpanInfo]

4346 -> Position

4447 -> m (Maybe Location)

45−gotoDefinition getHieFile ideOpts srcSpans pos =

46− listToMaybe <$> locationsAtPoint getHieFile ideOpts pos srcSpans

48+gotoDefinition getHieFile ideOpts pkgState srcSpans pos =

49+ listToMaybe <$> locationsAtPoint getHieFile ideOpts pkgState pos srcSpans

4750

4851-- | Synopsis for the name at a given position.

4952atPoint

5053 :: IdeOptions

51− -> SpansInfo

54+ -> [TypecheckedModule]

55+ -> [SpanInfo]

5256 -> Position

5357 -> Maybe (Maybe Range, [T.Text])

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)

58+atPoint IdeOptions{..} tcs srcSpans pos = do

59+ SpanInfo{..} <- listToMaybe $ orderSpans $ spansAtPoint pos srcSpans

60+ ty <- spaninfoType

61+ let mbName = getNameM spaninfoSource

62+ mbDefinedAt = fmap (\name -> "**Defined " <> T.pack (showSDocUnsafe $ pprNameDefnLoc name) <> "**\n") mbName

63+ docInfo = maybe [] (\name -> getDocumentation name tcs) mbName

64+ range = Range

65+ (Position spaninfoStartLine spaninfoStartCol)

66+ (Position spaninfoEndLine spaninfoEndCol)

67+ colon = if optNewColonConvention then ":" else "::"

68+ wrapLanguageSyntax x = T.unlines [ "```" <> T.pack optLanguageSyntax, x, "```"]

69+ typeSig = wrapLanguageSyntax $ case mbName of

70+ Nothing -> colon <> " " <> showName ty

71+ Just name ->

72+ let modulePrefix = maybe "" (<> ".") (getModuleNameAsText name)

73+ in modulePrefix <> showName name <> "\n " <> colon <> " " <> showName ty

74+ hoverInfo = docInfo <> [typeSig] <> maybeToList mbDefinedAt

75+ return (Just range, hoverInfo)

5876 where

59− -- Hover info for types, classes, type variables

60− hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs , ..} _ =

61− (wrapLanguageSyntax <$> name) <> location <> spanDocToMarkdown docs

62− where

63− name = [maybe shouldNotHappen showName mbName]

64− location = [maybe shouldNotHappen definedAt mbName]

65− shouldNotHappen = "ghcide: did not expect a type level component without a name"

66− mbName = getNameM spaninfoSource

67−

68− -- Hover info for values/data

69− hoverInfo SpanInfo{spaninfoType = (Just typ), spaninfoDocs = docs , ..} cnts =

70− (wrapLanguageSyntax <$> nameOrSource) <> location <> spanDocToMarkdown docs

71− where

72− mbName = getNameM spaninfoSource

73− expr = case spaninfoSource of

74− Named n -> qualifyNameIfPossible n

75− Lit l -> crop $ T.pack l

76− _ -> ""

77− nameOrSource = [expr <> "\n" <> typeAnnotation]

78− qualifyNameIfPossible name' = modulePrefix <> showName name'

79− where modulePrefix = maybe "" (<> ".") (getModuleNameAsText name')

80− location = [maybe "" definedAt mbName]

81−

82− thisFVs = tyCoVarsOfType typ

83− constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts

84− constraintsT = T.intercalate ", " (map showName constraintsOverFVs)

85−

86− typeAnnotation = case constraintsOverFVs of

87− [] -> colon <> showName typ

88− [_] -> colon <> constraintsT <> "\n=> " <> showName typ

89− _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ

90−

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

96−

97− range SpanInfo{..} = Range

98− (Position spaninfoStartLine spaninfoStartCol)

99− (Position spaninfoEndLine spaninfoEndCol)

100−

101− colon = if optNewColonConvention then ": " else ":: "

102− wrapLanguageSyntax x = T.unlines [ "```" <> T.pack optLanguageSyntax, x, "```"]

103−

10477 -- NOTE(RJR): This is a bit hacky.

10578 -- We don't want to show the user type signatures generated from Eq and Show

10679 -- instances, as they do not appear in the source program.

10780 -- However the user could have written an `==` or `show` function directly,

10881 -- in which case we still want to show information for that.

10982 -- Hence we just move such information later in the list of spans.

110− deEmpasizeGeneratedEqShow :: [SpanInfo] -> [SpanInfo]

111− deEmpasizeGeneratedEqShow = uncurry (++) . partition (not . isTypeclassDeclSpan)

83+ orderSpans :: [SpanInfo] -> [SpanInfo]

84+ orderSpans = uncurry (++) . partition (not . isTypeclassDeclSpan)

11285 isTypeclassDeclSpan :: SpanInfo -> Bool

11386 isTypeclassDeclSpan spanInfo =

11487 case getNameM (spaninfoSource spanInfo) of

11588 Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]

11689 Nothing -> False

11790

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 =

127− fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos

91+locationsAtPoint :: forall m . MonadIO m => (FilePath -> m (Maybe HieFile)) -> IdeOptions -> HscEnv -> Position -> [SpanInfo] -> m [Location]

92+locationsAtPoint getHieFile IdeOptions{..} pkgState pos =

93+ fmap (map srcSpanToLocation) .

94+ mapMaybeM (getSpan . spaninfoSource) .

95+ spansAtPoint pos

12896 where getSpan :: SpanSource -> m (Maybe SrcSpan)

12997 getSpan NoSource = pure Nothing

13098 getSpan (SpanS sp) = pure $ Just sp

131− getSpan (Lit _) = pure Nothing

13299 getSpan (Named name) = case nameSrcSpan name of

133100 sp@(RealSrcSpan _) -> pure $ Just sp

134101 sp@(UnhelpfulSpan _) -> runMaybeT $ do

135102 guard (sp /= wiredInSrcSpan)

136− -- This case usually arises when the definition is in an external package (DAML only).

103+ -- This case usually arises when the definition is in an external package.

137104 -- In this case the interface files contain garbage source spans

138105 -- so we instead read the .hie files to get useful source spans.

139− mod <- MaybeT $ return $ nameModule_maybe name

140− (hieFile, srcPath) <- MaybeT $ getHieFile mod

141− avail <- MaybeT $ pure $ find (eqName name . snd) $ hieExportNames hieFile

106+ let mod = nameModule name

107+ let unitId = moduleUnitId mod

108+ pkgConfig <- MaybeT $ pure $ lookupPackageConfig unitId pkgState

109+ hiePath <- MaybeT $ liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod

110+ hieFile <- MaybeT $ getHieFile hiePath

111+ avail <- MaybeT $ pure $ listToMaybe (filterAvails (eqName name) $ hie_exports hieFile)

112+ srcPath <- MaybeT $ liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod

142113 -- The location will point to the source file used during compilation.

143114 -- This file might no longer exists and even if it does the path will be relative

144115 -- to the compilation directory which we don’t know.

145− let span = setFileName srcPath $ fst avail

116+ let span = setFileName srcPath $ nameSrcSpan $ availName avail

146117 pure span

147118 -- We ignore uniques and source spans and only compare the name and the module.

148119 eqName :: Name -> Name -> Bool

149− eqName n n' = nameOccName n == nameOccName n' && nameModule_maybe n == nameModule_maybe n'

120+ eqName n n' = nameOccName n == nameOccName n' && nameModule n == nameModule n'

150121 setFileName f (RealSrcSpan span) = RealSrcSpan (span { srcSpanFile = mkFastString f })

151122 setFileName _ span@(UnhelpfulSpan _) = span

152123

153−-- | Filter out spans which do not enclose a given point

154124spansAtPoint :: Position -> [SpanInfo] -> [SpanInfo]

155125spansAtPoint pos = filter atp where

156126 line = _line pos

157127 cha = _character pos

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)

128+ atp SpanInfo{..} = spaninfoStartLine <= line

129+ && spaninfoEndLine >= line

130+ && spaninfoStartCol <= cha

131+ -- The end col points to the column after the

132+ -- last character so we use > instead of >=

133+ && spaninfoEndCol > cha

168134

169135showName :: Outputable a => a -> T.Text

170136showName = T.pack . prettyprint

src/Development/IDE/Spans/Calculate.hs+64−149

@@ -9,35 +9,29 @@

1010-- | Get information on modules, identifiers, etc.

1111

12−module Development.IDE.Spans.Calculate(getSrcSpanInfos) where

12+module Development.IDE.Spans.Calculate(getSrcSpanInfos,listifyAllSpans) where

1313

1414import ConLike

1515import Control.Monad

1616import qualified CoreUtils

17+import Data.Data

18+import qualified Data.Generics

1719import Data.List

1820import Data.Maybe

1921import DataCon

2022import Desugar

2123import GHC

2224import GhcMonad

23−import HscTypes

2425import FastString (mkFastString)

25−import OccName

2626import Development.IDE.Types.Location

2727import Development.IDE.Spans.Type

28−#ifdef GHC_LIB

2928import Development.IDE.GHC.Error (zeroSpan)

30−#else

31−import Development.IDE.GHC.Error (zeroSpan, catchSrcErrors)

32−#endif

3329import Prelude hiding (mod)

3430import TcHsSyn

3531import Var

3632import Development.IDE.Core.Compile

37−import qualified Development.IDE.GHC.Compat as Compat

3833import Development.IDE.GHC.Util

39−import Development.IDE.Spans.Common

40−import Development.IDE.Spans.Documentation

34+

4135

4236-- A lot of things gained an extra X argument in GHC 8.6, which we mostly ignore

4337-- this U ignores that arg in 8.6, but is hidden in 8.4

@@ -50,67 +44,42 @@ import Development.IDE.Spans.Documentation

5044-- | Get source span info, used for e.g. AtPoint and Goto Definition.

5145getSrcSpanInfos

5246 :: HscEnv

53− -> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order

47+ -> [(Located ModuleName, Maybe NormalizedFilePath)]

5448 -> TcModuleResult

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

49+ -> IO [SpanInfo]

50+getSrcSpanInfos env imports tc =

51+ runGhcEnv env

52+ . getSpanInfo imports

53+ $ tmrModule tc

6154

6255-- | Get ALL source spans in the module.

6356getSpanInfo :: GhcMonad m

6457 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports

6558 -> TypecheckedModule

66− -> [ParsedModule]

67− -> [ModIface]

68− -> m SpansInfo

69−getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps deps =

70− do let tcs = tm_typechecked_source

59+ -> m [SpanInfo]

60+getSpanInfo mods tcm =

61+ do let tcs = tm_typechecked_source tcm

7162 bs = listifyAllSpans tcs :: [LHsBind GhcTc]

7263 es = listifyAllSpans tcs :: [LHsExpr GhcTc]

7364 ps = listifyAllSpans' tcs :: [Pat GhcTc]

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

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

8770 let imports = importInfo mods

8871 let exports = getExports tcm

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,_,_)

72+ let exprs = exports ++ imports ++ concat bts ++ concat tts ++ catMaybes (ets ++ pts)

73+ return (mapMaybe toSpanInfo (sortBy cmp exprs))

74+ where cmp (_,a,_) (_,b,_)

9475 | a `isSubspanOf` b = LT

9576 | b `isSubspanOf` a = GT

9677 | otherwise = compare (srcSpanStart a) (srcSpanStart b)

9778

98− addEmptyInfo = map (\(a,b) -> (a,b,Nothing,emptySpanDoc))

99− constraintToInfo (sp, ty) = (SpanS sp, sp, Just ty, emptySpanDoc)

100−

101−-- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always

102−-- points to the first match) whereas the parsed module has the correct locations.

103−-- Therefore we build up a map from OccName to the corresponding definition in the parsed module

104−-- to lookup precise locations for things like multi-clause function definitions.

105−--

106−-- For now this only contains FunBinds.

107−funBindMap :: ParsedModule -> OccEnv (HsBind GhcPs)

108−funBindMap pm = mkOccEnv $ [ (occName $ unLoc f, bnd) | L _ (Compat.ValD bnd@FunBind{fun_id = f}) <- hsmodDecls $ unLoc $ pm_parsed_source pm ]

109−

110−getExports :: TypecheckedModule -> [(SpanSource, SrcSpan)]

79+getExports :: TypecheckedModule -> [(SpanSource, SrcSpan, Maybe Type)]

11180getExports m

11281 | Just (_, _, Just exports, _) <- renamedSource m =

113− [ (Named $ unLoc n, getLoc n)

82+ [ (Named $ unLoc n, getLoc n, Nothing)

11483 | (e, _) <- exports

11584 , n <- ieLNames $ unLoc e

11685 ]

@@ -126,96 +95,43 @@ ieLNames _ = []

12695

12796-- | Get the name and type of a binding.

12897getTypeLHsBind :: (GhcMonad m)

129− => [ParsedModule]

130− -> OccEnv (HsBind GhcPs)

98+ => TypecheckedModule

13199 -> LHsBind GhcTc

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 _ = []

100+ -> m [(SpanSource, SrcSpan, Maybe Type)]

101+getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) =

102+ return [(Named $ getName (unLoc pid), getLoc pid, Just (varType (unLoc pid)))]

103+getTypeLHsBind _ _ = return []

151104

152105-- | Get the name and type of an expression.

153106getTypeLHsExpr :: (GhcMonad m)

154− => [ParsedModule]

107+ => TypecheckedModule

155108 -> LHsExpr GhcTc

156− -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))

157−getTypeLHsExpr deps e = do

109+ -> m (Maybe (SpanSource, SrcSpan, Maybe Type))

110+getTypeLHsExpr _ e = do

158111 hs_env <- getSession

159112 (_, mbe) <- liftIO (deSugarExpr hs_env e)

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

113+ return $

114+ case mbe of

115+ Just expr ->

116+ Just (getSpanSource (unLoc e), getLoc e, Just (CoreUtils.exprType expr))

117+ Nothing -> Nothing

168118 where

169119 getSpanSource :: HsExpr GhcTc -> SpanSource

170− getSpanSource xpr | isLit xpr = Lit (showGhc xpr)

171120 getSpanSource (HsVar U (L _ i)) = Named (getName i)

172121 getSpanSource (HsConLikeOut U (RealDataCon dc)) = Named (dataConName dc)

173122 getSpanSource RecordCon {rcon_con_name} = Named (getName rcon_con_name)

174123 getSpanSource (HsWrap U _ xpr) = getSpanSource xpr

175124 getSpanSource (HsPar U xpr) = getSpanSource (unLoc xpr)

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

125+ getSpanSource _ = NoSource

207126

208127-- | Get the name and type of a pattern.

209128getTypeLPat :: (GhcMonad m)

210− => [ParsedModule]

129+ => TypecheckedModule

211130 -> Pat GhcTc

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)

131+ -> m (Maybe (SpanSource, SrcSpan, Maybe Type))

132+getTypeLPat _ pat =

133+ let (src, spn) = getSpanSource pat in

134+ return $ Just (src, spn, Just (hsPatType pat))

219135 where

220136 getSpanSource :: Pat GhcTc -> (SpanSource, SrcSpan)

221137 getSpanSource (VarPat U (L spn vid)) = (Named (getName vid), spn)

@@ -225,40 +141,40 @@ getTypeLPat deps pat = do

225141

226142getLHsType

227143 :: GhcMonad m

228− => [ParsedModule]

144+ => TypecheckedModule

229145 -> LHsType GhcRn

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)]

146+ -> m [(SpanSource, SrcSpan, Maybe Type)]

147+getLHsType _ (L spn (HsTyVar U _ v)) = pure [(Named $ unLoc v, spn, Nothing)]

245148getLHsType _ _ = pure []

246149

247150importInfo :: [(Located ModuleName, Maybe NormalizedFilePath)]

248− -> [(SpanSource, SrcSpan)]

151+ -> [(SpanSource, SrcSpan, Maybe Type)]

249152importInfo = mapMaybe (uncurry wrk) where

250− wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan)

153+ wrk :: Located ModuleName -> Maybe NormalizedFilePath -> Maybe (SpanSource, SrcSpan, Maybe Type)

251154 wrk modName = \case

252155 Nothing -> Nothing

253− Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName)

156+ Just fp -> Just (fpToSpanSource $ fromNormalizedFilePath fp, getLoc modName, Nothing)

254157

255158 -- TODO make this point to the module name

256159 fpToSpanSource :: FilePath -> SpanSource

257160 fpToSpanSource fp = SpanS $ RealSrcSpan $ zeroSpan $ mkFastString fp

258161

162+-- | Get ALL source spans in the source.

163+listifyAllSpans :: (Typeable a, Data m) => m -> [Located a]

164+listifyAllSpans tcs =

165+ Data.Generics.listify p tcs

166+ where p (L spn _) = isGoodSrcSpan spn

167+-- This is a version of `listifyAllSpans` specialized on picking out

168+-- patterns. It comes about since GHC now defines `type LPat p = Pat

169+-- p` (no top-level locations).

170+listifyAllSpans' :: Typeable a

171+ => TypecheckedSource -> [Pat a]

172+listifyAllSpans' tcs = Data.Generics.listify (const True) tcs

173+

174+

259175-- | Pretty print the types into a 'SpanInfo'.

260−toSpanInfo :: (SpanSource, SrcSpan, Maybe Type, SpanDoc) -> Maybe SpanInfo

261−toSpanInfo (name,mspan,typ,docs) =

176+toSpanInfo :: (SpanSource, SrcSpan, Maybe Type) -> Maybe SpanInfo

177+toSpanInfo (name,mspan,typ) =

262178 case mspan of

263179 RealSrcSpan spn ->

264180 -- GHC’s line and column numbers are 1-based while LSP’s line and column

@@ -268,6 +184,5 @@ toSpanInfo (name,mspan,typ,docs) =

268184 (srcSpanEndLine spn - 1)

269185 (srcSpanEndCol spn - 1)

270186 typ

271− name

272− docs)

187+ name)

273188 _ -> Nothing

src/Development/IDE/Spans/Common.hsdeleted−162

@@ -1,162 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−#include "ghc-api-version.h"

3−

4−module Development.IDE.Spans.Common (

5− showGhc

6−, listifyAllSpans

7−, listifyAllSpans'

8−, safeTyThingId

9−#ifndef GHC_LIB

10−, safeTyThingType

11−#endif

12−, SpanDoc(..)

13−, emptySpanDoc

14−, spanDocToMarkdown

15−, spanDocToMarkdownForTest

16−) where

17−

18−import Data.Data

19−import qualified Data.Generics

20−import qualified Data.Text as T

21−import Data.List.Extra

22−

23−import GHC

24−import Outputable

25−import DynFlags

26−import ConLike

27−import DataCon

28−#ifndef GHC_LIB

29−import Var

30−#endif

31−

32−import qualified Documentation.Haddock.Parser as H

33−import qualified Documentation.Haddock.Types as H

34−

35−showGhc :: Outputable a => a -> String

36−showGhc = showPpr unsafeGlobalDynFlags

37−

38−-- | Get ALL source spans in the source.

39−listifyAllSpans :: (Typeable a, Data m) => m -> [Located a]

40−listifyAllSpans tcs =

41− Data.Generics.listify p tcs

42− where p (L spn _) = isGoodSrcSpan spn

43−-- This is a version of `listifyAllSpans` specialized on picking out

44−-- patterns. It comes about since GHC now defines `type LPat p = Pat

45−-- p` (no top-level locations).

46−listifyAllSpans' :: Typeable a

47− => TypecheckedSource -> [Pat a]

48−listifyAllSpans' tcs = Data.Generics.listify (const True) tcs

49−

50−#ifndef GHC_LIB

51−-- From haskell-ide-engine/src/Haskell/Ide/Engine/Support/HieExtras.hs

52−safeTyThingType :: TyThing -> Maybe Type

53−safeTyThingType thing

54− | Just i <- safeTyThingId thing = Just (varType i)

55−safeTyThingType (ATyCon tycon) = Just (tyConKind tycon)

56−safeTyThingType _ = Nothing

57−#endif

58−

59−safeTyThingId :: TyThing -> Maybe Id

60−safeTyThingId (AnId i) = Just i

61−safeTyThingId (AConLike (RealDataCon dc)) = Just $ dataConWrapId dc

62−safeTyThingId _ = Nothing

63−

64−-- Possible documentation for an element in the code

65−data SpanDoc

66− = SpanDocString HsDocString

67− | SpanDocText [T.Text]

68− deriving Show

69−

70−emptySpanDoc :: SpanDoc

71−emptySpanDoc = SpanDocText []

72−

73−spanDocToMarkdown :: SpanDoc -> [T.Text]

74−#if MIN_GHC_API_VERSION(8,6,0)

75−spanDocToMarkdown (SpanDocString docs)

76− = [T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs]

77−#else

78−spanDocToMarkdown (SpanDocString _)

79− = []

80−#endif

81−spanDocToMarkdown (SpanDocText txt) = txt

82−

83−spanDocToMarkdownForTest :: String -> String

84−spanDocToMarkdownForTest

85− = haddockToMarkdown . H.toRegular . H._doc . H.parseParas Nothing

86−

87−-- Simple (and a bit hacky) conversion from Haddock markup to Markdown

88−haddockToMarkdown

89− :: H.DocH String String -> String

90−

91−haddockToMarkdown H.DocEmpty

92− = ""

93−haddockToMarkdown (H.DocAppend d1 d2)

94− = haddockToMarkdown d1 ++ " " ++ haddockToMarkdown d2

95−haddockToMarkdown (H.DocString s)

96− = s

97−haddockToMarkdown (H.DocParagraph p)

98− = "\n\n" ++ haddockToMarkdown p

99−haddockToMarkdown (H.DocIdentifier i)

100− = "`" ++ i ++ "`"

101−haddockToMarkdown (H.DocIdentifierUnchecked i)

102− = "`" ++ i ++ "`"

103−haddockToMarkdown (H.DocModule i)

104− = "`" ++ i ++ "`"

105−haddockToMarkdown (H.DocWarning w)

106− = haddockToMarkdown w

107−haddockToMarkdown (H.DocEmphasis d)

108− = "*" ++ haddockToMarkdown d ++ "*"

109−haddockToMarkdown (H.DocBold d)

110− = "**" ++ haddockToMarkdown d ++ "**"

111−haddockToMarkdown (H.DocMonospaced d)

112− = "`" ++ escapeBackticks (haddockToMarkdown d) ++ "`"

113− where

114− escapeBackticks "" = ""

115− escapeBackticks ('`':ss) = '\\':'`':escapeBackticks ss

116− escapeBackticks (s :ss) = s:escapeBackticks ss

117−haddockToMarkdown (H.DocCodeBlock d)

118− = "\n```haskell\n" ++ haddockToMarkdown d ++ "\n```\n"

119−haddockToMarkdown (H.DocExamples es)

120− = "\n```haskell\n" ++ unlines (map exampleToMarkdown es) ++ "\n```\n"

121− where

122− exampleToMarkdown (H.Example expr result)

123− = ">>> " ++ expr ++ "\n" ++ unlines result

124−haddockToMarkdown (H.DocHyperlink (H.Hyperlink url Nothing))

125− = "<" ++ url ++ ">"

126−haddockToMarkdown (H.DocHyperlink (H.Hyperlink url (Just label)))

127− = "[" ++ haddockToMarkdown label ++ "](" ++ url ++ ")"

128−haddockToMarkdown (H.DocPic (H.Picture url Nothing))

129− = "![](" ++ url ++ ")"

130−haddockToMarkdown (H.DocPic (H.Picture url (Just label)))

131− = "![" ++ label ++ "](" ++ url ++ ")"

132−haddockToMarkdown (H.DocAName aname)

133− = "[" ++ aname ++ "]:"

134−haddockToMarkdown (H.DocHeader (H.Header level title))

135− = replicate level '#' ++ " " ++ haddockToMarkdown title

136−

137−haddockToMarkdown (H.DocUnorderedList things)

138− = '\n' : (unlines $ map (("+ " ++) . trimStart . splitForList . haddockToMarkdown) things)

139−haddockToMarkdown (H.DocOrderedList things)

140− = '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things)

141−haddockToMarkdown (H.DocDefList things)

142− = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things)

143−

144−-- we cannot render math by default

145−haddockToMarkdown (H.DocMathInline _)

146− = "*cannot render inline math formula*"

147−haddockToMarkdown (H.DocMathDisplay _)

148− = "\n\n*cannot render display math formula*\n\n"

149−

150−-- TODO: render tables

151−haddockToMarkdown (H.DocTable _t)

152− = "\n\n*tables are not yet supported*\n\n"

153−

154−-- things I don't really know how to handle

155−haddockToMarkdown (H.DocProperty _)

156− = "" -- don't really know what to do

157−

158−splitForList :: String -> String

159−splitForList s

160− = case lines s of

161− [] -> ""

162− (first:rest) -> unlines $ first : map ((" " ++) . trimStart) rest

src/Development/IDE/Spans/Documentation.hs+18−41

@@ -1,12 +1,8 @@

22-- SPDX-License-Identifier: Apache-2.0

4−{-# LANGUAGE CPP #-}

5−#include "ghc-api-version.h"

6−

74module Development.IDE.Spans.Documentation (

85 getDocumentation

9− , getDocumentationTryGhc

106 ) where

117

128import Control.Monad

@@ -14,34 +10,16 @@ import Data.List.Extra

1410import qualified Data.Map as M

1511import Data.Maybe

1612import qualified Data.Text as T

17−import Development.IDE.GHC.Compat

1813import Development.IDE.GHC.Error

19−import Development.IDE.Spans.Common

14+import Development.IDE.Spans.Calculate

2015import FastString

16+import GHC

2117import SrcLoc

2218

2319

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−

4220getDocumentation

43− :: [ParsedModule] -- ^ All of the possible modules it could be defined in.

44− -> Name -- ^ The name you want documentation for.

21+ :: Name -- ^ The name you want documentation for.

22+ -> [TypecheckedModule] -- ^ All of the possible modules it could be defined in.

4523 -> [T.Text]

4624-- This finds any documentation between the name you want

4725-- documentation for and the one before it. This is only an

@@ -50,18 +28,17 @@ getDocumentation

5028-- may be edge cases where it is very wrong).

5129-- TODO : Build a version of GHC exactprint to extract this information

5230-- more accurately.

53−getDocumentation sources targetName = fromMaybe [] $ do

31+getDocumentation targetName tcs = fromMaybe [] $ do

5432 -- Find the module the target is defined in.

5533 targetNameSpan <- realSpan $ nameSrcSpan targetName

5634 tc <-

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− ]

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])

6542 -- Sort the names' source spans.

6643 let sortedSpans = sortedNameSpans bs

6744 -- Now go ahead and extract the docs.

@@ -83,16 +60,16 @@ getDocumentation sources targetName = fromMaybe [] $ do

8360 where

8461 -- Get the name bound by a binding. We only concern ourselves with

8562 -- @FunBind@ (which covers functions and variables).

86− name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)

87− name_of_bind FunBind {fun_id} = Just fun_id

63+ name_of_bind :: LHsBind GhcTc -> Maybe Name

64+ name_of_bind (L _ FunBind {fun_id}) = Just (getName (unLoc fun_id))

8865 name_of_bind _ = Nothing

8966 -- Get source spans from names, discard unhelpful spans, remove

9067 -- duplicates and sort.

91− sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]

92− sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)

68+ sortedNameSpans :: [Name] -> [RealSrcSpan]

69+ sortedNameSpans ls = nubSort (mapMaybe (realSpan . nameSrcSpan) ls)

9370 isBetween target before after = before <= target && target <= after

94− ann = snd . pm_annotations

95− annotationFileName :: ParsedModule -> Maybe FastString

71+ ann = snd . pm_annotations . tm_parsed_module

72+ annotationFileName :: TypecheckedModule -> Maybe FastString

9673 annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann

9774 realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]

9875 realSpans =

src/Development/IDE/Spans/Type.hs+4−19

@@ -6,8 +6,7 @@

66-- | Types used separate to GHCi vanilla.

88module Development.IDE.Spans.Type(

9− SpansInfo(..)

10− , SpanInfo(..)

9+ SpanInfo(..)

1110 , SpanSource(..)

1211 , getNameM

1312 ) where

@@ -16,15 +15,6 @@ import GHC

1615import Control.DeepSeq

1716import OccName

1817import 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

2818

2919-- | Type of some span of source code. Most of these fields are

3020-- unboxed but Haddock doesn't show that.

@@ -44,14 +34,11 @@ data SpanInfo =

4434 -- any. This can be useful for accessing a variety of

4535 -- information about the identifier such as module,

4636 -- locality, definition location, etc.

47− ,spaninfoDocs :: !SpanDoc

48− -- ^ Documentation for the element

4937 }

5038instance Show SpanInfo where

51− show (SpanInfo sl sc el ec t n docs) =

39+ show (SpanInfo sl sc el ec t n) =

5240 unwords ["(SpanInfo", show sl, show sc, show el, show ec

53− , show $ maybe "NoType" prettyPrint t, "(" <> show n <> "))"

54− , "docs(" <> show docs <> ")"]

41+ , show $ maybe "NoType" prettyPrint t, "(" <> show n <> "))"]

5542

5643instance NFData SpanInfo where

5744 rnf = rwhnf

@@ -60,7 +47,6 @@ instance NFData SpanInfo where

6047-- we don't always get a name out so sometimes manually annotating source is more appropriate

6148data SpanSource = Named Name

6249 | SpanS SrcSpan

63− | Lit String

6450 | NoSource

6551 deriving (Eq)

6652

@@ -68,10 +54,9 @@ instance Show SpanSource where

6854 show = \case

6955 Named n -> "Named " ++ occNameString (occName n)

7056 SpanS sp -> "Span " ++ show sp

71− Lit lit -> "Lit " ++ lit

7257 NoSource -> "NoSource"

7358

7459getNameM :: SpanSource -> Maybe Name

7560getNameM = \case

7661 Named name -> Just name

77− _ -> Nothing

62+ _ -> Nothing

src/Development/IDE/Types/Diagnostics.hs+7−38

@@ -4,23 +4,19 @@

55module Development.IDE.Types.Diagnostics (

66 LSP.Diagnostic(..),

7− ShowDiagnostic(..),

87 FileDiagnostic,

9− IdeResult,

108 LSP.DiagnosticSeverity(..),

119 DiagnosticStore,

1210 List(..),

1311 ideErrorText,

14− ideErrorWithSource,

1512 showDiagnostics,

1613 showDiagnosticsColored,

1714 ) where

1815

19−import Control.DeepSeq

2016import Data.Maybe as Maybe

2117import qualified Data.Text as T

2218import Data.Text.Prettyprint.Doc

23−import Language.Haskell.LSP.Types as LSP (DiagnosticSource,

19+import Language.Haskell.LSP.Types as LSP (

2420 DiagnosticSeverity(..)

2521 , Diagnostic(..)

2622 , List(..)

@@ -32,43 +28,17 @@ import Data.Text.Prettyprint.Doc.Render.Terminal (Color(..), color)

3228

3329import Development.IDE.Types.Location

3430

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)

3831

3932ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic

40−ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError)

41−

42−ideErrorWithSource

43− :: Maybe DiagnosticSource

44− -> Maybe DiagnosticSeverity

45− -> a

46− -> T.Text

47− -> (a, ShowDiagnostic, Diagnostic)

48−ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic {

33+ideErrorText fp msg = (fp, LSP.Diagnostic {

4934 _range = noRange,

50− _severity = sev,

35+ _severity = Just LSP.DsError,

5136 _code = Nothing,

52− _source = source,

37+ _source = Just "compiler",

5338 _message = msg,

54− _relatedInformation = Nothing,

55− _tags = Nothing

39+ _relatedInformation = Nothing

5640 })

5741

58−-- | Defines whether a particular diagnostic should be reported

59−-- back to the user.

60−--

61−-- One important use case is "missing signature" code lenses,

62−-- for which we need to enable the corresponding warning during

63−-- type checking. However, we do not want to show the warning

64−-- unless the programmer asks for it (#261).

65−data ShowDiagnostic

66− = ShowDiag -- ^ Report back to the user

67− | HideDiag -- ^ Hide from user

68− deriving (Eq, Ord, Show)

69−

70−instance NFData ShowDiagnostic where

71− rnf = rwhnf

7242

7343-- | Human readable diagnostics for a specific file.

7444--

@@ -76,7 +46,7 @@ instance NFData ShowDiagnostic where

7646-- along with the related source location so that we can display the error

7747-- on either the console or in the IDE at the right source location.

7848--

79−type FileDiagnostic = (NormalizedFilePath, ShowDiagnostic, Diagnostic)

49+type FileDiagnostic = (NormalizedFilePath, Diagnostic)

8050

8151prettyRange :: Range -> Doc Terminal.AnsiStyle

8252prettyRange Range{..} = f _start <> "-" <> f _end

@@ -96,10 +66,9 @@ prettyDiagnostics :: [FileDiagnostic] -> Doc Terminal.AnsiStyle

9666prettyDiagnostics = vcat . map prettyDiagnostic

9767

9868prettyDiagnostic :: FileDiagnostic -> Doc Terminal.AnsiStyle

99−prettyDiagnostic (fp, sh, LSP.Diagnostic{..}) =

69+prettyDiagnostic (fp, LSP.Diagnostic{..}) =

10070 vcat

10171 [ slabel_ "File: " $ pretty (fromNormalizedFilePath fp)

102− , slabel_ "Hidden: " $ if sh == ShowDiag then "no" else "yes"

10372 , slabel_ "Range: " $ prettyRange _range

10473 , slabel_ "Source: " $ pretty _source

10574 , slabel_ "Severity:" $ pretty $ show sev

src/Development/IDE/Types/Location.hs+59−70

@@ -10,59 +10,84 @@ module Development.IDE.Types.Location

1010 , Position(..)

1111 , showPosition

1212 , Range(..)

13− , LSP.Uri(..)

14− , LSP.NormalizedUri

13+ , Uri(..)

14+ , NormalizedUri

1515 , LSP.toNormalizedUri

1616 , LSP.fromNormalizedUri

17− , LSP.NormalizedFilePath

17+ , NormalizedFilePath

1818 , fromUri

19− , emptyFilePath

20− , emptyPathUri

21− , toNormalizedFilePath'

22− , LSP.fromNormalizedFilePath

19+ , toNormalizedFilePath

20+ , fromNormalizedFilePath

21+ , filePathToUri

2322 , filePathToUri'

2423 , uriToFilePath'

25− , readSrcSpan

2624 ) where

2725

28−import Control.Applicative

2926import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..))

30−import Control.Monad

31−import Data.Hashable (Hashable(hash))

27+import Control.DeepSeq

28+import Data.Binary

29+import Data.Maybe as Maybe

30+import Data.Hashable

3231import Data.String

33−import FastString

32+import System.FilePath

33+import System.Info.Extra

3434import qualified Language.Haskell.LSP.Types as LSP

35−import SrcLoc as GHC

36−import Text.ParserCombinators.ReadP as ReadP

37−import Data.Maybe (fromMaybe)

38−

39−toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath

40−-- We want to keep empty paths instead of normalising them to "."

41−toNormalizedFilePath' "" = emptyFilePath

42−toNormalizedFilePath' fp = LSP.toNormalizedFilePath fp

43−

44−emptyFilePath :: LSP.NormalizedFilePath

45−emptyFilePath = LSP.NormalizedFilePath emptyPathUri ""

35+import Language.Haskell.LSP.Types as LSP (

36+ filePathToUri

37+ , NormalizedUri(..)

38+ , Uri(..)

39+ , toNormalizedUri

40+ , fromNormalizedUri

41+ )

42+

43+

44+-- | Newtype wrapper around FilePath that always has normalized slashes.

45+newtype NormalizedFilePath = NormalizedFilePath FilePath

46+ deriving (Eq, Ord, Show, Hashable, NFData, Binary)

47+

48+instance IsString NormalizedFilePath where

49+ fromString = toNormalizedFilePath

50+

51+toNormalizedFilePath :: FilePath -> NormalizedFilePath

52+toNormalizedFilePath "" = NormalizedFilePath ""

53+toNormalizedFilePath fp = NormalizedFilePath $ normalise' fp

54+ where

55+ -- We do not use System.FilePath’s normalise here since that

56+ -- also normalises things like the case of the drive letter

57+ -- which NormalizedUri does not normalise so we get VFS lookup failures.

58+ normalise' :: FilePath -> FilePath

59+ normalise' = oneSlash . map (\c -> if isPathSeparator c then pathSeparator else c)

60+

61+ -- Allow double slashes as the very first element of the path for UNC drives on Windows

62+ -- otherwise turn adjacent slashes into one. These slashes often arise from dodgy CPP

63+ oneSlash :: FilePath -> FilePath

64+ oneSlash (x:xs) | isWindows = x : f xs

65+ oneSlash xs = f xs

66+

67+ f (x:y:xs) | isPathSeparator x, isPathSeparator y = f (x:xs)

68+ f (x:xs) = x : f xs

69+ f [] = []

70+

71+

72+fromNormalizedFilePath :: NormalizedFilePath -> FilePath

73+fromNormalizedFilePath (NormalizedFilePath fp) = fp

4674

4775-- | We use an empty string as a filepath when we don’t have a file.

4876-- However, haskell-lsp doesn’t support that in uriToFilePath and given

4977-- that it is not a valid filepath it does not make sense to upstream a fix.

5078-- So we have our own wrapper here that supports empty filepaths.

51−uriToFilePath' :: LSP.Uri -> Maybe FilePath

79+uriToFilePath' :: Uri -> Maybe FilePath

5280uriToFilePath' uri

53− | uri == LSP.fromNormalizedUri emptyPathUri = Just ""

81+ | uri == filePathToUri "" = Just ""

5482 | otherwise = LSP.uriToFilePath uri

5583

56−emptyPathUri :: LSP.NormalizedUri

57−emptyPathUri =

58− let s = "file://"

59− in LSP.NormalizedUri (hash s) s

84+filePathToUri' :: NormalizedFilePath -> NormalizedUri

85+filePathToUri' = toNormalizedUri . filePathToUri . fromNormalizedFilePath

86+

6087

61−filePathToUri' :: LSP.NormalizedFilePath -> LSP.NormalizedUri

62−filePathToUri' = LSP.normalizedFilePathToUri

88+fromUri :: LSP.NormalizedUri -> NormalizedFilePath

89+fromUri = toNormalizedFilePath . fromMaybe noFilePath . uriToFilePath' . fromNormalizedUri

6390

64−fromUri :: LSP.NormalizedUri -> LSP.NormalizedFilePath

65−fromUri = fromMaybe (toNormalizedFilePath' noFilePath) . LSP.uriToNormalizedFilePath

6691

6792noFilePath :: FilePath

6893noFilePath = "<unknown>"

@@ -71,42 +96,6 @@ noFilePath = "<unknown>"

7196noRange :: Range

7297noRange = Range (Position 0 0) (Position 100000 0)

7398

99+

74100showPosition :: Position -> String

75101showPosition Position{..} = show (_line + 1) ++ ":" ++ show (_character + 1)

76−

77−-- | Parser for the GHC output format

78−readSrcSpan :: ReadS SrcSpan

79−readSrcSpan = readP_to_S (singleLineSrcSpanP <|> multiLineSrcSpanP)

80− where

81− singleLineSrcSpanP, multiLineSrcSpanP :: ReadP SrcSpan

82− singleLineSrcSpanP = do

83− fp <- filePathP

84− l <- readS_to_P reads <* char ':'

85− c0 <- readS_to_P reads

86− c1 <- (char '-' *> readS_to_P reads) <|> pure c0

87− let from = mkSrcLoc fp l c0

88− to = mkSrcLoc fp l c1

89− return $ mkSrcSpan from to

90−

91− multiLineSrcSpanP = do

92− fp <- filePathP

93− s <- parensP (srcLocP fp)

94− void $ char '-'

95− e <- parensP (srcLocP fp)

96− return $ mkSrcSpan s e

97−

98− parensP :: ReadP a -> ReadP a

99− parensP = between (char '(') (char ')')

100−

101− filePathP :: ReadP FastString

102− filePathP = fromString <$> (readFilePath <* char ':') <|> pure ""

103−

104− srcLocP :: FastString -> ReadP SrcLoc

105− srcLocP fp = do

106− l <- readS_to_P reads

107− void $ char ','

108− c <- readS_to_P reads

109− return $ mkSrcLoc fp l c

110−

111− readFilePath :: ReadP FilePath

112− readFilePath = some ReadP.get

src/Development/IDE/Types/Options.hs+8−35

@@ -12,25 +12,25 @@ module Development.IDE.Types.Options

1212 , clientSupportsProgress

1313 , IdePkgLocationOptions(..)

1414 , defaultIdeOptions

15− , IdeResult

1615 ) where

1716

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

2523

2624data IdeOptions = IdeOptions

2725 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource

2826 -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings

2927 -- and a list of errors, along with a new parse tree.

30− , optGhcSession :: Action (FilePath -> Action (IdeResult HscEnvEq))

28+ , optGhcSession :: IO (FilePath -> Action HscEnvEq)

3129 -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.

32− -- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.

30+ -- The 'IO' will be called once, then the resulting function will be applied once per file.

3331 -- 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,17 +43,12 @@ 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

4846 , optReportProgress :: IdeReportProgress

4947 -- ^ Whether to report progress during long operations.

5048 , optLanguageSyntax :: String

5149 -- ^ the ```language to use

5250 , optNewColonConvention :: Bool

5351 -- ^ 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.

5752 , optDefer :: IdeDefer

5853 -- ^ Whether to defer type errors, typed holes and out of scope

5954 -- variables. Deferral allows the IDE to continue to provide

@@ -75,10 +70,10 @@ newtype IdeReportProgress = IdeReportProgress Bool

7570newtype IdeDefer = IdeDefer Bool

7671

7772clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress

78−clientSupportsProgress caps = IdeReportProgress $ Just True ==

79− (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))

73+clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $

74+ LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)

8075

81−defaultIdeOptions :: Action (FilePath -> Action (IdeResult HscEnvEq)) -> IdeOptions

76+defaultIdeOptions :: IO (FilePath -> Action HscEnvEq) -> IdeOptions

8277defaultIdeOptions session = IdeOptions

8378 {optPreprocessor = IdePreprocessedSource [] []

8479 ,optGhcSession = session

@@ -90,9 +85,7 @@ defaultIdeOptions session = IdeOptions

9085 ,optReportProgress = IdeReportProgress False

9186 ,optLanguageSyntax = "haskell"

9287 ,optNewColonConvention = False

93− ,optKeywords = haskellKeywords

9488 ,optDefer = IdeDefer True

95− ,optTesting = False

9689 }

9790

9891

@@ -110,23 +103,3 @@ data IdePkgLocationOptions = IdePkgLocationOptions

110103defaultIdePkgLocationOptions :: IdePkgLocationOptions

111104defaultIdePkgLocationOptions = IdePkgLocationOptions f f

112105 where f _ _ = return Nothing

113−

114−-- | From https://wiki.haskell.org/Keywords

115−haskellKeywords :: [T.Text]

116−haskellKeywords =

117− [ "as"

118− , "case", "of"

119− , "class", "instance", "type"

120− , "data", "family", "newtype"

121− , "default"

122− , "deriving"

123− , "do", "mdo", "proc", "rec"

124− , "forall"

125− , "foreign"

126− , "hiding"

127− , "if", "then", "else"

128− , "import", "qualified", "hiding"

129− , "infix", "infixl", "infixr"

130− , "let", "in", "where"

131− , "module"

132− ]

stack-ghc-lib.yaml+4−10

@@ -2,18 +2,12 @@ resolver: nightly-2019-09-16

22packages:

33- .

44extra-deps:

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

5+- haskell-lsp-0.18.0.0

6+- haskell-lsp-types-0.18.0.0

7+- lsp-test-0.8.2.0

8+- hie-bios-0.2.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

1711nix:

1812 packages: [zlib]

1913flags:

stack.yaml+5−14

@@ -1,19 +1,10 @@

1−resolver: nightly-2019-09-21

1+resolver: nightly-2019-09-16

22packages:

33- .

44extra-deps:

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

5+- haskell-lsp-0.18.0.0

6+- haskell-lsp-types-0.18.0.0

7+- lsp-test-0.8.2.0

8+- hie-bios-0.2.1

189nix:

1910 packages: [zlib]

stack810.yamldeleted−18

@@ -1,18 +0,0 @@

1−resolver: nightly-2020-02-13

2−compiler: ghc-8.10.1

3−allow-newer: true

4−packages:

5−- .

6−extra-deps:

7−- haskell-lsp-0.22.0.0

8−- haskell-lsp-types-0.22.0.0

9−- lsp-test-0.11.0.1

10−- ghc-check-0.3.0.1

11−- hie-bios-0.5.0

12−

13−# for ghc-8.10

14−- Cabal-3.2.0.0

15−- lens-4.19.1

16−

17−nix:

18− packages: [zlib]

stack84.yaml+6−23

@@ -3,31 +3,14 @@ packages:

33- .

55extra-deps:

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

6+- haskell-lsp-0.18.0.0

7+- haskell-lsp-types-0.18.0.0

8+- lsp-test-0.8.2.0

119- rope-utf16-splay-0.3.1.0

10+- shake-0.18.3

1211- filepattern-0.1.1

1312- js-dgtable-0.5.2

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−

13+- hie-bios-0.2.1

3214nix:

3315 packages: [zlib]

16+allow-newer: true

stack88.yaml+2−6

@@ -1,11 +1,7 @@

1−resolver: nightly-2020-02-13

1+resolver: nightly-2019-12-06

22packages:

33- .

44extra-deps:

5−- haskell-lsp-0.22.0.0

6−- haskell-lsp-types-0.22.0.0

7−- lsp-test-0.11.0.1

8−- ghc-check-0.3.0.1

9−- hie-bios-0.5.0

5+allow-newer: true

106nix:

117 packages: [zlib]

test/data/GotoHover.hsnew file+34

@@ -0,0 +1,34 @@

1+{- HLINT ignore -}

2+module Testing ( module Testing )where

3+import Data.Text (Text, pack)

4+data TypeConstructor = DataConstructor

5+ { fff :: Text

6+ , ggg :: Int }

7+aaa :: TypeConstructor

8+aaa = DataConstructor

9+ { fff = ""

10+ , ggg = 0

11+ }

12+bbb :: TypeConstructor

13+bbb = DataConstructor "" 0

14+ccc :: (Text, Int)

15+ccc = (fff bbb, ggg aaa)

16+ddd :: Num a => a -> a -> a

17+ddd vv ww = vv +! ww

18+a +! b = a - b

19+hhh (Just a) (><) = a >< a

20+iii a b = a `b` a

21+jjj s = pack $ s <> s

22+class Class a where

23+ method :: a -> Int

24+instance Class Int where

25+ method = succ

26+kkk :: Class a => Int -> a -> Int

27+kkk n c = n + method c

28+

29+doBind :: Maybe ()

30+doBind = do unwrapped <- Just ()

31+ return unwrapped

32+

33+listCompBind :: [Char]

34+listCompBind = [ succ c | c <- "abc" ]

test/data/hover/Bar.hsdeleted−3

@@ -1,3 +0,0 @@

1−module Bar (Bar(..)) where

2−

3−data Bar = Bar

test/data/hover/Foo.hsdeleted−5

@@ -1,5 +0,0 @@

1−module Foo (Bar, foo) where

2−

3−import Bar

4−

5−foo = Bar

test/data/hover/GotoHover.hsdeleted−57

@@ -1,57 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{- HLINT ignore -}

3−module Testing ( module Testing ) where

4−import Data.Text (Text, pack)

5−import Foo (Bar, foo)

6−

7−

8−data TypeConstructor = DataConstructor

9− { fff :: Text

10− , ggg :: Int }

11−aaa :: TypeConstructor

12−aaa = DataConstructor

13− { fff = "dfgy"

14− , ggg = 832

15− }

16−bbb :: TypeConstructor

17−bbb = DataConstructor "mjgp" 2994

18−ccc :: (Text, Int)

19−ccc = (fff bbb, ggg aaa)

20−ddd :: Num a => a -> a -> a

21−ddd vv ww = vv +! ww

22−a +! b = a - b

23−hhh (Just a) (><) = a >< a

24−iii a b = a `b` a

25−jjj s = pack $ s <> s

26−class MyClass a where

27− method :: a -> Int

28−instance MyClass Int where

29− method = succ

30−kkk :: MyClass a => Int -> a -> Int

31−kkk n c = n + method c

32−

33−doBind :: Maybe ()

34−doBind = do unwrapped <- Just ()

35− return unwrapped

36−

37−listCompBind :: [Char]

38−listCompBind = [ succ c | c <- "ptfx" ]

39−

40−multipleClause :: Bool -> Char

41−multipleClause True = 't'

42−multipleClause False = 'f'

43−

44−-- | Recognizable docs: kpqz

45−documented :: Monad m => Either Int (m a)

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.hsdeleted−3

@@ -1,3 +0,0 @@

1−module A(foo) where

2−

3−foo = ()

test/data/multi/a/a.cabaldeleted−9

@@ -1,9 +0,0 @@

1−name: a

2−version: 1.0.0

3−build-type: Simple

4−cabal-version: >= 1.2

5−

6−library

7− build-depends: base

8− exposed-modules: A

9− hs-source-dirs: .

test/data/multi/b/B.hsdeleted−3

@@ -1,3 +0,0 @@

1−module B(module B) where

2−import A

3−qux = foo

test/data/multi/b/b.cabaldeleted−9

@@ -1,9 +0,0 @@

1−name: b

2−version: 1.0.0

3−build-type: Simple

4−cabal-version: >= 1.2

5−

6−library

7− build-depends: base, a

8− exposed-modules: B

9− hs-source-dirs: .

test/data/multi/cabal.projectdeleted−1

@@ -1 +0,0 @@

1−packages: a b

test/data/multi/hie.yamldeleted−6

@@ -1,6 +0,0 @@

1−cradle:

2− cabal:

3− - path: "./a"

4− component: "lib:a"

5− - path: "./b"

6− component: "lib:b"

test/exe/Main.hs+171−1731

@@ -1,83 +1,48 @@

22-- SPDX-License-Identifier: Apache-2.0

4−{-# LANGUAGE AllowAmbiguousTypes #-}

54{-# LANGUAGE DuplicateRecordFields #-}

6−{-# LANGUAGE PatternSynonyms #-}

75{-# LANGUAGE CPP #-}

86#include "ghc-api-version.h"

108module Main (main) where

119

1210import Control.Applicative.Combinators

13−import Control.Exception (bracket, catch)

14−import qualified Control.Lens as Lens

1511import Control.Monad

1612import Control.Monad.IO.Class (liftIO)

17−import Data.Aeson (FromJSON, Value)

13+import Data.Char (toLower)

1814import 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)

2315import Development.IDE.GHC.Util

2416import qualified Data.Text as T

25−import Data.Typeable

26−import Development.IDE.Spans.Common

2717import Development.IDE.Test

2818import Development.IDE.Test.Runfiles

29−import Development.IDE.Types.Location

30−import Development.Shake (getDirectoryFilesIO)

3119import Language.Haskell.LSP.Test

32−import Language.Haskell.LSP.Messages

3320import Language.Haskell.LSP.Types

3421import Language.Haskell.LSP.Types.Capabilities

35−import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)

36−import Language.Haskell.LSP.VFS (applyChange)

37−import Network.URI

38−import System.Environment.Blank (getEnv, setEnv, unsetEnv)

22+import System.Environment.Blank (setEnv)

3923import System.FilePath

4024import System.IO.Extra

4125import System.Directory

42−import Test.QuickCheck

43−import Test.QuickCheck.Instances ()

4426import Test.Tasty

45−import Test.Tasty.ExpectedFailure

46−import Test.Tasty.Ingredients.Rerun

4727import Test.Tasty.HUnit

48−import Test.Tasty.QuickCheck

28+import Test.Tasty.ExpectedFailure

4929import Data.Maybe

5030

5131main :: IO ()

52−main = do

53− -- We mess with env vars so run single-threaded.

54− setEnv "TASTY_NUM_THREADS" "1" True

55− defaultMainWithRerun $ testGroup "HIE"

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− ]

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+ , findDefinitionAndHoverTests

43+ , pluginTests

44+ , thTests

45+ ]

8146

8247initializeResponseTests :: TestTree

8348initializeResponseTests = withResource acquire release tests where

@@ -92,14 +57,14 @@ initializeResponseTests = withResource acquire release tests where

9257 testGroup "initialize response capabilities"

9358 [ chk " text doc sync" _textDocumentSync tds

9459 , chk " hover" _hoverProvider (Just True)

95− , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing)

60+ , chk "NO completion" _completionProvider Nothing

9661 , chk "NO signature help" _signatureHelpProvider Nothing

9762 , chk " goto definition" _definitionProvider (Just True)

9863 , chk "NO goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic False)

9964 , chk "NO goto implementation" _implementationProvider (Just $ GotoOptionsStatic False)

10065 , chk "NO find references" _referencesProvider Nothing

10166 , chk "NO doc highlight" _documentHighlightProvider Nothing

102− , chk " doc symbol" _documentSymbolProvider (Just True)

67+ , chk "NO doc symbol" _documentSymbolProvider Nothing

10368 , chk "NO workspace symbol" _workspaceSymbolProvider Nothing

10469 , chk " code action" _codeActionProvider $ Just $ CodeActionOptionsStatic True

10570 , chk " code lens" _codeLensProvider $ Just $ CodeLensOptions Nothing

@@ -112,8 +77,8 @@ initializeResponseTests = withResource acquire release tests where

11277 , chk "NO doc link" _documentLinkProvider Nothing

11378 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)

11479 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)

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 )}))

80+ , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

81+ , chk "NO workspace" _workspace nothingWorkspace

11782 , chk "NO experimental" _experimental Nothing

11883 ] where

11984

@@ -124,21 +89,14 @@ initializeResponseTests = withResource acquire release tests where

12489 , _willSaveWaitUntil = Nothing

12590 , _save = Just (SaveOptions {_includeText = Nothing})}))

12691

92+ nothingWorkspace = Just (WorkspaceOptions {_workspaceFolders = Nothing})

93+

12794 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree

12895 chk title getActual expected =

12996 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir

13097

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−

14098 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner

141− innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c

99+ innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c

142100 innerCaps _ = error "this test only expects inner capabilities"

143101

144102 acquire :: IO InitializeResponse

@@ -152,7 +110,7 @@ diagnosticTests :: TestTree

152110diagnosticTests = testGroup "diagnostics"

153111 [ testSessionWait "fix syntax error" $ do

154112 let content = T.unlines [ "module Testing wher" ]

155− doc <- createDoc "Testing.hs" "haskell" content

113+ doc <- openDoc' "Testing.hs" "haskell" content

156114 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]

157115 let change = TextDocumentContentChangeEvent

158116 { _range = Just (Range (Position 0 15) (Position 0 19))

@@ -163,9 +121,9 @@ diagnosticTests = testGroup "diagnostics"

163121 expectDiagnostics [("Testing.hs", [])]

164122 , testSessionWait "introduce syntax error" $ do

165123 let content = T.unlines [ "module Testing where" ]

166− doc <- createDoc "Testing.hs" "haskell" content

167− void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)

168− void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)

124+ doc <- openDoc' "Testing.hs" "haskell" content

125+ void (message :: Session WorkDoneProgressCreateRequest)

126+ void (message :: Session WorkDoneProgressBeginNotification)

169127 let change = TextDocumentContentChangeEvent

170128 { _range = Just (Range (Position 0 15) (Position 0 18))

171129 , _rangeLength = Nothing

@@ -181,7 +139,7 @@ diagnosticTests = testGroup "diagnostics"

181139 , "bar :: Int -> Int -> Int"

182140 , "bar a b = cd + b"

183141 ]

184− _ <- createDoc "Testing.hs" "haskell" content

142+ _ <- openDoc' "Testing.hs" "haskell" content

185143 expectDiagnostics

186144 [ ( "Testing.hs"

187145 , [ (DsError, (2, 14), "Variable not in scope: ab")

@@ -195,7 +153,7 @@ diagnosticTests = testGroup "diagnostics"

195153 , "foo :: Int -> String -> Int"

196154 , "foo a b = a + b"

197155 ]

198− _ <- createDoc "Testing.hs" "haskell" content

156+ _ <- openDoc' "Testing.hs" "haskell" content

199157 expectDiagnostics

200158 [ ( "Testing.hs"

201159 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]

@@ -207,7 +165,7 @@ diagnosticTests = testGroup "diagnostics"

207165 , "foo :: Int -> String"

208166 , "foo a = _ a"

209167 ]

210− _ <- createDoc "Testing.hs" "haskell" content

168+ _ <- openDoc' "Testing.hs" "haskell" content

211169 expectDiagnostics

212170 [ ( "Testing.hs"

213171 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]

@@ -229,23 +187,24 @@ diagnosticTests = testGroup "diagnostics"

229187 [ ("A.hs", [(DsError, (2,4), aMessage)])

230188 , ("B.hs", [(DsError, (3,4), bMessage)])]

231189 deferralTest title binding msg = testSessionWait title $ do

232− _ <- createDoc "A.hs" "haskell" $ sourceA binding

233− _ <- createDoc "B.hs" "haskell" sourceB

190+ _ <- openDoc' "A.hs" "haskell" $ sourceA binding

191+ _ <- openDoc' "B.hs" "haskell" sourceB

234192 expectDiagnostics $ expectedDs msg

235193 in

236194 [ deferralTest "type error" "True" "Couldn't match expected type"

237195 , deferralTest "typed hole" "_" "Found hole"

238196 , deferralTest "out of scope var" "unbound" "Variable not in scope"

197+ , deferralTest "message shows error" "True" "A.hs:3:5: error:"

239198 ]

240199

241200 , testSessionWait "remove required module" $ do

242201 let contentA = T.unlines [ "module ModuleA where" ]

243− docA <- createDoc "ModuleA.hs" "haskell" contentA

202+ docA <- openDoc' "ModuleA.hs" "haskell" contentA

244203 let contentB = T.unlines

245204 [ "module ModuleB where"

246205 , "import ModuleA"

247206 ]

248− _ <- createDoc "ModuleB.hs" "haskell" contentB

207+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

249208 let change = TextDocumentContentChangeEvent

250209 { _range = Just (Range (Position 0 0) (Position 0 20))

251210 , _rangeLength = Nothing

@@ -258,21 +217,11 @@ diagnosticTests = testGroup "diagnostics"

258217 [ "module ModuleB where"

259218 , "import ModuleA"

260219 ]

261− _ <- createDoc "ModuleB.hs" "haskell" contentB

220+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

262221 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

263222 let contentA = T.unlines [ "module ModuleA where" ]

264− _ <- createDoc "ModuleA.hs" "haskell" contentA

223+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

265224 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", [])]

276225 , testSessionWait "cyclic module dependency" $ do

277226 let contentA = T.unlines

278227 [ "module ModuleA where"

@@ -282,8 +231,8 @@ diagnosticTests = testGroup "diagnostics"

282231 [ "module ModuleB where"

283232 , "import ModuleA"

284233 ]

285− _ <- createDoc "ModuleA.hs" "haskell" contentA

286− _ <- createDoc "ModuleB.hs" "haskell" contentB

234+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

235+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

287236 expectDiagnostics

288237 [ ( "ModuleA.hs"

289238 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]

@@ -304,9 +253,9 @@ diagnosticTests = testGroup "diagnostics"

304253 let contentBboot = T.unlines

305254 [ "module ModuleB where"

306255 ]

307− _ <- createDoc "ModuleA.hs" "haskell" contentA

308− _ <- createDoc "ModuleB.hs" "haskell" contentB

309− _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot

256+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

257+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

258+ _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot

310259 expectDiagnostics []

311260 , testSessionWait "correct reference used with hs-boot" $ do

312261 let contentB = T.unlines

@@ -328,10 +277,10 @@ diagnosticTests = testGroup "diagnostics"

328277 -- resolved to the hs-boot file

329278 , "y = x"

330279 ]

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

280+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

281+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

282+ _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot

283+ _ <- openDoc' "ModuleC.hs" "haskell" contentC

335284 expectDiagnostics []

336285 , testSessionWait "redundant import" $ do

337286 let contentA = T.unlines ["module ModuleA where"]

@@ -340,8 +289,8 @@ diagnosticTests = testGroup "diagnostics"

340289 , "module ModuleB where"

341290 , "import ModuleA"

342291 ]

343− _ <- createDoc "ModuleA.hs" "haskell" contentA

344− _ <- createDoc "ModuleB.hs" "haskell" contentB

292+ _ <- openDoc' "ModuleA.hs" "haskell" contentA

293+ _ <- openDoc' "ModuleB.hs" "haskell" contentB

345294 expectDiagnostics

346295 [ ( "ModuleB.hs"

347296 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]

@@ -350,7 +299,6 @@ diagnosticTests = testGroup "diagnostics"

350299 , testSessionWait "package imports" $ do

351300 let thisDataListContent = T.unlines

352301 [ "module Data.List where"

353− , "x :: Integer"

354302 , "x = 123"

355303 ]

356304 let mainContent = T.unlines

@@ -363,8 +311,8 @@ diagnosticTests = testGroup "diagnostics"

363311 , "wrong1 = ThisList.map"

364312 , "wrong2 = BaseList.x"

365313 ]

366− _ <- createDoc "Data/List.hs" "haskell" thisDataListContent

367− _ <- createDoc "Main.hs" "haskell" mainContent

314+ _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent

315+ _ <- openDoc' "Main.hs" "haskell" mainContent

368316 expectDiagnostics

369317 [ ( "Main.hs"

370318 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")

@@ -379,7 +327,7 @@ diagnosticTests = testGroup "diagnostics"

379327 , "foo :: Ord a => a -> Int"

380328 , "foo a = 1"

381329 ]

382− _ <- createDoc "Foo.hs" "haskell" fooContent

330+ _ <- openDoc' "Foo.hs" "haskell" fooContent

383331 expectDiagnostics

384332 [ ( "Foo.hs"

385333 -- The test is to make sure that warnings contain unqualified names

@@ -404,18 +352,18 @@ diagnosticTests = testGroup "diagnostics"

404352 Just pathB <- pure $ uriToFilePath uriB

405353 uriB <- pure $

406354 let (drive, suffix) = splitDrive pathB

407− in filePathToUri (joinDrive (lower drive) suffix)

355+ in filePathToUri (joinDrive (map toLower drive ) suffix)

408356 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)

409357 liftIO $ writeFileUTF8 pathB $ T.unpack bContent

410358 uriA <- getDocUri "A/A.hs"

411359 Just pathA <- pure $ uriToFilePath uriA

412360 uriA <- pure $

413361 let (drive, suffix) = splitDrive pathA

414− in filePathToUri (joinDrive (lower drive) suffix)

362+ in filePathToUri (joinDrive (map toLower drive ) suffix)

415363 let itemA = TextDocumentItem uriA "haskell" 0 aContent

416364 let a = TextDocumentIdentifier uriA

417365 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)

418− diagsNot <- skipManyTill anyMessage diagnostic

366+ diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification

419367 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)

420368 -- Check that if we put a lower-case drive in for A.A

421369 -- the diagnostics for A.B will also be lower-case.

@@ -424,38 +372,6 @@ diagnosticTests = testGroup "diagnostics"

424372 liftIO $ unless ("redundant" `T.isInfixOf` msg) $

425373 assertFailure ("Expected redundant import but got " <> T.unpack msg)

426374 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

459375 ]

460376

461377codeActionTests :: TestTree

@@ -463,46 +379,9 @@ codeActionTests = testGroup "code actions"

463379 [ renameActionTests

464380 , typeWildCardActionTests

465381 , removeImportTests

466− , extendImportTests

467− , suggestImportTests

468− , addExtensionTests

469− , fixConstructorImportTests

470382 , importRenameActionTests

471383 , fillTypedHoleTests

472384 , addSigActionTests

473− , insertNewDefinitionTests

474− ]

475−

476−codeLensesTests :: TestTree

477−codeLensesTests = testGroup "code lenses"

478− [ addSigLensesTests

479− ]

480−

481−watchedFilesTests :: TestTree

482−watchedFilesTests = testGroup "watched files"

483− [ testSession' "workspace files" $ \sessionDir -> do

484− liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"

485− _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"

486− watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

487−

488− -- Expect 4 subscriptions (A does not get any because it's VFS):

489− -- - /path-to-workspace/WatchedFilesMissingModule.hs

490− -- - /path-to-workspace/WatchedFilesMissingModule.lhs

491− -- - /path-to-workspace/src/WatchedFilesMissingModule.hs

492− -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs

493− liftIO $ length watchedFileRegs @?= 4

494−

495− , testSession' "non workspace file" $ \sessionDir -> do

496− liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"

497− _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"

498− watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

499−

500− -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):

501− -- - /path-to-workspace/WatchedFilesMissingModule.hs

502− -- - /path-to-workspace/WatchedFilesMissingModule.lhs

503− liftIO $ length watchedFileRegs @?= 2

504−

505− -- TODO add a test for didChangeWorkspaceFolder

506385 ]

507386

508387renameActionTests :: TestTree

@@ -513,9 +392,11 @@ renameActionTests = testGroup "rename actions"

513392 , "foo :: Int -> Int"

514393 , "foo argName = argNme"

515394 ]

516− doc <- createDoc "Testing.hs" "haskell" content

395+ doc <- openDoc' "Testing.hs" "haskell" content

517396 _ <- waitForDiagnostics

518− action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"

397+ [CACodeAction action@CodeAction { _title = actionTitle }]

398+ <- getCodeActions doc (Range (Position 2 14) (Position 2 20))

399+ liftIO $ "Replace with ‘argName’" @=? actionTitle

519400 executeCodeAction action

520401 contentAfterAction <- documentContents doc

521402 let expectedContentAfterAction = T.unlines

@@ -531,9 +412,11 @@ renameActionTests = testGroup "rename actions"

531412 , "foo :: Maybe a -> [a]"

532413 , "foo = maybToList"

533414 ]

534− doc <- createDoc "Testing.hs" "haskell" content

415+ doc <- openDoc' "Testing.hs" "haskell" content

535416 _ <- waitForDiagnostics

536− action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"

417+ [CACodeAction action@CodeAction { _title = actionTitle }]

418+ <- getCodeActions doc (Range (Position 3 6) (Position 3 16))

419+ liftIO $ "Replace with ‘maybeToList’" @=? actionTitle

537420 executeCodeAction action

538421 contentAfterAction <- documentContents doc

539422 let expectedContentAfterAction = T.unlines

@@ -549,11 +432,12 @@ renameActionTests = testGroup "rename actions"

549432 , "foo :: Char -> Char -> Char -> Char"

550433 , "foo argument1 argument2 argument3 = argumentX"

551434 ]

552− doc <- createDoc "Testing.hs" "haskell" content

435+ doc <- openDoc' "Testing.hs" "haskell" content

553436 _ <- waitForDiagnostics

554− _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))

555− ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]

556− return()

437+ actionsOrCommands <- getCodeActions doc (Range (Position 2 36) (Position 2 45))

438+ let actionTitles = [ actionTitle | CACodeAction CodeAction{ _title = actionTitle } <- actionsOrCommands ]

439+ expectedActionTitles = ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]

440+ liftIO $ expectedActionTitles @=? actionTitles

557441 , testSession "change infix function" $ do

558442 let content = T.unlines

559443 [ "module Testing where"

@@ -561,7 +445,7 @@ renameActionTests = testGroup "rename actions"

561445 , "monus x y = max 0 (x - y)"

562446 , "foo x y = x `monnus` y"

563447 ]

564− doc <- createDoc "Testing.hs" "haskell" content

448+ doc <- openDoc' "Testing.hs" "haskell" content

565449 _ <- waitForDiagnostics

566450 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))

567451 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]

@@ -584,7 +468,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

584468 , "func :: _"

585469 , "func x = x"

586470 ]

587− doc <- createDoc "Testing.hs" "haskell" content

471+ doc <- openDoc' "Testing.hs" "haskell" content

588472 _ <- waitForDiagnostics

589473 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

590474 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -604,7 +488,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

604488 , "func :: _"

605489 , "func x y = x + y"

606490 ]

607− doc <- createDoc "Testing.hs" "haskell" content

491+ doc <- openDoc' "Testing.hs" "haskell" content

608492 _ <- waitForDiagnostics

609493 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

610494 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -627,7 +511,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

627511 , " y = x * 2"

628512 , " in y"

629513 ]

630− doc <- createDoc "Testing.hs" "haskell" content

514+ doc <- openDoc' "Testing.hs" "haskell" content

631515 _ <- waitForDiagnostics

632516 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))

633517 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -652,15 +536,14 @@ removeImportTests = testGroup "remove import actions"

652536 let contentA = T.unlines

653537 [ "module ModuleA where"

654538 ]

655− _docA <- createDoc "ModuleA.hs" "haskell" contentA

539+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

656540 let contentB = T.unlines

657541 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

658542 , "module ModuleB where"

659543 , "import ModuleA"

660− , "stuffB :: Integer"

661544 , "stuffB = 123"

662545 ]

663− docB <- createDoc "ModuleB.hs" "haskell" contentB

546+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

664547 _ <- waitForDiagnostics

665548 [CACodeAction action@CodeAction { _title = actionTitle }]

666549 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -670,7 +553,6 @@ removeImportTests = testGroup "remove import actions"

670553 let expectedContentAfterAction = T.unlines

671554 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

672555 , "module ModuleB where"

673− , "stuffB :: Integer"

674556 , "stuffB = 123"

675557 ]

676558 liftIO $ expectedContentAfterAction @=? contentAfterAction

@@ -678,15 +560,14 @@ removeImportTests = testGroup "remove import actions"

678560 let contentA = T.unlines

679561 [ "module ModuleA where"

680562 ]

681− _docA <- createDoc "ModuleA.hs" "haskell" contentA

563+ _docA <- openDoc' "ModuleA.hs" "haskell" contentA

682564 let contentB = T.unlines

683565 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

684566 , "module ModuleB where"

685567 , "import qualified ModuleA"

686− , "stuffB :: Integer"

687568 , "stuffB = 123"

688569 ]

689− docB <- createDoc "ModuleB.hs" "haskell" contentB

570+ docB <- openDoc' "ModuleB.hs" "haskell" contentB

690571 _ <- waitForDiagnostics

691572 [CACodeAction action@CodeAction { _title = actionTitle }]

692573 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -696,457 +577,10 @@ removeImportTests = testGroup "remove import actions"

696577 let expectedContentAfterAction = T.unlines

697578 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

698579 , "module ModuleB where"

699− , "stuffB :: Integer"

700580 , "stuffB = 123"

701581 ]

702582 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− ])

1051583 ]

1052− where

1053− template initialContent range expectedAction expectedContents = do

1054− doc <- createDoc "Module.hs" "haskell" initialContent

1055− _ <- waitForDiagnostics

1056− CACodeAction action@CodeAction { _title = actionTitle } : _

1057− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1058− getCodeActions doc range

1059− liftIO $ expectedAction @=? actionTitle

1060− executeCodeAction action

1061− contentAfterAction <- documentContents doc

1062− liftIO $ expectedContents @=? contentAfterAction

1063−

1064−

1065−insertNewDefinitionTests :: TestTree

1066−insertNewDefinitionTests = testGroup "insert new definition actions"

1067− [ testSession "insert new function definition" $ do

1068− let txtB =

1069− ["foo True = select [True]"

1070− , ""

1071− ,"foo False = False"

1072− ]

1073− txtB' =

1074− [""

1075− ,"someOtherCode = ()"

1076− ]

1077− docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1078− _ <- waitForDiagnostics

1079− CACodeAction action@CodeAction { _title = actionTitle } : _

1080− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1081− getCodeActions docB (R 1 0 1 50)

1082− liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"

1083− executeCodeAction action

1084− contentAfterAction <- documentContents docB

1085− liftIO $ contentAfterAction @?= T.unlines (txtB ++

1086− [ ""

1087− , "select :: [Bool] -> Bool"

1088− , "select = error \"not implemented\""

1089− ]

1090− ++ txtB')

1091− , testSession "define a hole" $ do

1092− let txtB =

1093− ["foo True = _select [True]"

1094− , ""

1095− ,"foo False = False"

1096− ]

1097− txtB' =

1098− [""

1099− ,"someOtherCode = ()"

1100− ]

1101− docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1102− _ <- waitForDiagnostics

1103− CACodeAction action@CodeAction { _title = actionTitle } : _

1104− <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

1105− getCodeActions docB (R 1 0 1 50)

1106− liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"

1107− executeCodeAction action

1108− contentAfterAction <- documentContents docB

1109− liftIO $ contentAfterAction @?= T.unlines (

1110− ["foo True = select [True]"

1111− , ""

1112− ,"foo False = False"

1113− , ""

1114− , "select :: [Bool] -> Bool"

1115− , "select = error \"not implemented\""

1116− ]

1117− ++ txtB')

1118− ]

1119−

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

1150584

1151585importRenameActionTests :: TestTree

1152586importRenameActionTests = testGroup "import rename actions"

@@ -1157,7 +591,7 @@ importRenameActionTests = testGroup "import rename actions"

1157591 [ "module Testing where"

1158592 , "import Data.Mape"

1159593 ]

1160− doc <- createDoc "Testing.hs" "haskell" content

594+ doc <- openDoc' "Testing.hs" "haskell" content

1161595 _ <- waitForDiagnostics

1162596 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))

1163597 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]

@@ -1194,10 +628,10 @@ fillTypedHoleTests = let

1194628 newA newB newC = testSession (T.unpack actionTitle) $ do

1195629 let originalCode = sourceCode oldA oldB oldC

1196630 let expectedCode = sourceCode newA newB newC

1197− doc <- createDoc "Testing.hs" "haskell" originalCode

631+ doc <- openDoc' "Testing.hs" "haskell" originalCode

1198632 _ <- waitForDiagnostics

1199633 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))

1200− chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands

634+ let chosenAction = pickActionWithTitle actionTitle actionsOrCommands

1201635 executeCodeAction chosenAction

1202636 modifiedCode <- documentContents doc

1203637 liftIO $ expectedCode @=? modifiedCode

@@ -1234,81 +668,47 @@ fillTypedHoleTests = let

1234668

1235669addSigActionTests :: TestTree

1236670addSigActionTests = let

1237− header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"

1238− moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"

1239− before def = T.unlines [header, moduleH, def]

1240− after' def sig = T.unlines [header, moduleH, sig, def]

671+ header = T.unlines [ "{-# OPTIONS_GHC -Wmissing-signatures #-}"

672+ , "module Sigs where"]

673+ before def = T.unlines [header, def]

674+ after' def sig = T.unlines [header, sig, def]

1241675

1242676 def >:: sig = testSession (T.unpack def) $ do

1243677 let originalCode = before def

1244− let expectedCode = after' def sig

1245− doc <- createDoc "Sigs.hs" "haskell" originalCode

678+ let expectedCode = after' def sig

679+ doc <- openDoc' "Sigs.hs" "haskell" originalCode

1246680 _ <- waitForDiagnostics

1247681 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))

1248− chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

682+ let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

1249683 executeCodeAction chosenAction

1250684 modifiedCode <- documentContents doc

1251685 liftIO $ expectedCode @=? modifiedCode

1252686 in

1253687 testGroup "add signature"

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"

1261− ]

688+ [ "abc = True" >:: "abc :: Bool"

689+ , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"

690+ , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"

691+ , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"

692+ , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"

693+ , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"

694+ ]

1262695

1263−addSigLensesTests :: TestTree

1264−addSigLensesTests = let

1265− missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"

1266− notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"

1267− moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"

1268− other = T.unlines ["f :: Integer -> Integer", "f x = 3"]

1269− before withMissing def

1270− = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]

1271− after' withMissing def sig

1272− = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, sig, def, other]

696+findDefinitionAndHoverTests :: TestTree

697+findDefinitionAndHoverTests = let

1273698

1274− sigSession withMissing def sig = testSession (T.unpack def) $ do

1275− let originalCode = before withMissing def

1276− let expectedCode = after' withMissing def sig

1277− doc <- createDoc "Sigs.hs" "haskell" originalCode

1278− [CodeLens {_command = Just c}] <- getCodeLenses doc

1279− executeCommand c

1280− modifiedCode <- getDocumentEdit doc

1281− liftIO $ expectedCode @=? modifiedCode

1282− in

1283− testGroup "add signature"

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"

1292− ]

1293− | (title, enableWarnings) <-

1294− [("with warnings enabled", True)

1295− ,("with warnings disabled", False)

1296− ]

1297− ]

699+ tst (get, check) pos targetRange title = testSession title $ do

700+ doc <- openTestDataDoc sourceFilePath

701+ found <- get doc pos

702+ check found targetRange

1298703

1299−checkDefs :: [Location] -> Session [Expect] -> Session ()

1300−checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where

704+ checkDefs :: [Location] -> [Expect] -> Session ()

705+ checkDefs defs expectations = traverse_ check expectations where

1301706

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

707+ check (ExpectRange expectedRange) = do

708+ assertNDefinitionsFound 1 defs

709+ assertRangeCorrect (head defs) expectedRange

710+ check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"

711+ check _ = pure () -- all other expectations not relevant to getDefinition

1312712

1313713 assertNDefinitionsFound :: Int -> [a] -> Session ()

1314714 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)

@@ -1316,35 +716,23 @@ checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where

1316716 assertRangeCorrect Location{_range = foundRange} expectedRange =

1317717 liftIO $ expectedRange @=? foundRange

1318718

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

719+ checkHover :: Maybe Hover -> [Expect] -> Session ()

720+ checkHover hover expectations = traverse_ check expectations where

1332721

1333722 check expected =

1334723 case hover of

1335− Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"

724+ Nothing -> liftIO $ assertFailure "no hover found"

1336725 Just Hover{_contents = (HoverContents MarkupContent{_value = msg})

1337726 ,_range = rangeInHover } ->

1338727 case expected of

1339728 ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg

1340729 ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg

1341730 ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets

1342− ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover

1343731 _ -> pure () -- all other expectations not relevant to hover

1344732 _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover

1345733

1346734 extractLineColFromHoverMsg :: T.Text -> [T.Text]

1347− extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")

735+ extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "**" . last . T.splitOn (sourceFileName <> ":")

1348736

1349737 checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()

1350738 checkHoverRange expectedRange rangeInHover msg =

@@ -1371,12 +759,9 @@ findDefinitionAndHoverTests = let

1371759

1372760 mkFindTests tests = testGroup "get"

1373761 [ testGroup "definition" $ mapMaybe fst tests

1374− , testGroup "hover" $ mapMaybe snd tests

1375− , checkFileCompiles sourceFilePath ]

1376−

1377− test runDef runHover look expect = testM runDef runHover look (return expect)

762+ , testGroup "hover" $ mapMaybe snd tests ]

1378763

1379− testM runDef runHover look expect title =

764+ test runDef runHover look expect title =

1380765 ( runDef $ tst def look expect title

1381766 , runHover $ tst hover look expect title ) where

1382767 def = (getDefinitions, checkDefs)

@@ -1384,100 +769,59 @@ findDefinitionAndHoverTests = let

1384769 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out

1385770

1386771 -- search locations expectations on results

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]

772+ fffL4 = _start fffR ; fffR = mkRange 4 4 4 7 ; fff = [ExpectRange fffR]

773+ fffL8 = Position 8 4 ;

774+ fffL14 = Position 14 7 ;

775+ aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]

776+ dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]

777+ dcL12 = Position 12 11 ;

778+ xtcL5 = Position 5 11 ; xtc = [ExpectExternFail]

779+ tcL6 = Position 6 11 ; tcData = [mkR 3 0 5 16]

780+ vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]

781+ opL16 = Position 16 15 ; op = [mkR 17 2 17 4]

782+ opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]

783+ aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]

784+ b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]

785+ xvL20 = Position 20 8 ; xvMsg = [ExpectHoverText ["Data.Text.pack", ":: String -> Text"], ExpectExternFail]

786+ clL23 = Position 23 11 ; cls = [mkR 21 0 22 20]

787+ clL25 = Position 25 9

788+ eclL15 = Position 15 8 ; ecls = [ExpectHoverText ["Num"], ExpectExternFail]

789+ dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]

790+ dnbL30 = Position 30 23

791+ lcbL33 = Position 33 26 ; lcb = [ExpectHoverText [":: Char"], mkR 33 26 33 27]

792+ lclL33 = Position 33 22

1424793 in

1425794 mkFindTests

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)"

795+ -- def hover look expect

796+ [ test yes yes fffL4 fff "field in record definition"

797+ , test broken broken fffL8 fff "field in record construction"

798+ , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs

799+ , test yes yes aaaL14 aaa "top-level name" -- 120

800+ , test broken broken dcL7 tcDC "record data constructor"

801+ , test yes yes dcL12 tcDC "plain data constructor" -- 121

802+ , test yes broken tcL6 tcData "type constructor" -- 147

803+ , test broken broken xtcL5 xtc "type constructor from other package"

804+ , test broken yes xvL20 xvMsg "value from other package" -- 120

805+ , test yes yes vvL16 vv "plain parameter" -- 120

806+ , test yes yes aL18 apmp "pattern match name" -- 120

807+ , test yes yes opL16 op "top-level operator" -- 120, 123

808+ , test yes yes opL18 opp "parameter operator" -- 120

809+ , test yes yes b'L19 bp "name in backticks" -- 120

810+ , test yes broken clL23 cls "class in instance declaration"

811+ , test yes broken clL25 cls "class in signature" -- 147

812+ , test broken broken eclL15 ecls "external class in signature"

813+ , test yes yes dnbL29 dnb "do-notation bind" -- 137

814+ , test yes yes dnbL30 dnb "do-notation lookup"

815+ , test yes yes lcbL33 lcb "listcomp bind" -- 137

816+ , test yes yes lclL33 lcb "listcomp lookup"

1464817 ]

1465818 where yes, broken :: (TestTree -> Maybe TestTree)

1466819 yes = Just -- test should run and pass

1467820 broken = Just . (`xfail` "known broken")

1468− no = const Nothing -- don't run this test at all

1469−

1470−checkFileCompiles :: FilePath -> TestTree

1471−checkFileCompiles fp =

1472− testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do

1473− void (openTestDataDoc (dir </> fp))

1474− expectNoMoreDiagnostics 0.5

1475−

1476−

821+ -- no = const Nothing -- don't run this test at all

1477822

1478823pluginTests :: TestTree

1479−pluginTests = (`xfail8101` "known broken (#556)")

1480− $ testSessionWait "plugins" $ do

824+pluginTests = testSessionWait "plugins" $ do

1481825 let content =

1482826 T.unlines

1483827 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"

@@ -1491,100 +835,13 @@ pluginTests = (`xfail8101` "known broken (#556)")

1491835 , "foo :: Int -> Int -> Int"

1492836 , "foo a b = a + c"

1493837 ]

1494− _ <- createDoc "Testing.hs" "haskell" content

838+ _ <- openDoc' "Testing.hs" "haskell" content

1495839 expectDiagnostics

1496840 [ ( "Testing.hs",

1497841 [(DsError, (8, 14), "Variable not in scope: c")]

1498842 )

1499843 ]

1500844

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−

1588845thTests :: TestTree

1589846thTests =

1590847 testGroup

@@ -1610,586 +867,24 @@ thTests =

1610867 "b :: Integer",

1611868 "b = $(litE $ IntegerL $ a) + n"

1612869 ]

1613− _ <- createDoc "A.hs" "haskell" sourceA

1614− _ <- createDoc "B.hs" "haskell" sourceB

870+ _ <- openDoc' "A.hs" "haskell" sourceA

871+ _ <- openDoc' "B.hs" "haskell" sourceB

1615872 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]

1616− , testSessionWait "newtype-closure" $ do

1617− let sourceA =

1618− T.unlines

1619− [ "{-# LANGUAGE DeriveDataTypeable #-}"

1620− ,"{-# LANGUAGE TemplateHaskell #-}"

1621− ,"module A (a) where"

1622− ,"import Data.Data"

1623− ,"import Language.Haskell.TH"

1624− ,"newtype A = A () deriving (Data)"

1625− ,"a :: ExpQ"

1626− ,"a = [| 0 |]"]

1627− let sourceB =

1628− T.unlines

1629− [ "{-# LANGUAGE TemplateHaskell #-}"

1630− ,"module B where"

1631− ,"import A"

1632− ,"b :: Int"

1633− ,"b = $( a )" ]

1634− _ <- createDoc "A.hs" "haskell" sourceA

1635− _ <- createDoc "B.hs" "haskell" sourceB

1636− return ()

1637− ]

1638−

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 "*")]

1723873 ]

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')

1948874

1949875xfail :: TestTree -> String -> TestTree

1950876xfail = flip expectFailBecause

1951877

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−

1959878data Expect

1960879 = ExpectRange Range -- Both gotoDef and hover should report this range

1961− | ExpectLocation Location

1962880-- | ExpectDefRange Range -- Only gotoDef should report this range

1963881 | ExpectHoverRange Range -- Only hover should report this range

1964882 | ExpectHoverText [T.Text] -- the hover message must contain these snippets

1965883 | ExpectExternFail -- definition lookup in other file expected to fail

1966− | ExpectNoDefinitions

1967− | ExpectNoHover

1968884-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples

1969− deriving Eq

1970885

1971886mkR :: Int -> Int -> Int -> Int -> Expect

1972887mkR 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−

2193888----------------------------------------------------------------------

2194889-- Utils

2195890

@@ -2197,12 +892,6 @@ sessionDepsArePickedUp = testSession'

2197892testSession :: String -> Session () -> TestTree

2198893testSession name = testCase name . run

2199894

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−

2206895testSessionWait :: String -> Session () -> TestTree

2207896testSessionWait name = testSession name .

2208897 -- Check that any diagnostics produced were already consumed by the test case.

@@ -2213,284 +902,35 @@ testSessionWait name = testSession name .

2213902 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.

2214903 ( >> expectNoMoreDiagnostics 0.5)

2215904

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− ]

905+pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction

906+pickActionWithTitle title actions = head

907+ [ action

908+ | CACodeAction action@CodeAction{ _title = actionTitle } <- actions

909+ , title == actionTitle ]

2230910

2231911mkRange :: Int -> Int -> Int -> Int -> Range

2232912mkRange a b c d = Range (Position a b) (Position c d)

2233913

2234914run :: Session a -> IO a

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

915+run s = withTempDir $ \dir -> do

2255916 ghcideExe <- locateGhcideExecutable

2256917

2257918 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56

2258919 -- since the package import test creates "Data/List.hs", which otherwise has no physical home

2259920 createDirectoryIfMissing True $ dir ++ "/Data"

2260921

2261−

2262− let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]

922+ let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]

2263923 -- HIE calls getXgdDirectory which assumes that HOME is set.

2264924 -- Only sets HOME if it wasn't already set.

2265925 setEnv "HOME" "/homeless-shelter" False

2266− let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }

2267− runSessionWithConfig conf cmd lspTestCaps dir s

926+ runSessionWithConfig conf cmd fullCaps { _window = Just $ WindowClientCapabilities $ Just True } dir s

2268927 where

2269928 conf = defaultConfig

2270− -- If you uncomment this you can see all logging

929+ -- If you uncomment this you can see all messages

2271930 -- which can be quite useful for debugging.

2272− -- { logStdErr = True, logColor = False }

2273− -- If you really want to, you can also see all messages

2274− -- { logMessages = True, logColor = False }

931+ -- { logMessages = True, logColor = False, logStdErr = True }

2275932

2276933openTestDataDoc :: FilePath -> Session TextDocumentIdentifier

2277934openTestDataDoc path = do

2278935 source <- liftIO $ readFileUtf8 $ "test/data" </> path

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− ]

936+ openDoc' path "haskell" source

test/preprocessor/Main.hsdeleted−10

@@ -1,10 +0,0 @@

1−

2−module Main(main) where

3−

4−import System.Environment

5−

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+2−8

@@ -1,13 +1,10 @@

22-- SPDX-License-Identifier: Apache-2.0

4−{-# LANGUAGE DuplicateRecordFields #-}

5−

64module Development.IDE.Test

75 ( Cursor

86 , cursorPosition

97 , requireDiagnostic

10− , diagnostic

118 , expectDiagnostics

129 , expectNoMoreDiagnostics

1310 ) where

@@ -18,7 +15,7 @@ import Control.Monad

1815import Control.Monad.IO.Class

1916import qualified Data.Map.Strict as Map

2017import qualified Data.Text as T

21−import Language.Haskell.LSP.Test hiding (message)

18+import Language.Haskell.LSP.Test hiding (message, openDoc')

2219import qualified Language.Haskell.LSP.Test as LspTest

2320import Language.Haskell.LSP.Types

2421import Language.Haskell.LSP.Types.Lens as Lsp

@@ -80,7 +77,7 @@ expectDiagnostics expected = do

8077 go m

8178 | Map.null m = pure ()

8279 | otherwise = do

83− diagsNot <- skipManyTill anyMessage diagnostic

80+ diagsNot <- skipManyTill anyMessage LspTest.message :: Session PublishDiagnosticsNotification

8481 let fileUri = diagsNot ^. params . uri

8582 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of

8683 Nothing -> do

@@ -99,9 +96,6 @@ expectDiagnostics expected = do

9996 " but got " <> show actual

10097 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m

10198

102−diagnostic :: Session PublishDiagnosticsNotification

103−diagnostic = LspTest.message

104−

10599standardizeQuotes :: T.Text -> T.Text

106100standardizeQuotes msg = let

107101 repl '‘' = '\''