368cff7...master · ghcide

git.iko.soy/ghcide

75 files changed+8286−1535

since splitsnapshots

unifiedsplit

.azure/linux-stack.ymlnew file+63

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

1+jobs:

2+- job: ghcide_stack_linux

3+ timeoutInMinutes: 60

4+ pool:

5+ vmImage: 'ubuntu-latest'

6+ strategy:

7+ matrix:

8+ stack_810:

9+ STACK_YAML: "stack810.yaml"

10+ stack_88:

11+ STACK_YAML: "stack88.yaml"

12+ stack_86:

13+ STACK_YAML: "stack.yaml"

14+ stack_84:

15+ STACK_YAML: "stack84.yaml"

16+ stack_ghc_lib_88:

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

18+ steps:

19+ - checkout: self

20+ - task: Cache@2

21+ inputs:

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

23+ path: .azure-cache

24+ cacheHitVar: CACHE_RESTORED

25+ displayName: "Cache stack artifacts"

26+ - bash: |

27+ mkdir -p ~/.stack

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

29+ displayName: "Unpack cache"

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

31+ - bash: |

32+ ./fmt.sh

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

34+ - bash: |

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

36+ sudo apt-get update

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

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

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

40+ fi

41+ displayName: 'Install Stack'

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

43+ displayName: 'stack setup'

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

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

46+ - bash: |

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

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

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

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

51+ - bash: |

52+ mkdir -p .azure-cache

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

54+ displayName: "Pack cache"

55+ - bash: |

56+ set -euo pipefail

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

58+ curl -XPOST \

59+ -i \

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

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

62+ $(Slack.URL)

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

.azure/windows-stack.ymlnew file+68

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

1+jobs:

2+- job: ghcide_stack_windows

3+ timeoutInMinutes: 60

4+ pool:

5+ vmImage: 'windows-2019'

6+ strategy:

7+ matrix:

8+ stack_810:

9+ STACK_YAML: "stack810.yaml"

10+ stack_88:

11+ STACK_YAML: "stack88.yaml"

12+ stack_86:

13+ STACK_YAML: "stack.yaml"

14+ stack_84:

15+ STACK_YAML: "stack84.yaml"

16+ stack_ghc_lib_88:

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

18+ variables:

19+ STACK_ROOT: "C:\\sr"

20+ steps:

21+ - checkout: self

22+ - task: Cache@2

23+ inputs:

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

25+ path: .azure-cache

26+ cacheHitVar: CACHE_RESTORED

27+ displayName: "Cache stack artifacts"

28+ - bash: |

29+ mkdir -p $STACK_ROOT

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

31+ mkdir -p .stack-work

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

33+ displayName: "Unpack cache"

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

35+ - bash: |

36+ ./fmt.sh

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

38+ - bash: |

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

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

41+ mkdir -p "$STACK_ROOT"

42+ displayName: 'Install Stack'

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

44+ displayName: 'stack setup'

45+ - bash: |

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

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

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

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

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

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

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

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

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

55+ - bash: |

56+ mkdir -p .azure-cache

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

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

59+ displayName: "Pack cache"

60+ - bash: |

61+ set -euo pipefail

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

63+ curl -XPOST \

64+ -i \

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

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

67+ $(Slack.URL)

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

.editorconfignew file+11

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

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

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

4+root = true

6+[*]

7+end_of_line = LF

8+indent_style = space

9+indent_size = 4

10+trim_trailing_whitespace = true

11+insert_final_newline = true

.ghcideleted−25

@@ -1,25 +0,0 @@

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

2−

3−:set -XBangPatterns

4−:set -XDeriveFunctor

5−:set -XDeriveGeneric

6−:set -XGeneralizedNewtypeDeriving

7−:set -XLambdaCase

8−:set -XNamedFieldPuns

9−:set -XOverloadedStrings

10−:set -XRecordWildCards

11−:set -XScopedTypeVariables

12−:set -XStandaloneDeriving

13−:set -XTupleSections

14−:set -XTypeApplications

15−:set -XViewPatterns

16−

17−:set -package=ghc

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

19−:set -DGHC_STABLE

20−:set -Iinclude

21−:set -idist/build/autogen

22−:set -isrc

23−:set -iexe

24−

25−:load Main

.gitignore+4

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

44cabal.project.local

55*~

66*.lock

7+/.tasty-rerun-log

8+.vscode

9+/.hlint-*

10+bench/example

.hlint.yaml+5−1

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

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

7474

7575 # Shady extensions

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

7776 - name: CPP

7877 within:

78+ - Development.IDE.Compat

7979 - Development.IDE.Core.FileStore

8080 - Development.IDE.Core.Compile

81+ - Development.IDE.Core.Rules

8182 - Development.IDE.GHC.Compat

83+ - Development.IDE.GHC.Orphans

8284 - Development.IDE.GHC.Util

8385 - Development.IDE.Import.FindImports

86+ - Development.IDE.LSP.Outline

8487 - Development.IDE.Spans.Calculate

8588 - Development.IDE.Spans.Documentation

8689 - Development.IDE.Spans.Common

8790 - Development.IDE.Plugin.CodeAction

91+ - Development.IDE.Plugin.Completions

8892 - Development.IDE.Plugin.Completions.Logic

8993 - Main

9094

CHANGELOG.md+20

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

11### unreleased

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

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

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

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

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

9+ files) (thanks @jinwoo)

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

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

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

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

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

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

16+ @pepeiborra)

17+* Minor improvements to completions

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

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

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

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

22+

323### 0.1.0 (2020-02-04)

424

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

README.md+62−3

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

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

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

2727

28+

29+## Limitations to Multi-Component support

30+

31+`ghcide` supports loading multiple components into the same session so that

32+features such as go-to definition work across components. However, there are

33+some limitations to this.

34+

35+1. You will get much better results currently manually specifying the hie.yaml file.

36+Until tools like cabal and stack provide the right interface to support multi-component

37+projects, it is always advised to specify explicitly how your project partitions.

38+2. Cross-component features only work if you have loaded at least one file

39+from each component.

40+3. There is a known issue where if you have three components, such that A depends on B which depends on C

41+then if you load A and C into the session but not B then under certain situations you

42+can get strange errors about a type coming from two different places. See [this repo](https://github.com/fendor/ghcide-bad-interface-files) for

43+a simple reproduction of the bug.

44+

2845## Using it

2946

3047### Install `ghcide`

3148

3249#### With Nix

3350

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

51+Note that you need to compile `ghcide` with the same `ghc` as the project you are working on.

52+

53+1. If the `ghc` you are using matches the version (or better is) from `nixpkgs` it‘s easiest to use the `ghcide` from `nixpkgs`. You can do so via

54+ ```

55+ nix-env -iA haskellPackages.ghcide

56+ ```

57+ or e.g. including `pkgs.haskellPackages.ghcide` in your projects `shell.nix`.

58+ Depending on your `nixpkgs` channel that might not be the newest `ghcide`, though.

59+

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

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

3562

3663#### With Cabal or Stack

3764

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

6491

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

6693

94+### Optimal project setup

95+

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

97+

6798### Using with VS Code

6899

69100You can install the VSCode extension from the [VSCode

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

203234```

204235

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

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

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

238+

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

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

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

207242

208243### SpaceVim

209244

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

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

249284using `stack install ghcide` within a project.

250285

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+

251300## Hacking on ghcide

252301

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

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

255312

256313### Building the extension

257314

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

268325

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

270327

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+

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

272331

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

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

274333

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

azure-pipelines.yml+3−184

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

44 branches:

55 include:

66 - master

7+ - azure*

89# Enable PR triggers that target the master branch

910pr:

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

1314 - master

1415

1516jobs:

16− - job: ghcide_stack_86

17− timeoutInMinutes: 60

18− pool:

19− vmImage: 'ubuntu-latest'

20− steps:

21− - checkout: self

22− - task: CacheBeta@0

23− inputs:

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

25− path: .azure-cache

26− cacheHitVar: CACHE_RESTORED

27− displayName: "Cache stack artifacts"

28− - bash: |

29− mkdir -p ~/.stack

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

31− displayName: "Unpack cache"

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

33− - bash: |

34− ./fmt.sh

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

36− - bash: |

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

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

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

40− fi

41− displayName: 'Install Stack'

42− - bash: stack setup

43− displayName: 'stack setup'

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

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

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

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

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

49− - bash: |

50− mkdir -p .azure-cache

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

52− displayName: "Pack cache"

53− - bash: |

54− set -euo pipefail

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

56− curl -XPOST \

57− -i \

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

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

60− $(Slack.URL)

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

62− - job: ghcide_stack_84

63− timeoutInMinutes: 60

64− pool:

65− vmImage: 'ubuntu-latest'

66− steps:

67− - checkout: self

68− - task: CacheBeta@0

69− inputs:

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

71− path: .azure-cache

72− cacheHitVar: CACHE_RESTORED

73− displayName: "Cache stack artifacts"

74− - bash: |

75− mkdir -p ~/.stack

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

77− displayName: "Unpack cache"

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

79− - bash: |

80− ./fmt.sh

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

82− - bash: |

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

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

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

86− fi

87− displayName: 'Install Stack'

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

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

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

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

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

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

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

95− - bash: |

96− mkdir -p .azure-cache

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

98− displayName: "Pack cache"

99− - bash: |

100− set -euo pipefail

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

102− curl -XPOST \

103− -i \

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

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

106− $(Slack.URL)

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

108− - job: ghcide_stack_88

109− timeoutInMinutes: 60

110− pool:

111− vmImage: 'ubuntu-latest'

112− steps:

113− - checkout: self

114− - task: CacheBeta@0

115− inputs:

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

117− path: .azure-cache

118− cacheHitVar: CACHE_RESTORED

119− displayName: "Cache stack artifacts"

120− - bash: |

121− mkdir -p ~/.stack

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

123− displayName: "Unpack cache"

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

125− - bash: |

126− ./fmt.sh

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

128− - bash: |

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

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

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

132− fi

133− displayName: 'Install Stack'

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

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

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

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

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

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

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

141− - bash: |

142− mkdir -p .azure-cache

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

144− displayName: "Pack cache"

145− - bash: |

146− set -euo pipefail

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

148− curl -XPOST \

149− -i \

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

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

152− $(Slack.URL)

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

154− - job: ghcide_stack_ghc_lib_88

155− timeoutInMinutes: 60

156− pool:

157− vmImage: 'ubuntu-latest'

158− steps:

159− - checkout: self

160− - task: CacheBeta@0

161− inputs:

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

163− path: .azure-cache

164− cacheHitVar: CACHE_RESTORED

165− displayName: "Cache stack artifacts"

166− - bash: |

167− mkdir -p ~/.stack

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

169− displayName: "Unpack cache"

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

171− - bash: |

172− ./fmt.sh

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

174− - bash: |

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

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

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

178− fi

179− displayName: 'Install Stack'

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

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

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

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

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

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

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

187− - bash: |

188− mkdir -p .azure-cache

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

190− displayName: "Pack cache"

191− - bash: |

192− set -euo pipefail

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

194− curl -XPOST \

195− -i \

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

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

198− $(Slack.URL)

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

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

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

bench/Main.hsnew file+287

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

1+{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE ExistentialQuantification #-}

3+{-# LANGUAGE ImplicitParams #-}

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

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

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

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

11+

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

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

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

15+

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

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

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

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

20+

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

22+

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

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

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

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

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

28+

29+ How to run:

30+ 1. `cabal bench`

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

32+

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

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

35+ produce the same results.

36+

37+ -}

38+

39+import Control.Applicative.Combinators

40+import Control.Concurrent

41+import Control.Exception.Safe

42+import Control.Monad.Extra

43+import Control.Monad.IO.Class

44+import Data.Aeson

45+import Data.List

46+import Data.Maybe

47+import Data.Version

48+import Language.Haskell.LSP.Test

49+import Language.Haskell.LSP.Types

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

51+import Numeric.Natural

52+import Options.Applicative

53+import System.Directory

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

55+import System.Process

56+import System.Time.Extra

57+

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

59+-- convenient for hygienic edits

60+hygienicP :: Position

61+hygienicP = Position 854 23

62+

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

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

65+identifierP :: Position

66+identifierP = Position 853 12

67+

68+main :: IO ()

69+main = do

70+ config <- execParser $ info configP fullDesc

71+ let ?config = config

72+

73+ output "starting test"

74+

75+ cleanUp <- setup

76+

77+ runBenchmarks

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

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

80+ isJust <$> getHover doc identifierP,

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

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

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

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

85+ bench "documentSymbols" 100 $

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

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

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

89+ let change =

90+ TextDocumentContentChangeEvent

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

92+ _rangeLength = Nothing,

93+ _text = " "

94+ }

95+ changeDoc doc [change]

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

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

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

99+ let change =

100+ TextDocumentContentChangeEvent

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

102+ _rangeLength = Nothing,

103+ _text = " "

104+ }

105+ changeDoc doc [change]

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

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

108+ benchWithSetup

109+ "code actions"

110+ 10

111+ ( \doc -> do

112+ let p = identifierP

113+ let change =

114+ TextDocumentContentChangeEvent

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

116+ _rangeLength = Nothing,

117+ _text = "a"

118+ }

119+ changeDoc doc [change]

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

121+ return p

122+ )

123+ ( \p doc -> do

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

125+ ),

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

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

128+ let p = identifierP

129+ let change =

130+ TextDocumentContentChangeEvent

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

132+ _rangeLength = Nothing,

133+ _text = "a"

134+ }

135+ changeDoc doc [change]

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

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

138+ ]

139+ `finally` cleanUp

140+

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

142+

143+examplePackageName :: String

144+examplePackageName = "Cabal"

145+

146+examplePackageVersion :: Version

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

148+

149+examplePackage :: String

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

151+

152+exampleModulePath :: FilePath

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

154+

155+examplesPath :: FilePath

156+examplesPath = "bench/example"

157+

158+data Config = Config

159+ { verbose :: !Bool,

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

161+ shakeProfiling :: !(Maybe FilePath),

162+ outputCSV :: !Bool

163+ }

164+

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

166+

167+configP :: Parser Config

168+configP = Config

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

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

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

172+

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

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

175+

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

177+

178+type Experiment = TextDocumentIdentifier -> Session Bool

179+

180+data Bench = forall setup.

181+ Bench

182+ { name :: !String,

183+ samples :: !Natural,

184+ benchSetup :: TextDocumentIdentifier -> Session setup,

185+ experiment :: setup -> Experiment

186+ }

187+

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

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

190+ where

191+ experiment () = userExperiment

192+ benchSetup _ = return ()

193+

194+benchWithSetup ::

195+ String ->

196+ Natural ->

197+ (TextDocumentIdentifier -> Session p) ->

198+ (p -> Experiment) ->

199+ Bench

200+benchWithSetup = Bench

201+

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

203+runBenchmarks benchmarks = do

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

205+

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

207+ output $

208+ "TOTAL "

209+ <> name

210+ <> " = "

211+ <> showDuration duration

212+ <> " ("

213+ <> show samples

214+ <> " repetitions)"

215+

216+ when (outputCSV ?config) $ do

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

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

219+

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

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

222+ $ runSessionWithConfig conf cmd lspTestCaps dir

223+ $ do

224+ doc <- openDoc exampleModulePath "haskell"

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

226+

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

228+ userState <- benchSetup doc

229+ let loop 0 = return True

230+ loop n = do

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

232+ if not res

233+ then return False

234+ else do

235+ output (showDuration t)

236+ loop (n -1)

237+

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

239+

240+ exitServer

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

242+ liftIO $ threadDelay 50000

243+

244+ return $ if res then t else -1

245+ where

246+ cmd =

247+ unwords $

248+ [ "ghcide",

249+ "--lsp",

250+ "--cwd",

251+ dir,

252+ "+RTS",

253+ "-S",

254+ "-RTS"

255+ ]

256+ ++ concat

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

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

259+ ]

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

261+ lspTestCaps =

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

263+ conf =

264+ defaultConfig

265+ { logStdErr = verbose ?config,

266+ logMessages = False,

267+ logColor = False

268+ }

269+

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

271+setup = do

272+ alreadyExists <- doesDirectoryExist examplesPath

273+ when alreadyExists $ removeDirectoryRecursive examplesPath

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

275+ writeFile

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

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

278+

279+ whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True

280+

281+ return $ removeDirectoryRecursive examplesPath

282+

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

284+exitServer :: Session ()

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

286+

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

docs/Setup.md+38−1

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

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

5555```

5656

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

58+

59+ $ stack ide targets

60+ mypackage:lib

61+ mypackage:exe:mypackage-exe

62+ mypackage:test:mypackage-test

63+

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

65+

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

67+

5768## ghc: readCreateProcess: does not exist

5869

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

71+

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

6073

6174And we figured a hack around for this:

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

6982

7083## Could not find module ...

7184

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

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

86+

87+## Ambiguous main module

88+

89+```console

90+$ stack exec ghcide

91+

92+...

93+

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

95+```

96+

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

98+

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

73100

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

75102

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

106133## Docker stack builds

107134

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

136+

137+## stty error on Windows + Stack

138+

139+If you get an error like:

140+

141+```

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

143+```

144+

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

exe/Arguments.hs+4

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

1212 ,argFiles :: [FilePath]

1313 ,argsVersion :: Bool

1414 ,argsShakeProfiling :: Maybe FilePath

15+ ,argsTesting :: Bool

16+ ,argsThreads :: Int

1517 }

1618

1719getArguments :: IO Arguments

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

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

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

3133 <*> 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+538−82

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

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

55{-# LANGUAGE TemplateHaskell #-}

6+{-# LANGUAGE TypeFamilies #-}

78module Main(main) where

10+import Linker (initDynLinker)

11+import Data.IORef

12+import NameCache

13+import Packages

14+import Module

915import Arguments

10−import Data.Maybe

11−import Data.List.Extra

12−import System.FilePath

16+import Control.Concurrent.Async

1317import Control.Concurrent.Extra

1418import Control.Exception

1519import Control.Monad.Extra

1620import Control.Monad.IO.Class

1721import Data.Default

18−import System.Time.Extra

22+import Data.Either

23+import Data.Function

24+import Data.List.Extra

25+import Data.Maybe

26+import qualified Data.Text as T

27+import qualified Data.Text.IO as T

28+import Data.Time.Clock (UTCTime)

29+import Data.Version

30+import Development.IDE.Core.Debouncer

1931import Development.IDE.Core.FileStore

2032import Development.IDE.Core.OfInterest

2133import Development.IDE.Core.Service

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

3143import Development.IDE.Plugin

3244import Development.IDE.Plugin.Completions as Completions

3345import Development.IDE.Plugin.CodeAction as CodeAction

34−import qualified Data.Text as T

35−import qualified Data.Text.IO as T

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

3647import Language.Haskell.LSP.Messages

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

38−import Linker

39−import Data.Version

48+import Language.Haskell.LSP.Types

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

4050import Development.IDE.LSP.LanguageServer

41−import System.Directory.Extra as IO

51+import qualified System.Directory.Extra as IO

4252import System.Environment

4353import System.IO

4454import System.Exit

55+import System.FilePath

56+import System.Directory

57+import System.Time.Extra

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

4559import Paths_ghcide

4660import Development.GitRev

4761import Development.Shake (Action, action)

48−import qualified Data.Set as Set

62+import qualified Data.HashSet as HashSet

63+import qualified Data.HashMap.Strict as HM

4964import qualified Data.Map.Strict as Map

50−

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)

5171import GHC hiding (def)

52−import qualified GHC.Paths

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

73+import Data.Either.Extra

5374

54−import HIE.Bios

75+import HIE.Bios.Cradle

76+import HIE.Bios.Types

5577

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

57−getLibdir :: IO FilePath

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

78+import Utils

5979

6080ghcideVersion :: IO String

6181ghcideVersion = do

@@ -82,74 +102,68 @@ main = do

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

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

84104

85− whenJust argsCwd setCurrentDirectory

105+ whenJust argsCwd IO.setCurrentDirectory

86106

87− dir <- getCurrentDirectory

107+ dir <- IO.getCurrentDirectory

108+ command <- makeLspCommandId "typesignature.add"

88109

89110 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+ }

90116

91117 if argLSP then do

92118 t <- offsetTime

93119 hPutStrLn stderr "Starting LSP server..."

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

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

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

96122 t <- t

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

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

99− session <- loadSession dir

100− let options = (defaultIdeOptions $ return session)

124+ let options = (defaultIdeOptions $ loadSessionShake dir)

101125 { optReportProgress = clientSupportsProgress caps

102126 , optShakeProfiling = argsShakeProfiling

127+ , optTesting = argsTesting

128+ , optThreads = argsThreads

103129 }

104− initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event (logger minBound) options vfs

130+ debouncer <- newAsyncDebouncer

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

132+ getLspId event (logger minBound) debouncer options vfs

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

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

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

108140

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

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

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

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

112− files <- nubOrd <$> mapM canonicalizePath files

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

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

114146

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

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

116148 cradles <- mapM findCradle files

117149 let ucradles = nubOrd cradles

118150 let n = length ucradles

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

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

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

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

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

124− when (isNothing x) $ print cradle

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

126− cradleToSession cradle

127−

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

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

129153 vfs <- makeVFSHandle

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

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

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

133− cradle <- Map.lookup file filesToCradles

134− Map.lookup cradle cradlesToSessions

135−

136− let options =

137− (defaultIdeOptions $ return $ return . grab)

138− { optShakeProfiling = argsShakeProfiling }

139− ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) options vfs

140−

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

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

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

154+ debouncer <- newAsyncDebouncer

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

156+

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

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

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

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

145161 when (failed /= []) $

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

147163

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

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

150−

151− unless (null failed) exitFailure

152−

166+ return ()

153167

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

155169expandFiles = concatMapM $ \x -> do

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

158172 let recurse "." = True

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

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

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

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

162176 when (null files) $

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

164178 return files

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

167181kick :: Action ()

168182kick = do

169183 files <- getFilesOfInterest

170− void $ uses TypeCheck $ Set.toList files

184+ void $ uses TypeCheck $ HashSet.toList files

171185

172186-- | Print an LSP event.

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

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

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

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

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

177191showEvent lock e = withLock lock $ print e

178192

179193

180−cradleToSession :: Cradle a -> IO HscEnvEq

181−cradleToSession cradle = do

182− cradleRes <- getCompilerOptions "" cradle

183− opts <- case cradleRes of

184− CradleSuccess r -> pure r

185− CradleFail err -> throwIO err

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

187− -- That will require some more changes.

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

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

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

196+cradleToSessionOpts cradle file = do

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

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

199+ case cradleRes of

200+ CradleSuccess r -> pure (Right r)

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

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

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

204+ CradleNone -> return (Left [])

205+

206+emptyHscEnv :: IO HscEnv

207+emptyHscEnv = do

189208 libdir <- getLibdir

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

191− _targets <- initSession opts

192− getSession

209+ env <- runGhc (Just libdir) getSession

193210 initDynLinker env

194− newHscEnvEq env

211+ pure env

212+

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

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

215+-- directories

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

217+-- to canonicalise it.

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

219+targetToFile is (TargetModule mod) = do

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

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

222+ mapM (fmap toNormalizedFilePath' . canonicalizePath) fps

223+targetToFile _ (TargetFile f _) = do

224+ f' <- canonicalizePath f

225+ return [toNormalizedFilePath' f']

226+

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

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

229+

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

231+loadSessionShake fp = do

232+ se <- getShakeExtras

233+ IdeOptions{optTesting} <- getIdeOptions

234+ res <- liftIO $ loadSession optTesting se fp

235+ return (fmap liftIO res)

236+

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

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

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

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

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

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

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

244+ -- Mapping from a Filepath to HscEnv

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

246+

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

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

249+ res <- findCradle v

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

251+ -- try and normalise that

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

253+ res' <- traverse IO.makeAbsolute res

254+ return $ normalise <$> res'

255+

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

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

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

259+ -- which contains the union.

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

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

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

263+ -- Parse DynFlags for the newly discovered component

264+ hscEnv <- emptyHscEnv

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

266+ setOptions opts (hsc_dflags hscEnv)

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

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

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

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

271+ -- (unitId, DynFlag, Targets)

272+ modifyVar hscEnvs $ \m -> do

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

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

275+ let oldDeps = Map.lookup hieYaml m

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

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

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

279+ -- information.

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

281+ : maybe [] snd oldDeps

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

283+ inplace = map rawComponentUnitId new_deps

284+

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

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

287+ -- components in this HscEnv

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

289+ let prefix = show rawComponentUnitId

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

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

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

293+ -- contain any packages which are also loaded

294+ -- into the same component.

295+ pure $ ComponentInfo rawComponentUnitId

296+ processed_df

297+ uids

298+ rawComponentTargets

299+ rawComponentFP

300+ rawComponentCOptions

301+ rawComponentDependencyInfo

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

303+ -- scratch again (for now)

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

305+ -- that I do not fully understand

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

307+ hscEnv <- case oldDeps of

308+ Nothing -> emptyHscEnv

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

310+ newHscEnv <-

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

312+ evalGhcEnv hscEnv $ do

313+ _ <- setSessionDynFlags df

314+ getSession

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

316+ -- HscEnv

317+ -- Returns

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

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

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

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

322+ -- existing packages

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

324+

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

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

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

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

329+ -- resolve imports. (especially PackageImports)

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

331+

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

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

334+

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

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

337+ let new_cache = newComponentCache logger hscEnv uids

338+ (cs, res) <- new_cache new

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

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

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

342+ modifyVar_ fileToFlags $ \var -> do

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

344+

345+ return (fst res)

346+

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

348+ consultCradle hieYaml cfp = do

349+ when optTesting $ eventer $ notifyCradleLoaded cfp

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

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

352+ eopts <- cradleToSessionOpts cradle cfp

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

354+ case eopts of

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

356+ -- into and HscEnv.

357+ Right opts -> do

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

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

360+ Left err -> do

361+ dep_info <- getDependencyInfo (maybeToList hieYaml)

362+ let ncfp = toNormalizedFilePath' cfp

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

364+ modifyVar_ fileToFlags $ \var -> do

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

366+ return res

367+

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

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

370+ sessionOpts (hieYaml, file) = do

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

372+ cfp <- canonicalizePath file

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

374+ Just (opts, old_di) -> do

375+ deps_ok <- checkDependencyInfo old_di

376+ if not deps_ok

377+ then do

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

379+ -- again.

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

381+ -- Keep the same name cache

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

383+ consultCradle hieYaml cfp

384+ else return opts

385+ Nothing -> consultCradle hieYaml cfp

195386

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)

196403

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

198−loadSession dir = do

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

200− res <- findCradle v

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

202− -- try and normalise that

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

204− res' <- traverse makeAbsolute res

205− return $ normalise <$> res'

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

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

208− cradleToSession c

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

210404

211405

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+

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

213593--

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

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

225605 res <- onceFork $ op k

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

227607 Just res -> return (mp, res)

608+

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

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

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

612+ let dflags'' =

613+ -- disabled, generated directly by ghcide instead

614+ flip gopt_unset Opt_WriteInterface $

615+ -- disabled, generated directly by ghcide instead

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

617+ dontWriteHieFiles $

618+ setIgnoreInterfacePragmas $

619+ setLinkerOptions $

620+ disableOptimisation $

621+ makeDynFlagsAbsolute compRoot dflags'

622+ -- initPackages parses the -package flags and

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

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

625+ return (final_df, targets)

626+

627+

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

629+-- (HscInterpreted) which implies LinkInMemory

630+-- HscInterpreted

631+setLinkerOptions :: DynFlags -> DynFlags

632+setLinkerOptions df = df {

633+ ghcLink = LinkInMemory

634+ , hscTarget = HscNothing

635+ , ghcMode = CompManager

636+ }

637+

638+setIgnoreInterfacePragmas :: DynFlags -> DynFlags

639+setIgnoreInterfacePragmas df =

640+ gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges

641+

642+disableOptimisation :: DynFlags -> DynFlags

643+disableOptimisation df = updOptLevel 0 df

644+

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

646+setHiDir f d =

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

648+ d { hiDir = Just f}

649+

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

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

652+ where

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

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

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

656+

657+-- | Sub directory for the cache path

658+cacheDir :: String

659+cacheDir = "ghcide"

660+

661+notifyCradleLoaded :: FilePath -> FromServerMessage

662+notifyCradleLoaded fp =

663+ NotCustomServer $

664+ NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $

665+ toJSON fp

666+

667+cradleLoadedMethod :: T.Text

668+cradleLoadedMethod = "ghcide/cradle/loaded"

669+

670+ghcVersionChecker :: IO VersionCheck

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

672+

673+checkGhcVersion :: IO (Maybe HscEnvEq)

674+checkGhcVersion = do

675+ res <- ghcVersionChecker

676+ case res of

677+ Failure err -> do

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

679+ return Nothing

680+ Mismatch {..} ->

681+ return $ Just GhcVersionMismatch {..}

682+ _ ->

683+ return Nothing

exe/Utils.hsnew file+9

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

1+module Utils (getLibdir) where

3+import qualified GHC.Paths

4+import System.Environment

5+import Data.Maybe

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

8+getLibdir :: IO FilePath

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

fmt.sh+1−1

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

11#!/usr/bin/env bash

22set -eou pipefail

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

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

ghcide.cabal+104−14

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

22build-type: Simple

33category: Development

44name: ghcide

5−version: 0.1.0

5+version: 0.2.0

66license: Apache-2.0

77license-file: LICENSE

88author: Digital Asset

99maintainer: Digital Asset

10−copyright: Digital Asset 2018-2019

10+copyright: Digital Asset 2018-2020

1111synopsis: The core of an IDE

1212description:

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

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

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

1616tested-with: GHC==8.6.5

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

18− test/data/GotoHover.hs

18+ test/data/hover/*.hs

19+ test/data/multi/cabal.project

20+ test/data/multi/hie.yaml

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

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

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

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

1925

2026source-repository head

2127 type: git

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

3036 default-language: Haskell2010

3137 build-depends:

3238 aeson,

39+ array,

3340 async,

3441 base == 4.*,

3542 binary,

@@ -43,8 +50,8 @@ library

4350 filepath,

4451 haddock-library >= 1.8,

4552 hashable,

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

47− haskell-lsp == 0.19.*,

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

54+ haskell-lsp == 0.22.*,

4855 mtl,

4956 network-uri,

5057 prettyprinter-ansi-terminal,

@@ -60,7 +67,7 @@ library

6067 text,

6168 time,

6269 transformers,

63− unordered-containers,

70+ unordered-containers >= 0.2.10.0,

6471 utf8-string,

6572 hslogger

6673 if flag(ghc-lib)

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

7380 ghc-boot-th,

7481 ghc-boot,

7582 ghc >= 8.4

76− if !os(windows)

83+ if os(windows)

84+ build-depends:

85+ Win32

86+ else

7787 build-depends:

7888 unix

7989 c-sources:

@@ -99,7 +109,10 @@ library

99109 include-dirs:

100110 include

101111 exposed-modules:

112+ Development.IDE.Compat

113+ Development.IDE.Core.Debouncer

102114 Development.IDE.Core.FileStore

115+ Development.IDE.Core.IdeConfiguration

103116 Development.IDE.Core.OfInterest

104117 Development.IDE.Core.PositionMapping

105118 Development.IDE.Core.Rules

@@ -109,7 +122,9 @@ library

109122 Development.IDE.GHC.Error

110123 Development.IDE.GHC.Util

111124 Development.IDE.Import.DependencyInformation

125+ Development.IDE.LSP.HoverDefinition

112126 Development.IDE.LSP.LanguageServer

127+ Development.IDE.LSP.Outline

113128 Development.IDE.LSP.Protocol

114129 Development.IDE.LSP.Server

115130 Development.IDE.Spans.Common

@@ -121,7 +136,6 @@ library

121136 Development.IDE.Plugin.Completions

122137 Development.IDE.Plugin.CodeAction

123138 other-modules:

124− Development.IDE.Core.Debouncer

125139 Development.IDE.Core.Compile

126140 Development.IDE.Core.Preprocessor

127141 Development.IDE.Core.FileExists

@@ -129,22 +143,32 @@ library

129143 Development.IDE.GHC.CPP

130144 Development.IDE.GHC.Orphans

131145 Development.IDE.GHC.Warnings

146+ Development.IDE.GHC.WithDynFlags

132147 Development.IDE.Import.FindImports

133− Development.IDE.LSP.HoverDefinition

134148 Development.IDE.LSP.Notifications

135− Development.IDE.LSP.Outline

136149 Development.IDE.Spans.AtPoint

137150 Development.IDE.Spans.Calculate

138151 Development.IDE.Spans.Documentation

139152 Development.IDE.Spans.Type

153+ Development.IDE.Plugin.CodeAction.PositionIndexed

154+ Development.IDE.Plugin.CodeAction.Rules

155+ Development.IDE.Plugin.CodeAction.RuleTypes

140156 Development.IDE.Plugin.Completions.Logic

141157 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

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

143167

144168executable ghcide-test-preprocessor

145169 default-language: Haskell2010

146170 hs-source-dirs: test/preprocessor

147− ghc-options: -Wall

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

148172 main-is: Main.hs

149173 build-depends:

150174 base == 4.*

@@ -166,29 +190,52 @@ executable ghcide

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

167191 main-is: Main.hs

168192 build-depends:

193+ time,

194+ async,

169195 hslogger,

196+ aeson,

170197 base == 4.*,

198+ binary,

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

200+ bytestring,

171201 containers,

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

172203 data-default,

204+ deepseq,

173205 directory,

174206 extra,

175207 filepath,

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

176209 ghc-paths,

177210 ghc,

178211 gitrev,

212+ hashable,

179213 haskell-lsp,

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

214+ haskell-lsp-types,

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

181216 ghcide,

182217 optparse-applicative,

183218 shake,

184− text

219+ text,

220+ unordered-containers

185221 other-modules:

222+ Utils

186223 Arguments

187224 Paths_ghcide

188225

189226 default-extensions:

227+ BangPatterns

228+ DeriveFunctor

229+ DeriveGeneric

230+ GeneralizedNewtypeDeriving

231+ LambdaCase

232+ NamedFieldPuns

233+ OverloadedStrings

190234 RecordWildCards

235+ ScopedTypeVariables

236+ StandaloneDeriving

191237 TupleSections

238+ TypeApplications

192239 ViewPatterns

193240

194241test-suite ghcide-tests

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

220267 haddock-library,

221268 haskell-lsp,

222269 haskell-lsp-types,

270+ network-uri,

223271 lens,

224− lsp-test >= 0.8,

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

225273 parser-combinators,

226274 QuickCheck,

227275 quickcheck-instances,

228276 rope-utf16-splay,

277+ shake,

229278 tasty,

230279 tasty-expected-failure,

231280 tasty-hunit,

232281 tasty-quickcheck,

282+ tasty-rerun,

233283 text

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

235285 include-dirs: include

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

252302 TupleSections

253303 TypeApplications

254304 ViewPatterns

305+

306+benchmark ghcide-bench

307+ type: exitcode-stdio-1.0

308+ default-language: Haskell2010

309+ build-tool-depends:

310+ ghcide:ghcide,

311+ ghcide:ghcide-test-preprocessor

312+ build-depends:

313+ aeson,

314+ base,

315+ bytestring,

316+ containers,

317+ directory,

318+ extra,

319+ filepath,

320+ ghcide,

321+ lsp-test < 0.12,

322+ optparse-applicative,

323+ parser-combinators,

324+ process,

325+ safe-exceptions

326+ hs-source-dirs: bench

327+ include-dirs: include

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

329+ main-is: Main.hs

330+ other-modules:

331+ default-extensions:

332+ BangPatterns

333+ DeriveFunctor

334+ DeriveGeneric

335+ GeneralizedNewtypeDeriving

336+ LambdaCase

337+ NamedFieldPuns

338+ OverloadedStrings

339+ RecordWildCards

340+ ScopedTypeVariables

341+ StandaloneDeriving

342+ TupleSections

343+ TypeApplications

344+ ViewPatterns

hie.yaml+12−1

@@ -1 +1,12 @@

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

1+cradle:

2+ cabal:

3+ - path: "./src"

4+ component: "ghcide:lib:ghcide"

5+ - path: "./exe"

6+ component: "ghcide:exe:ghcide"

7+ - path: "./test"

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

9+ - path: "./bench"

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

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

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

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

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

3+{-

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

6+Main functions for .hie file generation

7+-}

8+{- HLINT ignore -}

9+{-# LANGUAGE OverloadedStrings #-}

10+{-# LANGUAGE FlexibleInstances #-}

11+{-# LANGUAGE UndecidableInstances #-}

12+{-# LANGUAGE FlexibleContexts #-}

13+{-# LANGUAGE TypeSynonymInstances #-}

14+{-# LANGUAGE ScopedTypeVariables #-}

15+{-# LANGUAGE TypeFamilies #-}

16+{-# LANGUAGE TypeApplications #-}

17+{-# LANGUAGE AllowAmbiguousTypes #-}

18+{-# LANGUAGE ViewPatterns #-}

19+{-# LANGUAGE DeriveDataTypeable #-}

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

21+

22+import GhcPrelude

23+

24+import Avail ( Avails )

25+import Bag ( Bag, bagToList )

26+import BasicTypes

27+import BooleanFormula

28+import Class ( FunDep )

29+import CoreUtils ( exprType )

30+import ConLike ( conLikeName )

31+import Desugar ( deSugarExpr )

32+import FieldLabel

33+import GHC.Hs

34+import HscTypes

35+import Module ( ModuleName, ml_hs_file )

36+import MonadUtils ( concatMapM, liftIO )

37+import Name ( Name, nameSrcSpan, setNameLoc )

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

39+import SrcLoc

40+import TcHsSyn ( hsLitType, hsPatType )

41+import Type ( mkVisFunTys, Type )

42+import TysWiredIn ( mkListTy, mkSumTy )

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

44+import TcRnTypes

45+import MkIface ( mkIfaceExports )

46+import Panic

47+

48+import HieTypes

49+import HieUtils

50+

51+import qualified Data.Array as A

52+import qualified Data.ByteString as BS

53+import qualified Data.Map as M

54+import qualified Data.Set as S

55+import Data.Data ( Data, Typeable )

56+import Data.List ( foldl1' )

57+import Data.Maybe ( listToMaybe )

58+import Control.Monad.Trans.Reader

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

60+

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

62+

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

64+need to pay attention to the following things:

65+

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

67+

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

69+ something the user typed

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

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

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

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

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

75+

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

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

78+

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

80+

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

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

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

84+

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

86+

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

88+

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

90+

91+data ContextInfo

92+ = Use -- ^ regular variable

93+ | MatchBind

94+ | IEThing IEType -- ^ import/export

95+ | TyDecl

96+ -- | Value binding

97+ | ValBind

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

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

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

101+ ...

102+

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

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

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

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

107+

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

109+particular location, you would do the following:

110+

111+ toHie $ C Use located_name

112+

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

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

115+`SrcSpans`.

116+

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

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

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

120+in HieAst.

121+

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

123+the name.

124+

125+For a function definition `foo`:

126+

127+foo x = x + y

128+ where y = x^2

129+

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

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

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

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

134+

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

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

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

138+.hie file.

139+

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

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

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

143+

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

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

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

147+

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

149+

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

151+ HsVar _ (L _ var) ->

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

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

154+ ]

155+ HsConLikeOut _ con ->

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

157+ ]

158+ ...

159+ HsApp _ a b ->

160+ [ toHie a

161+ , toHie b

162+ ]

163+

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

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

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

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

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

169+appropriately annotated symbols contained in the subtree.

170+

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

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

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

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

175+when given a typechecked AST:

176+

177+class Data a => HasType a where

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

179+instance HasType (LHsExpr GhcTc) where

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

181+instance HasType (LHsExpr GhcRn) where

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

183+

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

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

186+

187+-}

188+

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

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

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

192+ , Maybe LHsDocString )

193+type TypecheckedSource = LHsBinds GhcTc

194+

195+

196+{- Note [Name Remapping]

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

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

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

200+-}

201+newtype HieState = HieState

202+ { name_remapping :: NameEnv Id

203+ }

204+

205+initState :: HieState

206+initState = HieState emptyNameEnv

207+

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

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

210+

211+instance ModifyState Name where

212+ addSubstitution _ _ hs = hs

213+

214+instance ModifyState Id where

215+ addSubstitution mono poly hs =

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

217+

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

219+modifyState = foldr go id

220+ where

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

222+ go _ f = f

223+

224+type HieM = ReaderT HieState Hsc

225+

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

227+mkHieFile :: ModSummary

228+ -> TcGblEnv

229+ -> RenamedSource

230+ -> BS.ByteString -> Hsc HieFile

231+mkHieFile ms ts rs src = do

232+ let tc_binds = tcg_binds ts

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

234+ let Just src_file = ml_hs_file $ ms_location ms

235+ return $ HieFile

236+ { hie_hs_file = src_file

237+ , hie_module = ms_mod ms

238+ , hie_types = arr

239+ , hie_asts = asts'

240+ -- mkIfaceExports sorts the AvailInfos for stability

241+ , hie_exports = mkIfaceExports (tcg_exports ts)

242+ , hie_hs_src = src

243+ }

244+

245+getCompressedAsts :: TypecheckedSource -> RenamedSource

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

247+getCompressedAsts ts rs = do

248+ asts <- enrichHie ts rs

249+ return $ compressTypes asts

250+

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

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

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

254+ rasts <- processGrp hsGrp

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

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

257+ let spanFile children = case children of

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

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

260+ (realSrcSpanEnd $ nodeSpan $ last children)

261+

262+ modulify xs =

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

264+

265+ asts = HieASTs

266+ $ resolveTyVarScopes

267+ $ M.map (modulify . mergeSortAsts)

268+ $ M.fromListWith (++)

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

270+

271+ flat_asts = concat

272+ [ tasts

273+ , rasts

274+ , imps

275+ , exps

276+ ]

277+ return asts

278+ where

279+ processGrp grp = concatM

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

281+ , toHie $ hs_splcds grp

282+ , toHie $ hs_tyclds grp

283+ , toHie $ hs_derivds grp

284+ , toHie $ hs_fixds grp

285+ , toHie $ hs_defds grp

286+ , toHie $ hs_fords grp

287+ , toHie $ hs_warnds grp

288+ , toHie $ hs_annds grp

289+ , toHie $ hs_ruleds grp

290+ ]

291+

292+getRealSpan :: SrcSpan -> Maybe Span

293+getRealSpan (RealSrcSpan sp) = Just sp

294+getRealSpan _ = Nothing

295+

296+grhss_span :: GRHSs p body -> SrcSpan

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

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

299+

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

301+bindingsOnly [] = []

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

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

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

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

306+ _ -> bindingsOnly xs

307+

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

309+concatM xs = concat <$> sequence xs

310+

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

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

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

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

315+carry the required info

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

317+-}

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

319+

320+data RContext a = RC RecFieldContext a

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

322+-- ^ context for record fields

323+

324+data IEContext a = IEC IEType a

325+-- ^ context for imports/exports

326+

327+data BindContext a = BC BindType Scope a

328+-- ^ context for imports/exports

329+

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

331+-- ^ context for pattern synonym fields.

332+

333+data SigContext a = SC SigInfo a

334+-- ^ context for type signatures

335+

336+data SigInfo = SI SigType (Maybe Span)

337+

338+data SigType = BindSig | ClassSig | InstSig

339+

340+data RScoped a = RS Scope a

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

342+-- including a itself

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

344+-- let/where bindings

345+

346+-- | Pattern scope

347+data PScoped a = PS (Maybe Span)

348+ Scope -- ^ use site of the pattern

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

350+ a

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

352+

353+{- Note [TyVar Scopes]

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

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

356+in a separate pass

357+-}

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

359+

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

361+-- ^ First scope remains constant

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

363+-- things to its right, ala RScoped

364+

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

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

367+listScopes _ [] = []

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

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

370+ where

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

372+ sc = combineScopes scope $ mkScope $ getLoc p

373+

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

375+patScopes

376+ :: Maybe Span

377+ -> Scope

378+ -> Scope

379+ -> [LPat (GhcPass p)]

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

381+patScopes rsp useScope patScope xs =

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

383+ listScopes patScope (map dL xs)

384+

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

386+tvScopes

387+ :: TyVarScope

388+ -> Scope

389+ -> [LHsTyVarBndr a]

390+ -> [TVScoped (LHsTyVarBndr a)]

391+tvScopes tvScope rhsScope xs =

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

393+

394+{- Note [Scoping Rules for SigPat]

395+Explicitly quantified variables in pattern type signatures are not

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

397+are (HsWC and HsIB).

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

399+are brought into the RHS Scope

400+For example

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

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

403+

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

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

406+

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

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

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

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

411+on the the LHsType

412+-}

413+

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

415+

416+type family ProtectedSig a where

417+ ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs

418+ GhcRn

419+ (Shielded (LHsType GhcRn)))

420+ ProtectedSig GhcTc = NoExtField

421+

422+class ProtectSig a where

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

424+

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

426+ loc (SH _ a) = loc a

427+

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

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

430+

431+instance ProtectSig GhcTc where

432+ protectSig _ _ = noExtField

433+

434+instance ProtectSig GhcRn where

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

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

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

438+ protectSig _ (XHsWildCardBndrs nec) = noExtCon nec

439+

440+class HasLoc a where

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

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

443+ loc :: a -> SrcSpan

444+

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

446+ loc (TS _ a) = loc a

447+

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

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

450+

451+instance HasLoc (LHsQTyVars GhcRn) where

452+ loc (HsQTvs _ vs) = loc vs

453+ loc _ = noSrcSpan

454+

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

456+ loc (HsIB _ a) = loc a

457+ loc _ = noSrcSpan

458+

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

460+ loc (HsWC _ a) = loc a

461+ loc _ = noSrcSpan

462+

463+instance HasLoc (Located a) where

464+ loc (L l _) = l

465+

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

467+ loc [] = noSrcSpan

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

469+

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

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

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

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

474+ loc _ = noSrcSpan

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

476+ loc (HsValArg tm) = loc tm

477+ loc (HsTypeArg _ ty) = loc ty

478+ loc (HsArgPar sp) = sp

479+

480+instance HasLoc (HsDataDefn GhcRn) where

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

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

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

484+ loc _ = noSrcSpan

485+

486+{- Note [Real DataCon Name]

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

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

489+original datacon name

490+See also Note [Data Constructor Naming]

491+-}

492+class HasRealDataConName p where

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

494+

495+instance HasRealDataConName GhcRn where

496+ getRealDataCon _ n = n

497+instance HasRealDataConName GhcTc where

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

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

500+

501+-- | The main worker class

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

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

504+class ToHie a where

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

506+

507+-- | Used to collect type info

508+class Data a => HasType a where

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

510+

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

512+ toHie = concatMapM toHie

513+

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

515+ toHie = toHie . bagToList

516+

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

518+ toHie = maybe (pure []) toHie

519+

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

521+ toHie _ = pure []

522+

523+instance ToHie (TScoped NoExtField) where

524+ toHie _ = pure []

525+

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

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

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

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

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

531+ toHie _ = pure []

532+

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

534+ toHie c = case c of

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

536+ -> do

537+ m <- asks name_remapping

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

539+ Just var -> var

540+ Nothing-> name'

541+ pure

542+ [Node

543+ (NodeInfo S.empty [] $

544+ M.singleton (Right $ varName name)

545+ (IdentifierDetails (Just $ varType name')

546+ (S.singleton context)))

547+ span

548+ []]

549+ _ -> pure []

550+

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

552+ toHie c = case c of

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

554+ m <- asks name_remapping

555+ let name = case lookupNameEnv m name' of

556+ Just var -> varName var

557+ Nothing -> name'

558+ pure

559+ [Node

560+ (NodeInfo S.empty [] $

561+ M.singleton (Right name)

562+ (IdentifierDetails Nothing

563+ (S.singleton context)))

564+ span

565+ []]

566+ _ -> pure []

567+

568+-- | Dummy instances - never called

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

570+ toHie _ = pure []

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

572+ toHie _ = pure []

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

574+ toHie _ = pure []

575+instance ToHie (TScoped Type) where

576+ toHie _ = pure []

577+

578+instance HasType (LHsBind GhcRn) where

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

580+

581+instance HasType (LHsBind GhcTc) where

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

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

584+ _ -> makeNode bind spn

585+

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

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

588+

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

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

591+

592+instance HasType (LHsExpr GhcRn) where

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

594+

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

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

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

598+--

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

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

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

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

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

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

605+--

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

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

608+--

609+-- See #16233

610+instance HasType (LHsExpr GhcTc) where

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

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

613+ let tyOpt = case e' of

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

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

616+

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

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

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

620+

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

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

623+ HsDo ty _ _ -> Just ty

624+ HsMultiIf ty _ -> Just ty

625+

626+ _ -> Nothing

627+

628+ in

629+ case tyOpt of

630+ Just t -> makeTypeNode e' spn t

631+ Nothing

632+ | skipDesugaring e' -> fallback

633+ | otherwise -> do

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

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

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

637+ where

638+ fallback = makeNode e' spn

639+

640+ matchGroupType :: MatchGroupTc -> Type

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

642+

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

644+ --

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

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

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

648+ skipDesugaring :: HsExpr a -> Bool

649+ skipDesugaring e = case e of

650+ HsVar{} -> False

651+ HsUnboundVar{} -> False

652+ HsConLikeOut{} -> False

653+ HsRecFld{} -> False

654+ HsOverLabel{} -> False

655+ HsIPVar{} -> False

656+ HsWrap{} -> False

657+ _ -> True

658+

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

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

661+ , ToHie (PScoped (LPat a))

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

663+ , ToHie (LHsExpr a)

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

665+ , HasType (LHsBind a)

666+ , ModifyState (IdP a)

667+ , Data (HsBind a)

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

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

670+ concatM $ getTypeNode b : case bind of

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

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

673+ , toHie matches

674+ ]

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

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

677+ , toHie rhs

678+ ]

679+ VarBind{var_rhs = expr} ->

680+ [ toHie expr

681+ ]

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

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

684+ toHie $ fmap (BC context scope) binds

685+ ]

686+ PatSynBind _ psb ->

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

688+ ]

689+ XHsBindsLR _ -> []

690+

691+instance ( ToHie (LMatch a body)

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

693+ toHie mg = concatM $ case mg of

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

695+ [ pure $ locOnly span

696+ , toHie alts

697+ ]

698+ MG{} -> []

699+ XMatchGroup _ -> []

700+

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

702+ , ToHie (PScoped (LPat a))

703+ , ToHie (HsPatSynDir a)

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

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

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

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

708+ , toHie $ toBind dets

709+ , toHie $ PS Nothing lhsScope NoScope pat

710+ , toHie dir

711+ ]

712+ where

713+ lhsScope = combineScopes varScope detScope

714+ varScope = mkLScope var

715+ detScope = case dets of

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

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

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

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

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

721+ detSpan = case detScope of

722+ LocalScope a -> Just a

723+ _ -> Nothing

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

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

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

727+ XPatSynBind _ -> []

728+

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

730+ ) => ToHie (HsPatSynDir a) where

731+ toHie dir = case dir of

732+ ExplicitBidirectional mg -> toHie mg

733+ _ -> pure []

734+

735+instance ( a ~ GhcPass p

736+ , ToHie body

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

738+ , ToHie (PScoped (LPat a))

739+ , ToHie (GRHSs a body)

740+ , Data (Match a body)

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

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

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

744+ [ toHie mctx

745+ , let rhsScope = mkScope $ grhss_span grhss

746+ in toHie $ patScopes Nothing rhsScope NoScope pats

747+ , toHie grhss

748+ ]

749+ XMatch _ -> []

750+

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

752+ ) => ToHie (HsMatchContext a) where

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

754+ toHie (StmtCtxt a) = toHie a

755+ toHie _ = pure []

756+

757+instance ( ToHie (HsMatchContext a)

758+ ) => ToHie (HsStmtContext a) where

759+ toHie (PatGuard a) = toHie a

760+ toHie (ParStmtCtxt a) = toHie a

761+ toHie (TransStmtCtxt a) = toHie a

762+ toHie _ = pure []

763+

764+instance ( a ~ GhcPass p

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

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

767+ , ToHie (LHsExpr a)

768+ , ToHie (TScoped (LHsSigWcType a))

769+ , ProtectSig a

770+ , ToHie (TScoped (ProtectedSig a))

771+ , HasType (LPat a)

772+ , Data (HsSplice a)

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

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

775+ concatM $ getTypeNode lpat : case opat of

776+ WildPat _ ->

777+ []

778+ VarPat _ lname ->

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

780+ ]

781+ LazyPat _ p ->

782+ [ toHie $ PS rsp scope pscope p

783+ ]

784+ AsPat _ lname pat ->

785+ [ toHie $ C (PatternBind scope

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

787+ rsp)

788+ lname

789+ , toHie $ PS rsp scope pscope pat

790+ ]

791+ ParPat _ pat ->

792+ [ toHie $ PS rsp scope pscope pat

793+ ]

794+ BangPat _ pat ->

795+ [ toHie $ PS rsp scope pscope pat

796+ ]

797+ ListPat _ pats ->

798+ [ toHie $ patScopes rsp scope pscope pats

799+ ]

800+ TuplePat _ pats _ ->

801+ [ toHie $ patScopes rsp scope pscope pats

802+ ]

803+ SumPat _ pat _ _ ->

804+ [ toHie $ PS rsp scope pscope pat

805+ ]

806+ ConPatIn c dets ->

807+ [ toHie $ C Use c

808+ , toHie $ contextify dets

809+ ]

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

811+ [ toHie $ C Use $ fmap conLikeName con

812+ , toHie $ contextify dets

813+ ]

814+ ViewPat _ expr pat ->

815+ [ toHie expr

816+ , toHie $ PS rsp scope pscope pat

817+ ]

818+ SplicePat _ sp ->

819+ [ toHie $ L ospan sp

820+ ]

821+ LitPat _ _ ->

822+ []

823+ NPat _ _ _ _ ->

824+ []

825+ NPlusKPat _ n _ _ _ _ ->

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

827+ ]

828+ SigPat _ pat sig ->

829+ [ toHie $ PS rsp scope pscope pat

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

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

832+ (protectSig @a cscope sig)

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

834+ ]

835+ CoPat _ _ _ _ ->

836+ []

837+ XPat _ -> []

838+ where

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

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

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

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

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

844+ where

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

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

847+ scoped_fds = listScopes pscope fds

848+

849+instance ( ToHie body

850+ , ToHie (LGRHS a body)

851+ , ToHie (RScoped (LHsLocalBinds a))

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

853+ toHie grhs = concatM $ case grhs of

854+ GRHSs _ grhss binds ->

855+ [ toHie grhss

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

857+ ]

858+ XGRHSs _ -> []

859+

860+instance ( ToHie (Located body)

861+ , ToHie (RScoped (GuardLStmt a))

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

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

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

865+ GRHS _ guards body ->

866+ [ toHie $ listScopes (mkLScope body) guards

867+ , toHie body

868+ ]

869+ XGRHS _ -> []

870+

871+instance ( a ~ GhcPass p

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

873+ , HasType (LHsExpr a)

874+ , ToHie (PScoped (LPat a))

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

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

877+ , ToHie (RContext (HsRecordBinds a))

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

879+ , ToHie (ArithSeqInfo a)

880+ , ToHie (LHsCmdTop a)

881+ , ToHie (RScoped (GuardLStmt a))

882+ , ToHie (RScoped (LHsLocalBinds a))

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

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

885+ , Data (HsExpr a)

886+ , Data (HsSplice a)

887+ , Data (HsTupArg a)

888+ , Data (AmbiguousFieldOcc a)

889+ , (HasRealDataConName a)

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

891+ toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of

892+ HsVar _ (L _ var) ->

893+ [ toHie $ C Use (L mspan var)

894+ -- Patch up var location since typechecker removes it

895+ ]

896+ HsUnboundVar _ _ ->

897+ []

898+ HsConLikeOut _ con ->

899+ [ toHie $ C Use $ L mspan $ conLikeName con

900+ ]

901+ HsRecFld _ fld ->

902+ [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)

903+ ]

904+ HsOverLabel _ _ _ -> []

905+ HsIPVar _ _ -> []

906+ HsOverLit _ _ -> []

907+ HsLit _ _ -> []

908+ HsLam _ mg ->

909+ [ toHie mg

910+ ]

911+ HsLamCase _ mg ->

912+ [ toHie mg

913+ ]

914+ HsApp _ a b ->

915+ [ toHie a

916+ , toHie b

917+ ]

918+ HsAppType _ expr sig ->

919+ [ toHie expr

920+ , toHie $ TS (ResolvedScopes []) sig

921+ ]

922+ OpApp _ a b c ->

923+ [ toHie a

924+ , toHie b

925+ , toHie c

926+ ]

927+ NegApp _ a _ ->

928+ [ toHie a

929+ ]

930+ HsPar _ a ->

931+ [ toHie a

932+ ]

933+ SectionL _ a b ->

934+ [ toHie a

935+ , toHie b

936+ ]

937+ SectionR _ a b ->

938+ [ toHie a

939+ , toHie b

940+ ]

941+ ExplicitTuple _ args _ ->

942+ [ toHie args

943+ ]

944+ ExplicitSum _ _ _ expr ->

945+ [ toHie expr

946+ ]

947+ HsCase _ expr matches ->

948+ [ toHie expr

949+ , toHie matches

950+ ]

951+ HsIf _ _ a b c ->

952+ [ toHie a

953+ , toHie b

954+ , toHie c

955+ ]

956+ HsMultiIf _ grhss ->

957+ [ toHie grhss

958+ ]

959+ HsLet _ binds expr ->

960+ [ toHie $ RS (mkLScope expr) binds

961+ , toHie expr

962+ ]

963+ HsDo _ _ (L ispan stmts) ->

964+ [ pure $ locOnly ispan

965+ , toHie $ listScopes NoScope stmts

966+ ]

967+ ExplicitList _ _ exprs ->

968+ [ toHie exprs

969+ ]

970+ RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} ->

971+ [ toHie $ C Use (getRealDataCon @a mrealcon name)

972+ -- See Note [Real DataCon Name]

973+ , toHie $ RC RecFieldAssign $ binds

974+ ]

975+ RecordUpd {rupd_expr = expr, rupd_flds = upds}->

976+ [ toHie expr

977+ , toHie $ map (RC RecFieldAssign) upds

978+ ]

979+ ExprWithTySig _ expr sig ->

980+ [ toHie expr

981+ , toHie $ TS (ResolvedScopes [mkLScope expr]) sig

982+ ]

983+ ArithSeq _ _ info ->

984+ [ toHie info

985+ ]

986+ HsSCC _ _ _ expr ->

987+ [ toHie expr

988+ ]

989+ HsCoreAnn _ _ _ expr ->

990+ [ toHie expr

991+ ]

992+ HsProc _ pat cmdtop ->

993+ [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat

994+ , toHie cmdtop

995+ ]

996+ HsStatic _ expr ->

997+ [ toHie expr

998+ ]

999+ HsTick _ _ expr ->

1000+ [ toHie expr

1001+ ]

1002+ HsBinTick _ _ _ expr ->

1003+ [ toHie expr

1004+ ]

1005+ HsTickPragma _ _ _ _ expr ->

1006+ [ toHie expr

1007+ ]

1008+ HsWrap _ _ a ->

1009+ [ toHie $ L mspan a

1010+ ]

1011+ HsBracket _ b ->

1012+ [ toHie b

1013+ ]

1014+ HsRnBracketOut _ b p ->

1015+ [ toHie b

1016+ , toHie p

1017+ ]

1018+ HsTcBracketOut _ b p ->

1019+ [ toHie b

1020+ , toHie p

1021+ ]

1022+ HsSpliceE _ x ->

1023+ [ toHie $ L mspan x

1024+ ]

1025+ XExpr _ -> []

1026+

1027+instance ( a ~ GhcPass p

1028+ , ToHie (LHsExpr a)

1029+ , Data (HsTupArg a)

1030+ ) => ToHie (LHsTupArg (GhcPass p)) where

1031+ toHie (L span arg) = concatM $ makeNode arg span : case arg of

1032+ Present _ expr ->

1033+ [ toHie expr

1034+ ]

1035+ Missing _ -> []

1036+ XTupArg _ -> []

1037+

1038+instance ( a ~ GhcPass p

1039+ , ToHie (PScoped (LPat a))

1040+ , ToHie (LHsExpr a)

1041+ , ToHie (SigContext (LSig a))

1042+ , ToHie (RScoped (LHsLocalBinds a))

1043+ , ToHie (RScoped (ApplicativeArg a))

1044+ , ToHie (Located body)

1045+ , Data (StmtLR a a (Located body))

1046+ , Data (StmtLR a a (Located (HsExpr a)))

1047+ ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where

1048+ toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of

1049+ LastStmt _ body _ _ ->

1050+ [ toHie body

1051+ ]

1052+ BindStmt _ pat body _ _ ->

1053+ [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat

1054+ , toHie body

1055+ ]

1056+ ApplicativeStmt _ stmts _ ->

1057+ [ concatMapM (toHie . RS scope . snd) stmts

1058+ ]

1059+ BodyStmt _ body _ _ ->

1060+ [ toHie body

1061+ ]

1062+ LetStmt _ binds ->

1063+ [ toHie $ RS scope binds

1064+ ]

1065+ ParStmt _ parstmts _ _ ->

1066+ [ concatMapM (\(ParStmtBlock _ stmts _ _) ->

1067+ toHie $ listScopes NoScope stmts)

1068+ parstmts

1069+ ]

1070+ TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->

1071+ [ toHie $ listScopes scope stmts

1072+ , toHie using

1073+ , toHie by

1074+ ]

1075+ RecStmt {recS_stmts = stmts} ->

1076+ [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts

1077+ ]

1078+ XStmtLR _ -> []

1079+

1080+instance ( ToHie (LHsExpr a)

1081+ , ToHie (PScoped (LPat a))

1082+ , ToHie (BindContext (LHsBind a))

1083+ , ToHie (SigContext (LSig a))

1084+ , ToHie (RScoped (HsValBindsLR a a))

1085+ , Data (HsLocalBinds a)

1086+ ) => ToHie (RScoped (LHsLocalBinds a)) where

1087+ toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of

1088+ EmptyLocalBinds _ -> []

1089+ HsIPBinds _ _ -> []

1090+ HsValBinds _ valBinds ->

1091+ [ toHie $ RS (combineScopes scope $ mkScope sp)

1092+ valBinds

1093+ ]

1094+ XHsLocalBindsLR _ -> []

1095+

1096+instance ( ToHie (BindContext (LHsBind a))

1097+ , ToHie (SigContext (LSig a))

1098+ , ToHie (RScoped (XXValBindsLR a a))

1099+ ) => ToHie (RScoped (HsValBindsLR a a)) where

1100+ toHie (RS sc v) = concatM $ case v of

1101+ ValBinds _ binds sigs ->

1102+ [ toHie $ fmap (BC RegularBind sc) binds

1103+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs

1104+ ]

1105+ XValBindsLR x -> [ toHie $ RS sc x ]

1106+

1107+instance ToHie (RScoped (NHsValBindsLR GhcTc)) where

1108+ toHie (RS sc (NValBinds binds sigs)) = concatM $

1109+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)

1110+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs

1111+ ]

1112+instance ToHie (RScoped (NHsValBindsLR GhcRn)) where

1113+ toHie (RS sc (NValBinds binds sigs)) = concatM $

1114+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)

1115+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs

1116+ ]

1117+

1118+instance ( ToHie (RContext (LHsRecField a arg))

1119+ ) => ToHie (RContext (HsRecFields a arg)) where

1120+ toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields

1121+

1122+instance ( ToHie (RFContext (Located label))

1123+ , ToHie arg

1124+ , HasLoc arg

1125+ , Data label

1126+ , Data arg

1127+ ) => ToHie (RContext (LHsRecField' label arg)) where

1128+ toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of

1129+ HsRecField label expr _ ->

1130+ [ toHie $ RFC c (getRealSpan $ loc expr) label

1131+ , toHie expr

1132+ ]

1133+

1134+removeDefSrcSpan :: Name -> Name

1135+removeDefSrcSpan n = setNameLoc n noSrcSpan

1136+

1137+instance ToHie (RFContext (LFieldOcc GhcRn)) where

1138+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1139+ FieldOcc name _ ->

1140+ [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)

1141+ ]

1142+ XFieldOcc _ -> []

1143+

1144+instance ToHie (RFContext (LFieldOcc GhcTc)) where

1145+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1146+ FieldOcc var _ ->

1147+ let var' = setVarName var (removeDefSrcSpan $ varName var)

1148+ in [ toHie $ C (RecField c rhs) (L nspan var')

1149+ ]

1150+ XFieldOcc _ -> []

1151+

1152+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where

1153+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1154+ Unambiguous name _ ->

1155+ [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name

1156+ ]

1157+ Ambiguous _name _ ->

1158+ [ ]

1159+ XAmbiguousFieldOcc _ -> []

1160+

1161+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where

1162+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1163+ Unambiguous var _ ->

1164+ let var' = setVarName var (removeDefSrcSpan $ varName var)

1165+ in [ toHie $ C (RecField c rhs) (L nspan var')

1166+ ]

1167+ Ambiguous var _ ->

1168+ let var' = setVarName var (removeDefSrcSpan $ varName var)

1169+ in [ toHie $ C (RecField c rhs) (L nspan var')

1170+ ]

1171+ XAmbiguousFieldOcc _ -> []

1172+

1173+instance ( a ~ GhcPass p

1174+ , ToHie (PScoped (LPat a))

1175+ , ToHie (BindContext (LHsBind a))

1176+ , ToHie (LHsExpr a)

1177+ , ToHie (SigContext (LSig a))

1178+ , ToHie (RScoped (HsValBindsLR a a))

1179+ , Data (StmtLR a a (Located (HsExpr a)))

1180+ , Data (HsLocalBinds a)

1181+ ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where

1182+ toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM

1183+ [ toHie $ PS Nothing sc NoScope pat

1184+ , toHie expr

1185+ ]

1186+ toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM

1187+ [ toHie $ listScopes NoScope stmts

1188+ , toHie $ PS Nothing sc NoScope pat

1189+ ]

1190+ toHie (RS _ (XApplicativeArg _)) = pure []

1191+

1192+instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where

1193+ toHie (PrefixCon args) = toHie args

1194+ toHie (RecCon rec) = toHie rec

1195+ toHie (InfixCon a b) = concatM [ toHie a, toHie b]

1196+

1197+instance ( ToHie (LHsCmd a)

1198+ , Data (HsCmdTop a)

1199+ ) => ToHie (LHsCmdTop a) where

1200+ toHie (L span top) = concatM $ makeNode top span : case top of

1201+ HsCmdTop _ cmd ->

1202+ [ toHie cmd

1203+ ]

1204+ XCmdTop _ -> []

1205+

1206+instance ( a ~ GhcPass p

1207+ , ToHie (PScoped (LPat a))

1208+ , ToHie (BindContext (LHsBind a))

1209+ , ToHie (LHsExpr a)

1210+ , ToHie (MatchGroup a (LHsCmd a))

1211+ , ToHie (SigContext (LSig a))

1212+ , ToHie (RScoped (HsValBindsLR a a))

1213+ , Data (HsCmd a)

1214+ , Data (HsCmdTop a)

1215+ , Data (StmtLR a a (Located (HsCmd a)))

1216+ , Data (HsLocalBinds a)

1217+ , Data (StmtLR a a (Located (HsExpr a)))

1218+ ) => ToHie (LHsCmd (GhcPass p)) where

1219+ toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of

1220+ HsCmdArrApp _ a b _ _ ->

1221+ [ toHie a

1222+ , toHie b

1223+ ]

1224+ HsCmdArrForm _ a _ _ cmdtops ->

1225+ [ toHie a

1226+ , toHie cmdtops

1227+ ]

1228+ HsCmdApp _ a b ->

1229+ [ toHie a

1230+ , toHie b

1231+ ]

1232+ HsCmdLam _ mg ->

1233+ [ toHie mg

1234+ ]

1235+ HsCmdPar _ a ->

1236+ [ toHie a

1237+ ]

1238+ HsCmdCase _ expr alts ->

1239+ [ toHie expr

1240+ , toHie alts

1241+ ]

1242+ HsCmdIf _ _ a b c ->

1243+ [ toHie a

1244+ , toHie b

1245+ , toHie c

1246+ ]

1247+ HsCmdLet _ binds cmd' ->

1248+ [ toHie $ RS (mkLScope cmd') binds

1249+ , toHie cmd'

1250+ ]

1251+ HsCmdDo _ (L ispan stmts) ->

1252+ [ pure $ locOnly ispan

1253+ , toHie $ listScopes NoScope stmts

1254+ ]

1255+ HsCmdWrap _ _ _ -> []

1256+ XCmd _ -> []

1257+

1258+instance ToHie (TyClGroup GhcRn) where

1259+ toHie TyClGroup{ group_tyclds = classes

1260+ , group_roles = roles

1261+ , group_kisigs = sigs

1262+ , group_instds = instances } =

1263+ concatM

1264+ [ toHie classes

1265+ , toHie sigs

1266+ , toHie roles

1267+ , toHie instances

1268+ ]

1269+ toHie (XTyClGroup _) = pure []

1270+

1271+instance ToHie (LTyClDecl GhcRn) where

1272+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1273+ FamDecl {tcdFam = fdecl} ->

1274+ [ toHie (L span fdecl)

1275+ ]

1276+ SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->

1277+ [ toHie $ C (Decl SynDec $ getRealSpan span) name

1278+ , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars

1279+ , toHie typ

1280+ ]

1281+ DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->

1282+ [ toHie $ C (Decl DataDec $ getRealSpan span) name

1283+ , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars

1284+ , toHie defn

1285+ ]

1286+ where

1287+ quant_scope = mkLScope $ dd_ctxt defn

1288+ rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc

1289+ sig_sc = maybe NoScope mkLScope $ dd_kindSig defn

1290+ con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn

1291+ deriv_sc = mkLScope $ dd_derivs defn

1292+ ClassDecl { tcdCtxt = context

1293+ , tcdLName = name

1294+ , tcdTyVars = vars

1295+ , tcdFDs = deps

1296+ , tcdSigs = sigs

1297+ , tcdMeths = meths

1298+ , tcdATs = typs

1299+ , tcdATDefs = deftyps

1300+ } ->

1301+ [ toHie $ C (Decl ClassDec $ getRealSpan span) name

1302+ , toHie context

1303+ , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars

1304+ , toHie deps

1305+ , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs

1306+ , toHie $ fmap (BC InstanceBind ModuleScope) meths

1307+ , toHie typs

1308+ , concatMapM (pure . locOnly . getLoc) deftyps

1309+ , toHie deftyps

1310+ ]

1311+ where

1312+ context_scope = mkLScope context

1313+ rhs_scope = foldl1' combineScopes $ map mkScope

1314+ [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]

1315+ XTyClDecl _ -> []

1316+

1317+instance ToHie (LFamilyDecl GhcRn) where

1318+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1319+ FamilyDecl _ info name vars _ sig inj ->

1320+ [ toHie $ C (Decl FamDec $ getRealSpan span) name

1321+ , toHie $ TS (ResolvedScopes [rhsSpan]) vars

1322+ , toHie info

1323+ , toHie $ RS injSpan sig

1324+ , toHie inj

1325+ ]

1326+ where

1327+ rhsSpan = sigSpan `combineScopes` injSpan

1328+ sigSpan = mkScope $ getLoc sig

1329+ injSpan = maybe NoScope (mkScope . getLoc) inj

1330+ XFamilyDecl _ -> []

1331+

1332+instance ToHie (FamilyInfo GhcRn) where

1333+ toHie (ClosedTypeFamily (Just eqns)) = concatM $

1334+ [ concatMapM (pure . locOnly . getLoc) eqns

1335+ , toHie $ map go eqns

1336+ ]

1337+ where

1338+ go (L l ib) = TS (ResolvedScopes [mkScope l]) ib

1339+ toHie _ = pure []

1340+

1341+instance ToHie (RScoped (LFamilyResultSig GhcRn)) where

1342+ toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of

1343+ NoSig _ ->

1344+ []

1345+ KindSig _ k ->

1346+ [ toHie k

1347+ ]

1348+ TyVarSig _ bndr ->

1349+ [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr

1350+ ]

1351+ XFamilyResultSig _ -> []

1352+

1353+instance ToHie (Located (FunDep (Located Name))) where

1354+ toHie (L span fd@(lhs, rhs)) = concatM $

1355+ [ makeNode fd span

1356+ , toHie $ map (C Use) lhs

1357+ , toHie $ map (C Use) rhs

1358+ ]

1359+

1360+instance (ToHie rhs, HasLoc rhs)

1361+ => ToHie (TScoped (FamEqn GhcRn rhs)) where

1362+ toHie (TS _ f) = toHie f

1363+

1364+instance (ToHie rhs, HasLoc rhs)

1365+ => ToHie (FamEqn GhcRn rhs) where

1366+ toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $

1367+ [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var

1368+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1369+ , toHie pats

1370+ , toHie rhs

1371+ ]

1372+ where scope = combineScopes patsScope rhsScope

1373+ patsScope = mkScope (loc pats)

1374+ rhsScope = mkScope (loc rhs)

1375+ toHie (XFamEqn _) = pure []

1376+

1377+instance ToHie (LInjectivityAnn GhcRn) where

1378+ toHie (L span ann) = concatM $ makeNode ann span : case ann of

1379+ InjectivityAnn lhs rhs ->

1380+ [ toHie $ C Use lhs

1381+ , toHie $ map (C Use) rhs

1382+ ]

1383+

1384+instance ToHie (HsDataDefn GhcRn) where

1385+ toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM

1386+ [ toHie ctx

1387+ , toHie mkind

1388+ , toHie cons

1389+ , toHie derivs

1390+ ]

1391+ toHie (XHsDataDefn _) = pure []

1392+

1393+instance ToHie (HsDeriving GhcRn) where

1394+ toHie (L span clauses) = concatM

1395+ [ pure $ locOnly span

1396+ , toHie clauses

1397+ ]

1398+

1399+instance ToHie (LHsDerivingClause GhcRn) where

1400+ toHie (L span cl) = concatM $ makeNode cl span : case cl of

1401+ HsDerivingClause _ strat (L ispan tys) ->

1402+ [ toHie strat

1403+ , pure $ locOnly ispan

1404+ , toHie $ map (TS (ResolvedScopes [])) tys

1405+ ]

1406+ XHsDerivingClause _ -> []

1407+

1408+instance ToHie (Located (DerivStrategy GhcRn)) where

1409+ toHie (L span strat) = concatM $ makeNode strat span : case strat of

1410+ StockStrategy -> []

1411+ AnyclassStrategy -> []

1412+ NewtypeStrategy -> []

1413+ ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]

1414+

1415+instance ToHie (Located OverlapMode) where

1416+ toHie (L span _) = pure $ locOnly span

1417+

1418+instance ToHie (LConDecl GhcRn) where

1419+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1420+ ConDeclGADT { con_names = names, con_qvars = qvars

1421+ , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->

1422+ [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names

1423+ , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars

1424+ , toHie ctx

1425+ , toHie args

1426+ , toHie typ

1427+ ]

1428+ where

1429+ rhsScope = combineScopes argsScope tyScope

1430+ ctxScope = maybe NoScope mkLScope ctx

1431+ argsScope = condecl_scope args

1432+ tyScope = mkLScope typ

1433+ ConDeclH98 { con_name = name, con_ex_tvs = qvars

1434+ , con_mb_cxt = ctx, con_args = dets } ->

1435+ [ toHie $ C (Decl ConDec $ getRealSpan span) name

1436+ , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars

1437+ , toHie ctx

1438+ , toHie dets

1439+ ]

1440+ where

1441+ rhsScope = combineScopes ctxScope argsScope

1442+ ctxScope = maybe NoScope mkLScope ctx

1443+ argsScope = condecl_scope dets

1444+ XConDecl _ -> []

1445+ where condecl_scope args = case args of

1446+ PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs

1447+ InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)

1448+ RecCon x -> mkLScope x

1449+

1450+instance ToHie (Located [LConDeclField GhcRn]) where

1451+ toHie (L span decls) = concatM $

1452+ [ pure $ locOnly span

1453+ , toHie decls

1454+ ]

1455+

1456+instance ( HasLoc thing

1457+ , ToHie (TScoped thing)

1458+ ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where

1459+ toHie (TS sc (HsIB ibrn a)) = concatM $

1460+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn

1461+ , toHie $ TS sc a

1462+ ]

1463+ where span = loc a

1464+ toHie (TS _ (XHsImplicitBndrs _)) = pure []

1465+

1466+instance ( HasLoc thing

1467+ , ToHie (TScoped thing)

1468+ ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where

1469+ toHie (TS sc (HsWC names a)) = concatM $

1470+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names

1471+ , toHie $ TS sc a

1472+ ]

1473+ where span = loc a

1474+ toHie (TS _ (XHsWildCardBndrs _)) = pure []

1475+

1476+instance ToHie (LStandaloneKindSig GhcRn) where

1477+ toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]

1478+

1479+instance ToHie (StandaloneKindSig GhcRn) where

1480+ toHie sig = concatM $ case sig of

1481+ StandaloneKindSig _ name typ ->

1482+ [ toHie $ C TyDecl name

1483+ , toHie $ TS (ResolvedScopes []) typ

1484+ ]

1485+ XStandaloneKindSig _ -> []

1486+

1487+instance ToHie (SigContext (LSig GhcRn)) where

1488+ toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of

1489+ TypeSig _ names typ ->

1490+ [ toHie $ map (C TyDecl) names

1491+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1492+ ]

1493+ PatSynSig _ names typ ->

1494+ [ toHie $ map (C TyDecl) names

1495+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1496+ ]

1497+ ClassOpSig _ _ names typ ->

1498+ [ case styp of

1499+ ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names

1500+ _ -> toHie $ map (C $ TyDecl) names

1501+ , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ

1502+ ]

1503+ IdSig _ _ -> []

1504+ FixSig _ fsig ->

1505+ [ toHie $ L sp fsig

1506+ ]

1507+ InlineSig _ name _ ->

1508+ [ toHie $ (C Use) name

1509+ ]

1510+ SpecSig _ name typs _ ->

1511+ [ toHie $ (C Use) name

1512+ , toHie $ map (TS (ResolvedScopes [])) typs

1513+ ]

1514+ SpecInstSig _ _ typ ->

1515+ [ toHie $ TS (ResolvedScopes []) typ

1516+ ]

1517+ MinimalSig _ _ form ->

1518+ [ toHie form

1519+ ]

1520+ SCCFunSig _ _ name mtxt ->

1521+ [ toHie $ (C Use) name

1522+ , pure $ maybe [] (locOnly . getLoc) mtxt

1523+ ]

1524+ CompleteMatchSig _ _ (L ispan names) typ ->

1525+ [ pure $ locOnly ispan

1526+ , toHie $ map (C Use) names

1527+ , toHie $ fmap (C Use) typ

1528+ ]

1529+ XSig _ -> []

1530+

1531+instance ToHie (LHsType GhcRn) where

1532+ toHie x = toHie $ TS (ResolvedScopes []) x

1533+

1534+instance ToHie (TScoped (LHsType GhcRn)) where

1535+ toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of

1536+ HsForAllTy _ _ bndrs body ->

1537+ [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs

1538+ , toHie body

1539+ ]

1540+ HsQualTy _ ctx body ->

1541+ [ toHie ctx

1542+ , toHie body

1543+ ]

1544+ HsTyVar _ _ var ->

1545+ [ toHie $ C Use var

1546+ ]

1547+ HsAppTy _ a b ->

1548+ [ toHie a

1549+ , toHie b

1550+ ]

1551+ HsAppKindTy _ ty ki ->

1552+ [ toHie ty

1553+ , toHie $ TS (ResolvedScopes []) ki

1554+ ]

1555+ HsFunTy _ a b ->

1556+ [ toHie a

1557+ , toHie b

1558+ ]

1559+ HsListTy _ a ->

1560+ [ toHie a

1561+ ]

1562+ HsTupleTy _ _ tys ->

1563+ [ toHie tys

1564+ ]

1565+ HsSumTy _ tys ->

1566+ [ toHie tys

1567+ ]

1568+ HsOpTy _ a op b ->

1569+ [ toHie a

1570+ , toHie $ C Use op

1571+ , toHie b

1572+ ]

1573+ HsParTy _ a ->

1574+ [ toHie a

1575+ ]

1576+ HsIParamTy _ ip ty ->

1577+ [ toHie ip

1578+ , toHie ty

1579+ ]

1580+ HsKindSig _ a b ->

1581+ [ toHie a

1582+ , toHie b

1583+ ]

1584+ HsSpliceTy _ a ->

1585+ [ toHie $ L span a

1586+ ]

1587+ HsDocTy _ a _ ->

1588+ [ toHie a

1589+ ]

1590+ HsBangTy _ _ ty ->

1591+ [ toHie ty

1592+ ]

1593+ HsRecTy _ fields ->

1594+ [ toHie fields

1595+ ]

1596+ HsExplicitListTy _ _ tys ->

1597+ [ toHie tys

1598+ ]

1599+ HsExplicitTupleTy _ tys ->

1600+ [ toHie tys

1601+ ]

1602+ HsTyLit _ _ -> []

1603+ HsWildCardTy _ -> []

1604+ HsStarTy _ _ -> []

1605+ XHsType _ -> []

1606+

1607+instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where

1608+ toHie (HsValArg tm) = toHie tm

1609+ toHie (HsTypeArg _ ty) = toHie ty

1610+ toHie (HsArgPar sp) = pure $ locOnly sp

1611+

1612+instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where

1613+ toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1614+ UserTyVar _ var ->

1615+ [ toHie $ C (TyVarBind sc tsc) var

1616+ ]

1617+ KindedTyVar _ var kind ->

1618+ [ toHie $ C (TyVarBind sc tsc) var

1619+ , toHie kind

1620+ ]

1621+ XTyVarBndr _ -> []

1622+

1623+instance ToHie (TScoped (LHsQTyVars GhcRn)) where

1624+ toHie (TS sc (HsQTvs implicits vars)) = concatM $

1625+ [ pure $ bindingsOnly bindings

1626+ , toHie $ tvScopes sc NoScope vars

1627+ ]

1628+ where

1629+ varLoc = loc vars

1630+ bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits

1631+ toHie (TS _ (XLHsQTyVars _)) = pure []

1632+

1633+instance ToHie (LHsContext GhcRn) where

1634+ toHie (L span tys) = concatM $

1635+ [ pure $ locOnly span

1636+ , toHie tys

1637+ ]

1638+

1639+instance ToHie (LConDeclField GhcRn) where

1640+ toHie (L span field) = concatM $ makeNode field span : case field of

1641+ ConDeclField _ fields typ _ ->

1642+ [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields

1643+ , toHie typ

1644+ ]

1645+ XConDeclField _ -> []

1646+

1647+instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where

1648+ toHie (From expr) = toHie expr

1649+ toHie (FromThen a b) = concatM $

1650+ [ toHie a

1651+ , toHie b

1652+ ]

1653+ toHie (FromTo a b) = concatM $

1654+ [ toHie a

1655+ , toHie b

1656+ ]

1657+ toHie (FromThenTo a b c) = concatM $

1658+ [ toHie a

1659+ , toHie b

1660+ , toHie c

1661+ ]

1662+

1663+instance ToHie (LSpliceDecl GhcRn) where

1664+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1665+ SpliceDecl _ splice _ ->

1666+ [ toHie splice

1667+ ]

1668+ XSpliceDecl _ -> []

1669+

1670+instance ToHie (HsBracket a) where

1671+ toHie _ = pure []

1672+

1673+instance ToHie PendingRnSplice where

1674+ toHie _ = pure []

1675+

1676+instance ToHie PendingTcSplice where

1677+ toHie _ = pure []

1678+

1679+instance ToHie (LBooleanFormula (Located Name)) where

1680+ toHie (L span form) = concatM $ makeNode form span : case form of

1681+ Var a ->

1682+ [ toHie $ C Use a

1683+ ]

1684+ And forms ->

1685+ [ toHie forms

1686+ ]

1687+ Or forms ->

1688+ [ toHie forms

1689+ ]

1690+ Parens f ->

1691+ [ toHie f

1692+ ]

1693+

1694+instance ToHie (Located HsIPName) where

1695+ toHie (L span e) = makeNode e span

1696+

1697+instance ( ToHie (LHsExpr a)

1698+ , Data (HsSplice a)

1699+ ) => ToHie (Located (HsSplice a)) where

1700+ toHie (L span sp) = concatM $ makeNode sp span : case sp of

1701+ HsTypedSplice _ _ _ expr ->

1702+ [ toHie expr

1703+ ]

1704+ HsUntypedSplice _ _ _ expr ->

1705+ [ toHie expr

1706+ ]

1707+ HsQuasiQuote _ _ _ ispan _ ->

1708+ [ pure $ locOnly ispan

1709+ ]

1710+ HsSpliced _ _ _ ->

1711+ []

1712+ HsSplicedT _ ->

1713+ []

1714+ XSplice _ -> []

1715+

1716+instance ToHie (LRoleAnnotDecl GhcRn) where

1717+ toHie (L span annot) = concatM $ makeNode annot span : case annot of

1718+ RoleAnnotDecl _ var roles ->

1719+ [ toHie $ C Use var

1720+ , concatMapM (pure . locOnly . getLoc) roles

1721+ ]

1722+ XRoleAnnotDecl _ -> []

1723+

1724+instance ToHie (LInstDecl GhcRn) where

1725+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1726+ ClsInstD _ d ->

1727+ [ toHie $ L span d

1728+ ]

1729+ DataFamInstD _ d ->

1730+ [ toHie $ L span d

1731+ ]

1732+ TyFamInstD _ d ->

1733+ [ toHie $ L span d

1734+ ]

1735+ XInstDecl _ -> []

1736+

1737+instance ToHie (LClsInstDecl GhcRn) where

1738+ toHie (L span decl) = concatM

1739+ [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl

1740+ , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl

1741+ , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl

1742+ , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl

1743+ , toHie $ cid_tyfam_insts decl

1744+ , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl

1745+ , toHie $ cid_datafam_insts decl

1746+ , toHie $ cid_overlap_mode decl

1747+ ]

1748+

1749+instance ToHie (LDataFamInstDecl GhcRn) where

1750+ toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1751+

1752+instance ToHie (LTyFamInstDecl GhcRn) where

1753+ toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1754+

1755+instance ToHie (Context a)

1756+ => ToHie (PatSynFieldContext (RecordPatSynField a)) where

1757+ toHie (PSC sp (RecordPatSynField a b)) = concatM $

1758+ [ toHie $ C (RecField RecFieldDecl sp) a

1759+ , toHie $ C Use b

1760+ ]

1761+

1762+instance ToHie (LDerivDecl GhcRn) where

1763+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1764+ DerivDecl _ typ strat overlap ->

1765+ [ toHie $ TS (ResolvedScopes []) typ

1766+ , toHie strat

1767+ , toHie overlap

1768+ ]

1769+ XDerivDecl _ -> []

1770+

1771+instance ToHie (LFixitySig GhcRn) where

1772+ toHie (L span sig) = concatM $ makeNode sig span : case sig of

1773+ FixitySig _ vars _ ->

1774+ [ toHie $ map (C Use) vars

1775+ ]

1776+ XFixitySig _ -> []

1777+

1778+instance ToHie (LDefaultDecl GhcRn) where

1779+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1780+ DefaultDecl _ typs ->

1781+ [ toHie typs

1782+ ]

1783+ XDefaultDecl _ -> []

1784+

1785+instance ToHie (LForeignDecl GhcRn) where

1786+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1787+ ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->

1788+ [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name

1789+ , toHie $ TS (ResolvedScopes []) sig

1790+ , toHie fi

1791+ ]

1792+ ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->

1793+ [ toHie $ C Use name

1794+ , toHie $ TS (ResolvedScopes []) sig

1795+ , toHie fe

1796+ ]

1797+ XForeignDecl _ -> []

1798+

1799+instance ToHie ForeignImport where

1800+ toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $

1801+ [ locOnly a

1802+ , locOnly b

1803+ , locOnly c

1804+ ]

1805+

1806+instance ToHie ForeignExport where

1807+ toHie (CExport (L a _) (L b _)) = pure $ concat $

1808+ [ locOnly a

1809+ , locOnly b

1810+ ]

1811+

1812+instance ToHie (LWarnDecls GhcRn) where

1813+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1814+ Warnings _ _ warnings ->

1815+ [ toHie warnings

1816+ ]

1817+ XWarnDecls _ -> []

1818+

1819+instance ToHie (LWarnDecl GhcRn) where

1820+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1821+ Warning _ vars _ ->

1822+ [ toHie $ map (C Use) vars

1823+ ]

1824+ XWarnDecl _ -> []

1825+

1826+instance ToHie (LAnnDecl GhcRn) where

1827+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1828+ HsAnnotation _ _ prov expr ->

1829+ [ toHie prov

1830+ , toHie expr

1831+ ]

1832+ XAnnDecl _ -> []

1833+

1834+instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where

1835+ toHie (ValueAnnProvenance a) = toHie $ C Use a

1836+ toHie (TypeAnnProvenance a) = toHie $ C Use a

1837+ toHie ModuleAnnProvenance = pure []

1838+

1839+instance ToHie (LRuleDecls GhcRn) where

1840+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1841+ HsRules _ _ rules ->

1842+ [ toHie rules

1843+ ]

1844+ XRuleDecls _ -> []

1845+

1846+instance ToHie (LRuleDecl GhcRn) where

1847+ toHie (L _ (XRuleDecl _)) = pure []

1848+ toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM

1849+ [ makeNode r span

1850+ , pure $ locOnly $ getLoc rname

1851+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1852+ , toHie $ map (RS $ mkScope span) bndrs

1853+ , toHie exprA

1854+ , toHie exprB

1855+ ]

1856+ where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc

1857+ bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)

1858+ exprA_sc = mkLScope exprA

1859+ exprB_sc = mkLScope exprB

1860+

1861+instance ToHie (RScoped (LRuleBndr GhcRn)) where

1862+ toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1863+ RuleBndr _ var ->

1864+ [ toHie $ C (ValBind RegularBind sc Nothing) var

1865+ ]

1866+ RuleBndrSig _ var typ ->

1867+ [ toHie $ C (ValBind RegularBind sc Nothing) var

1868+ , toHie $ TS (ResolvedScopes [sc]) typ

1869+ ]

1870+ XRuleBndr _ -> []

1871+

1872+instance ToHie (LImportDecl GhcRn) where

1873+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1874+ ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->

1875+ [ toHie $ IEC Import name

1876+ , toHie $ fmap (IEC ImportAs) as

1877+ , maybe (pure []) goIE hidden

1878+ ]

1879+ XImportDecl _ -> []

1880+ where

1881+ goIE (hiding, (L sp liens)) = concatM $

1882+ [ pure $ locOnly sp

1883+ , toHie $ map (IEC c) liens

1884+ ]

1885+ where

1886+ c = if hiding then ImportHiding else Import

1887+

1888+instance ToHie (IEContext (LIE GhcRn)) where

1889+ toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of

1890+ IEVar _ n ->

1891+ [ toHie $ IEC c n

1892+ ]

1893+ IEThingAbs _ n ->

1894+ [ toHie $ IEC c n

1895+ ]

1896+ IEThingAll _ n ->

1897+ [ toHie $ IEC c n

1898+ ]

1899+ IEThingWith _ n _ ns flds ->

1900+ [ toHie $ IEC c n

1901+ , toHie $ map (IEC c) ns

1902+ , toHie $ map (IEC c) flds

1903+ ]

1904+ IEModuleContents _ n ->

1905+ [ toHie $ IEC c n

1906+ ]

1907+ IEGroup _ _ _ -> []

1908+ IEDoc _ _ -> []

1909+ IEDocNamed _ _ -> []

1910+ XIE _ -> []

1911+

1912+instance ToHie (IEContext (LIEWrappedName Name)) where

1913+ toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of

1914+ IEName n ->

1915+ [ toHie $ C (IEThing c) n

1916+ ]

1917+ IEPattern p ->

1918+ [ toHie $ C (IEThing c) p

1919+ ]

1920+ IEType n ->

1921+ [ toHie $ C (IEThing c) n

1922+ ]

1923+

1924+instance ToHie (IEContext (Located (FieldLbl Name))) where

1925+ toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of

1926+ FieldLabel _ _ n ->

1927+ [ toHie $ C (IEThing c) $ L span n

1928+ ]

src-ghc88/Development/IDE/GHC/HieAst.hsnew file+1789

@@ -0,0 +1,1789 @@

2+{-

3+Forked from GHC v8.8.1 to work around the readFile side effect in mkHiefile

5+Main functions for .hie file generation

6+-}

7+{- HLINT ignore -}

8+{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE FlexibleInstances #-}

10+{-# LANGUAGE UndecidableInstances #-}

11+{-# LANGUAGE FlexibleContexts #-}

12+{-# LANGUAGE TypeSynonymInstances #-}

13+{-# LANGUAGE ScopedTypeVariables #-}

14+{-# LANGUAGE TypeFamilies #-}

15+{-# LANGUAGE TypeApplications #-}

16+{-# LANGUAGE AllowAmbiguousTypes #-}

17+{-# LANGUAGE ViewPatterns #-}

18+{-# LANGUAGE DeriveDataTypeable #-}

19+module Development.IDE.GHC.HieAst ( mkHieFile ) where

20+

21+import Avail ( Avails )

22+import Bag ( Bag, bagToList )

23+import BasicTypes

24+import BooleanFormula

25+import Class ( FunDep )

26+import CoreUtils ( exprType )

27+import ConLike ( conLikeName )

28+import Desugar ( deSugarExpr )

29+import FieldLabel

30+import HsSyn

31+import HscTypes

32+import Module ( ModuleName, ml_hs_file )

33+import MonadUtils ( concatMapM, liftIO )

34+import Name ( Name, nameSrcSpan, setNameLoc )

35+import SrcLoc

36+import TcHsSyn ( hsLitType, hsPatType )

37+import Type ( mkFunTys, Type )

38+import TysWiredIn ( mkListTy, mkSumTy )

39+import Var ( Id, Var, setVarName, varName, varType )

40+import TcRnTypes

41+import MkIface ( mkIfaceExports )

42+

43+import HieTypes

44+import HieUtils

45+

46+import qualified Data.Array as A

47+import qualified Data.ByteString as BS

48+import qualified Data.Map as M

49+import qualified Data.Set as S

50+import Data.Data ( Data, Typeable )

51+import Data.List (foldl', foldl1' )

52+import Data.Maybe ( listToMaybe )

53+import Control.Monad.Trans.Reader

54+import Control.Monad.Trans.Class ( lift )

55+

56+-- These synonyms match those defined in main/GHC.hs

57+type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn]

58+ , Maybe [(LIE GhcRn, Avails)]

59+ , Maybe LHsDocString )

60+type TypecheckedSource = LHsBinds GhcTc

61+

62+

63+{- Note [Name Remapping]

64+The Typechecker introduces new names for mono names in AbsBinds.

65+We don't care about the distinction between mono and poly bindings,

66+so we replace all occurrences of the mono name with the poly name.

67+-}

68+newtype HieState = HieState

69+ { name_remapping :: M.Map Name Id

70+ }

71+

72+initState :: HieState

73+initState = HieState M.empty

74+

75+class ModifyState a where -- See Note [Name Remapping]

76+ addSubstitution :: a -> a -> HieState -> HieState

77+

78+instance ModifyState Name where

79+ addSubstitution _ _ hs = hs

80+

81+instance ModifyState Id where

82+ addSubstitution mono poly hs =

83+ hs{name_remapping = M.insert (varName mono) poly (name_remapping hs)}

84+

85+modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState

86+modifyState = foldr go id

87+ where

88+ go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f

89+ go _ f = f

90+

91+type HieM = ReaderT HieState Hsc

92+

93+-- | Construct an 'HieFile' from the outputs of the typechecker.

94+mkHieFile :: ModSummary

95+ -> TcGblEnv

96+ -> RenamedSource

97+ -> BS.ByteString

98+ -> Hsc HieFile

99+mkHieFile ms ts rs src = do

100+ let tc_binds = tcg_binds ts

101+ (asts', arr) <- getCompressedAsts tc_binds rs

102+ let Just src_file = ml_hs_file $ ms_location ms

103+ return $ HieFile

104+ { hie_hs_file = src_file

105+ , hie_module = ms_mod ms

106+ , hie_types = arr

107+ , hie_asts = asts'

108+ -- mkIfaceExports sorts the AvailInfos for stability

109+ , hie_exports = mkIfaceExports (tcg_exports ts)

110+ , hie_hs_src = src

111+ }

112+

113+getCompressedAsts :: TypecheckedSource -> RenamedSource

114+ -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)

115+getCompressedAsts ts rs = do

116+ asts <- enrichHie ts rs

117+ return $ compressTypes asts

118+

119+enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)

120+enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do

121+ tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts

122+ rasts <- processGrp hsGrp

123+ imps <- toHie $ filter (not . ideclImplicit . unLoc) imports

124+ exps <- toHie $ fmap (map $ IEC Export . fst) exports

125+ let spanFile children = case children of

126+ [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)

127+ _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)

128+ (realSrcSpanEnd $ nodeSpan $ last children)

129+

130+ modulify xs =

131+ Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs

132+

133+ asts = HieASTs

134+ $ resolveTyVarScopes

135+ $ M.map (modulify . mergeSortAsts)

136+ $ M.fromListWith (++)

137+ $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts

138+

139+ flat_asts = concat

140+ [ tasts

141+ , rasts

142+ , imps

143+ , exps

144+ ]

145+ return asts

146+ where

147+ processGrp grp = concatM

148+ [ toHie $ fmap (RS ModuleScope ) hs_valds grp

149+ , toHie $ hs_splcds grp

150+ , toHie $ hs_tyclds grp

151+ , toHie $ hs_derivds grp

152+ , toHie $ hs_fixds grp

153+ , toHie $ hs_defds grp

154+ , toHie $ hs_fords grp

155+ , toHie $ hs_warnds grp

156+ , toHie $ hs_annds grp

157+ , toHie $ hs_ruleds grp

158+ ]

159+

160+getRealSpan :: SrcSpan -> Maybe Span

161+getRealSpan (RealSrcSpan sp) = Just sp

162+getRealSpan _ = Nothing

163+

164+grhss_span :: GRHSs p body -> SrcSpan

165+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)

166+grhss_span (XGRHSs _) = error "XGRHS has no span"

167+

168+bindingsOnly :: [Context Name] -> [HieAST a]

169+bindingsOnly [] = []

170+bindingsOnly (C c n : xs) = case nameSrcSpan n of

171+ RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs

172+ where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)

173+ info = mempty{identInfo = S.singleton c}

174+ _ -> bindingsOnly xs

175+

176+concatM :: Monad m => [m [a]] -> m [a]

177+concatM xs = concat <$> sequence xs

178+

179+{- Note [Capturing Scopes and other non local information]

180+toHie is a local tranformation, but scopes of bindings cannot be known locally,

181+hence we have to push the relevant info down into the binding nodes.

182+We use the following types (*Context and *Scoped) to wrap things and

183+carry the required info

184+(Maybe Span) always carries the span of the entire binding, including rhs

185+-}

186+data Context a = C ContextInfo a -- Used for names and bindings

187+

188+data RContext a = RC RecFieldContext a

189+data RFContext a = RFC RecFieldContext (Maybe Span) a

190+-- ^ context for record fields

191+

192+data IEContext a = IEC IEType a

193+-- ^ context for imports/exports

194+

195+data BindContext a = BC BindType Scope a

196+-- ^ context for imports/exports

197+

198+data PatSynFieldContext a = PSC (Maybe Span) a

199+-- ^ context for pattern synonym fields.

200+

201+data SigContext a = SC SigInfo a

202+-- ^ context for type signatures

203+

204+data SigInfo = SI SigType (Maybe Span)

205+

206+data SigType = BindSig | ClassSig | InstSig

207+

208+data RScoped a = RS Scope a

209+-- ^ Scope spans over everything to the right of a, (mostly) not

210+-- including a itself

211+-- (Includes a in a few special cases like recursive do bindings) or

212+-- let/where bindings

213+

214+-- | Pattern scope

215+data PScoped a = PS (Maybe Span)

216+ Scope -- ^ use site of the pattern

217+ Scope -- ^ pattern to the right of a, not including a

218+ a

219+ deriving (Typeable, Data) -- Pattern Scope

220+

221+{- Note [TyVar Scopes]

222+Due to -XScopedTypeVariables, type variables can be in scope quite far from

223+their original binding. We resolve the scope of these type variables

224+in a separate pass

225+-}

226+data TScoped a = TS TyVarScope a -- TyVarScope

227+

228+data TVScoped a = TVS TyVarScope Scope a -- TyVarScope

229+-- ^ First scope remains constant

230+-- Second scope is used to build up the scope of a tyvar over

231+-- things to its right, ala RScoped

232+

233+-- | Each element scopes over the elements to the right

234+listScopes :: Scope -> [Located a] -> [RScoped (Located a)]

235+listScopes _ [] = []

236+listScopes rhsScope [pat] = [RS rhsScope pat]

237+listScopes rhsScope (pat : pats) = RS sc pat : pats'

238+ where

239+ pats'@((RS scope p):_) = listScopes rhsScope pats

240+ sc = combineScopes scope $ mkScope $ getLoc p

241+

242+-- | 'listScopes' specialised to 'PScoped' things

243+patScopes

244+ :: Maybe Span

245+ -> Scope

246+ -> Scope

247+ -> [LPat (GhcPass p)]

248+ -> [PScoped (LPat (GhcPass p))]

249+patScopes rsp useScope patScope xs =

250+ map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $

251+ listScopes patScope (map dL xs)

252+

253+-- | 'listScopes' specialised to 'TVScoped' things

254+tvScopes

255+ :: TyVarScope

256+ -> Scope

257+ -> [LHsTyVarBndr a]

258+ -> [TVScoped (LHsTyVarBndr a)]

259+tvScopes tvScope rhsScope xs =

260+ map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs

261+

262+{- Note [Scoping Rules for SigPat]

263+Explicitly quantified variables in pattern type signatures are not

264+brought into scope in the rhs, but implicitly quantified variables

265+are (HsWC and HsIB).

266+This is unlike other signatures, where explicitly quantified variables

267+are brought into the RHS Scope

268+For example

269+foo :: forall a. ...;

270+foo = ... -- a is in scope here

271+

272+bar (x :: forall a. a -> a) = ... -- a is not in scope here

273+-- ^ a is in scope here (pattern body)

274+

275+bax (x :: a) = ... -- a is in scope here

276+Because of HsWC and HsIB pass on their scope to their children

277+we must wrap the LHsType in pattern signatures in a

278+Shielded explictly, so that the HsWC/HsIB scope is not passed

279+on the the LHsType

280+-}

281+

282+data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead

283+

284+type family ProtectedSig a where

285+ ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs

286+ GhcRn

287+ (Shielded (LHsType GhcRn)))

288+ ProtectedSig GhcTc = NoExt

289+

290+class ProtectSig a where

291+ protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a

292+

293+instance (HasLoc a) => HasLoc (Shielded a) where

294+ loc (SH _ a) = loc a

295+

296+instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where

297+ toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)

298+

299+instance ProtectSig GhcTc where

300+ protectSig _ _ = NoExt

301+

302+instance ProtectSig GhcRn where

303+ protectSig sc (HsWC a (HsIB b sig)) =

304+ HsWC a (HsIB b (SH sc sig))

305+ protectSig _ _ = error "protectSig not given HsWC (HsIB)"

306+

307+class HasLoc a where

308+ -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can

309+ -- know what their implicit bindings are scoping over

310+ loc :: a -> SrcSpan

311+

312+instance HasLoc thing => HasLoc (TScoped thing) where

313+ loc (TS _ a) = loc a

314+

315+instance HasLoc thing => HasLoc (PScoped thing) where

316+ loc (PS _ _ _ a) = loc a

317+

318+instance HasLoc (LHsQTyVars GhcRn) where

319+ loc (HsQTvs _ vs) = loc vs

320+ loc _ = noSrcSpan

321+

322+instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where

323+ loc (HsIB _ a) = loc a

324+ loc _ = noSrcSpan

325+

326+instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where

327+ loc (HsWC _ a) = loc a

328+ loc _ = noSrcSpan

329+

330+instance HasLoc (Located a) where

331+ loc (L l _) = l

332+

333+instance HasLoc a => HasLoc [a] where

334+ loc [] = noSrcSpan

335+ loc xs = foldl1' combineSrcSpans $ map loc xs

336+

337+instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where

338+ loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]

339+ loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans

340+ [loc a, loc tvs, loc b, loc c]

341+ loc _ = noSrcSpan

342+instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where

343+ loc (HsValArg tm) = loc tm

344+ loc (HsTypeArg _ ty) = loc ty

345+ loc (HsArgPar sp) = sp

346+

347+instance HasLoc (HsDataDefn GhcRn) where

348+ loc def@(HsDataDefn{}) = loc $ dd_cons def

349+ -- Only used for data family instances, so we only need rhs

350+ -- Most probably the rest will be unhelpful anyway

351+ loc _ = noSrcSpan

352+

353+instance HasLoc (Pat (GhcPass a)) where

354+ loc (dL -> L l _) = l

355+

356+-- | The main worker class

357+class ToHie a where

358+ toHie :: a -> HieM [HieAST Type]

359+

360+-- | Used to collect type info

361+class Data a => HasType a where

362+ getTypeNode :: a -> HieM [HieAST Type]

363+

364+instance (ToHie a) => ToHie [a] where

365+ toHie = concatMapM toHie

366+

367+instance (ToHie a) => ToHie (Bag a) where

368+ toHie = toHie . bagToList

369+

370+instance (ToHie a) => ToHie (Maybe a) where

371+ toHie = maybe (pure []) toHie

372+

373+instance ToHie (Context (Located NoExt)) where

374+ toHie _ = pure []

375+

376+instance ToHie (TScoped NoExt) where

377+ toHie _ = pure []

378+

379+instance ToHie (IEContext (Located ModuleName)) where

380+ toHie (IEC c (L (RealSrcSpan span) mname)) =

381+ pure $ [Node (NodeInfo S.empty [] idents) span []]

382+ where details = mempty{identInfo = S.singleton (IEThing c)}

383+ idents = M.singleton (Left mname) details

384+ toHie _ = pure []

385+

386+instance ToHie (Context (Located Var)) where

387+ toHie c = case c of

388+ C context (L (RealSrcSpan span) name')

389+ -> do

390+ m <- asks name_remapping

391+ let name = M.findWithDefault name' (varName name') m

392+ pure

393+ [Node

394+ (NodeInfo S.empty [] $

395+ M.singleton (Right $ varName name)

396+ (IdentifierDetails (Just $ varType name')

397+ (S.singleton context)))

398+ span

399+ []]

400+ _ -> pure []

401+

402+instance ToHie (Context (Located Name)) where

403+ toHie c = case c of

404+ C context (L (RealSrcSpan span) name') -> do

405+ m <- asks name_remapping

406+ let name = case M.lookup name' m of

407+ Just var -> varName var

408+ Nothing -> name'

409+ pure

410+ [Node

411+ (NodeInfo S.empty [] $

412+ M.singleton (Right name)

413+ (IdentifierDetails Nothing

414+ (S.singleton context)))

415+ span

416+ []]

417+ _ -> pure []

418+

419+-- | Dummy instances - never called

420+instance ToHie (TScoped (LHsSigWcType GhcTc)) where

421+ toHie _ = pure []

422+instance ToHie (TScoped (LHsWcType GhcTc)) where

423+ toHie _ = pure []

424+instance ToHie (SigContext (LSig GhcTc)) where

425+ toHie _ = pure []

426+instance ToHie (TScoped Type) where

427+ toHie _ = pure []

428+

429+instance HasType (LHsBind GhcRn) where

430+ getTypeNode (L spn bind) = makeNode bind spn

431+

432+instance HasType (LHsBind GhcTc) where

433+ getTypeNode (L spn bind) = case bind of

434+ FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)

435+ _ -> makeNode bind spn

436+

437+instance HasType (LPat GhcRn) where

438+ getTypeNode (dL -> L spn pat) = makeNode pat spn

439+

440+instance HasType (LPat GhcTc) where

441+ getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)

442+

443+instance HasType (LHsExpr GhcRn) where

444+ getTypeNode (L spn e) = makeNode e spn

445+

446+-- | This instance tries to construct 'HieAST' nodes which include the type of

447+-- the expression. It is not yet possible to do this efficiently for all

448+-- expression forms, so we skip filling in the type for those inputs.

449+--

450+-- 'HsApp', for example, doesn't have any type information available directly on

451+-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then

452+-- query the type of that. Yet both the desugaring call and the type query both

453+-- involve recursive calls to the function and argument! This is particularly

454+-- problematic when you realize that the HIE traversal will eventually visit

455+-- those nodes too and ask for their types again.

456+--

457+-- Since the above is quite costly, we just skip cases where computing the

458+-- expression's type is going to be expensive.

459+--

460+-- See #16233

461+instance HasType (LHsExpr GhcTc) where

462+ getTypeNode e@(L spn e') = lift $

463+ -- Some expression forms have their type immediately available

464+ let tyOpt = case e' of

465+ HsLit _ l -> Just (hsLitType l)

466+ HsOverLit _ o -> Just (overLitType o)

467+

468+ HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)

469+ HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)

470+ HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)

471+

472+ ExplicitList ty _ _ -> Just (mkListTy ty)

473+ ExplicitSum ty _ _ _ -> Just (mkSumTy ty)

474+ HsDo ty _ _ -> Just ty

475+ HsMultiIf ty _ -> Just ty

476+

477+ _ -> Nothing

478+

479+ in

480+ case tyOpt of

481+ _ | skipDesugaring e' -> fallback

482+ | otherwise -> do

483+ hs_env <- Hsc $ \e w -> return (e,w)

484+ (_,mbe) <- liftIO $ deSugarExpr hs_env e

485+ maybe fallback (makeTypeNode e' spn . exprType) mbe

486+ where

487+ fallback = makeNode e' spn

488+

489+ matchGroupType :: MatchGroupTc -> Type

490+ matchGroupType (MatchGroupTc args res) = mkFunTys args res

491+

492+ -- | Skip desugaring of these expressions for performance reasons.

493+ --

494+ -- See impact on Haddock output (esp. missing type annotations or links)

495+ -- before marking more things here as 'False'. See impact on Haddock

496+ -- performance before marking more things as 'True'.

497+ skipDesugaring :: HsExpr a -> Bool

498+ skipDesugaring e = case e of

499+ HsVar{} -> False

500+ HsUnboundVar{} -> False

501+ HsConLikeOut{} -> False

502+ HsRecFld{} -> False

503+ HsOverLabel{} -> False

504+ HsIPVar{} -> False

505+ HsWrap{} -> False

506+ _ -> True

507+

508+instance ( ToHie (Context (Located (IdP a)))

509+ , ToHie (MatchGroup a (LHsExpr a))

510+ , ToHie (PScoped (LPat a))

511+ , ToHie (GRHSs a (LHsExpr a))

512+ , ToHie (LHsExpr a)

513+ , ToHie (Located (PatSynBind a a))

514+ , HasType (LHsBind a)

515+ , ModifyState (IdP a)

516+ , Data (HsBind a)

517+ ) => ToHie (BindContext (LHsBind a)) where

518+ toHie (BC context scope b@(L span bind)) =

519+ concatM $ getTypeNode b : case bind of

520+ FunBind{fun_id = name, fun_matches = matches} ->

521+ [ toHie $ C (ValBind context scope $ getRealSpan span) name

522+ , toHie matches

523+ ]

524+ PatBind{pat_lhs = lhs, pat_rhs = rhs} ->

525+ [ toHie $ PS (getRealSpan span) scope NoScope lhs

526+ , toHie rhs

527+ ]

528+ VarBind{var_rhs = expr} ->

529+ [ toHie expr

530+ ]

531+ AbsBinds{abs_exports = xs, abs_binds = binds} ->

532+ [ local (modifyState xs) $ -- Note [Name Remapping]

533+ toHie $ fmap (BC context scope) binds

534+ ]

535+ PatSynBind _ psb ->

536+ [ toHie $ L span psb -- PatSynBinds only occur at the top level

537+ ]

538+ XHsBindsLR _ -> []

539+

540+instance ( ToHie (LMatch a body)

541+ ) => ToHie (MatchGroup a body) where

542+ toHie mg = concatM $ case mg of

543+ MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->

544+ [ pure $ locOnly span

545+ , toHie alts

546+ ]

547+ MG{} -> []

548+ XMatchGroup _ -> []

549+

550+instance ( ToHie (Context (Located (IdP a)))

551+ , ToHie (PScoped (LPat a))

552+ , ToHie (HsPatSynDir a)

553+ ) => ToHie (Located (PatSynBind a a)) where

554+ toHie (L sp psb) = concatM $ case psb of

555+ PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->

556+ [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var

557+ , toHie $ toBind dets

558+ , toHie $ PS Nothing lhsScope NoScope pat

559+ , toHie dir

560+ ]

561+ where

562+ lhsScope = combineScopes varScope detScope

563+ varScope = mkLScope var

564+ detScope = case dets of

565+ (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args

566+ (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)

567+ (RecCon r) -> foldr go NoScope r

568+ go (RecordPatSynField a b) c = combineScopes c

569+ $ combineScopes (mkLScope a) (mkLScope b)

570+ detSpan = case detScope of

571+ LocalScope a -> Just a

572+ _ -> Nothing

573+ toBind (PrefixCon args) = PrefixCon $ map (C Use) args

574+ toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)

575+ toBind (RecCon r) = RecCon $ map (PSC detSpan) r

576+ XPatSynBind _ -> []

577+

578+instance ( ToHie (MatchGroup a (LHsExpr a))

579+ ) => ToHie (HsPatSynDir a) where

580+ toHie dir = case dir of

581+ ExplicitBidirectional mg -> toHie mg

582+ _ -> pure []

583+

584+instance ( a ~ GhcPass p

585+ , ToHie body

586+ , ToHie (HsMatchContext (NameOrRdrName (IdP a)))

587+ , ToHie (PScoped (LPat a))

588+ , ToHie (GRHSs a body)

589+ , Data (Match a body)

590+ ) => ToHie (LMatch (GhcPass p) body) where

591+ toHie (L span m ) = concatM $ makeNode m span : case m of

592+ Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->

593+ [ toHie mctx

594+ , let rhsScope = mkScope $ grhss_span grhss

595+ in toHie $ patScopes Nothing rhsScope NoScope pats

596+ , toHie grhss

597+ ]

598+ XMatch _ -> []

599+

600+instance ( ToHie (Context (Located a))

601+ ) => ToHie (HsMatchContext a) where

602+ toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name

603+ toHie (StmtCtxt a) = toHie a

604+ toHie _ = pure []

605+

606+instance ( ToHie (HsMatchContext a)

607+ ) => ToHie (HsStmtContext a) where

608+ toHie (PatGuard a) = toHie a

609+ toHie (ParStmtCtxt a) = toHie a

610+ toHie (TransStmtCtxt a) = toHie a

611+ toHie _ = pure []

612+

613+instance ( a ~ GhcPass p

614+ , ToHie (Context (Located (IdP a)))

615+ , ToHie (RContext (HsRecFields a (PScoped (LPat a))))

616+ , ToHie (LHsExpr a)

617+ , ToHie (TScoped (LHsSigWcType a))

618+ , ProtectSig a

619+ , ToHie (TScoped (ProtectedSig a))

620+ , HasType (LPat a)

621+ , Data (HsSplice a)

622+ ) => ToHie (PScoped (LPat (GhcPass p))) where

623+ toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =

624+ concatM $ getTypeNode lpat : case opat of

625+ WildPat _ ->

626+ []

627+ VarPat _ lname ->

628+ [ toHie $ C (PatternBind scope pscope rsp) lname

629+ ]

630+ LazyPat _ p ->

631+ [ toHie $ PS rsp scope pscope p

632+ ]

633+ AsPat _ lname pat ->

634+ [ toHie $ C (PatternBind scope

635+ (combineScopes (mkLScope (dL pat)) pscope)

636+ rsp)

637+ lname

638+ , toHie $ PS rsp scope pscope pat

639+ ]

640+ ParPat _ pat ->

641+ [ toHie $ PS rsp scope pscope pat

642+ ]

643+ BangPat _ pat ->

644+ [ toHie $ PS rsp scope pscope pat

645+ ]

646+ ListPat _ pats ->

647+ [ toHie $ patScopes rsp scope pscope pats

648+ ]

649+ TuplePat _ pats _ ->

650+ [ toHie $ patScopes rsp scope pscope pats

651+ ]

652+ SumPat _ pat _ _ ->

653+ [ toHie $ PS rsp scope pscope pat

654+ ]

655+ ConPatIn c dets ->

656+ [ toHie $ C Use c

657+ , toHie $ contextify dets

658+ ]

659+ ConPatOut {pat_con = con, pat_args = dets}->

660+ [ toHie $ C Use $ fmap conLikeName con

661+ , toHie $ contextify dets

662+ ]

663+ ViewPat _ expr pat ->

664+ [ toHie expr

665+ , toHie $ PS rsp scope pscope pat

666+ ]

667+ SplicePat _ sp ->

668+ [ toHie $ L ospan sp

669+ ]

670+ LitPat _ _ ->

671+ []

672+ NPat _ _ _ _ ->

673+ []

674+ NPlusKPat _ n _ _ _ _ ->

675+ [ toHie $ C (PatternBind scope pscope rsp) n

676+ ]

677+ SigPat _ pat sig ->

678+ [ toHie $ PS rsp scope pscope pat

679+ , let cscope = mkLScope (dL pat) in

680+ toHie $ TS (ResolvedScopes [cscope, scope, pscope])

681+ (protectSig @a cscope sig)

682+ -- See Note [Scoping Rules for SigPat]

683+ ]

684+ CoPat _ _ _ _ ->

685+ []

686+ XPat _ -> []

687+ where

688+ contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args

689+ contextify (InfixCon a b) = InfixCon a' b'

690+ where [a', b'] = patScopes rsp scope pscope [a,b]

691+ contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r

692+ contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a

693+ where

694+ go (RS fscope (L spn (HsRecField lbl pat pun))) =

695+ L spn $ HsRecField lbl (PS rsp scope fscope pat) pun

696+ scoped_fds = listScopes pscope fds

697+

698+instance ( ToHie body

699+ , ToHie (LGRHS a body)

700+ , ToHie (RScoped (LHsLocalBinds a))

701+ ) => ToHie (GRHSs a body) where

702+ toHie grhs = concatM $ case grhs of

703+ GRHSs _ grhss binds ->

704+ [ toHie grhss

705+ , toHie $ RS (mkScope $ grhss_span grhs) binds

706+ ]

707+ XGRHSs _ -> []

708+

709+instance ( ToHie (Located body)

710+ , ToHie (RScoped (GuardLStmt a))

711+ , Data (GRHS a (Located body))

712+ ) => ToHie (LGRHS a (Located body)) where

713+ toHie (L span g) = concatM $ makeNode g span : case g of

714+ GRHS _ guards body ->

715+ [ toHie $ listScopes (mkLScope body) guards

716+ , toHie body

717+ ]

718+ XGRHS _ -> []

719+

720+instance ( a ~ GhcPass p

721+ , ToHie (Context (Located (IdP a)))

722+ , HasType (LHsExpr a)

723+ , ToHie (PScoped (LPat a))

724+ , ToHie (MatchGroup a (LHsExpr a))

725+ , ToHie (LGRHS a (LHsExpr a))

726+ , ToHie (RContext (HsRecordBinds a))

727+ , ToHie (RFContext (Located (AmbiguousFieldOcc a)))

728+ , ToHie (ArithSeqInfo a)

729+ , ToHie (LHsCmdTop a)

730+ , ToHie (RScoped (GuardLStmt a))

731+ , ToHie (RScoped (LHsLocalBinds a))

732+ , ToHie (TScoped (LHsWcType (NoGhcTc a)))

733+ , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))

734+ , Data (HsExpr a)

735+ , Data (HsSplice a)

736+ , Data (HsTupArg a)

737+ , Data (AmbiguousFieldOcc a)

738+ ) => ToHie (LHsExpr (GhcPass p)) where

739+ toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of

740+ HsVar _ (L _ var) ->

741+ [ toHie $ C Use (L mspan var)

742+ -- Patch up var location since typechecker removes it

743+ ]

744+ HsUnboundVar _ _ ->

745+ []

746+ HsConLikeOut _ con ->

747+ [ toHie $ C Use $ L mspan $ conLikeName con

748+ ]

749+ HsRecFld _ fld ->

750+ [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)

751+ ]

752+ HsOverLabel _ _ _ -> []

753+ HsIPVar _ _ -> []

754+ HsOverLit _ _ -> []

755+ HsLit _ _ -> []

756+ HsLam _ mg ->

757+ [ toHie mg

758+ ]

759+ HsLamCase _ mg ->

760+ [ toHie mg

761+ ]

762+ HsApp _ a b ->

763+ [ toHie a

764+ , toHie b

765+ ]

766+ HsAppType _ expr sig ->

767+ [ toHie expr

768+ , toHie $ TS (ResolvedScopes []) sig

769+ ]

770+ OpApp _ a b c ->

771+ [ toHie a

772+ , toHie b

773+ , toHie c

774+ ]

775+ NegApp _ a _ ->

776+ [ toHie a

777+ ]

778+ HsPar _ a ->

779+ [ toHie a

780+ ]

781+ SectionL _ a b ->

782+ [ toHie a

783+ , toHie b

784+ ]

785+ SectionR _ a b ->

786+ [ toHie a

787+ , toHie b

788+ ]

789+ ExplicitTuple _ args _ ->

790+ [ toHie args

791+ ]

792+ ExplicitSum _ _ _ expr ->

793+ [ toHie expr

794+ ]

795+ HsCase _ expr matches ->

796+ [ toHie expr

797+ , toHie matches

798+ ]

799+ HsIf _ _ a b c ->

800+ [ toHie a

801+ , toHie b

802+ , toHie c

803+ ]

804+ HsMultiIf _ grhss ->

805+ [ toHie grhss

806+ ]

807+ HsLet _ binds expr ->

808+ [ toHie $ RS (mkLScope expr) binds

809+ , toHie expr

810+ ]

811+ HsDo _ _ (L ispan stmts) ->

812+ [ pure $ locOnly ispan

813+ , toHie $ listScopes NoScope stmts

814+ ]

815+ ExplicitList _ _ exprs ->

816+ [ toHie exprs

817+ ]

818+ RecordCon {rcon_con_name = name, rcon_flds = binds}->

819+ [ toHie $ C Use name

820+ , toHie $ RC RecFieldAssign $ binds

821+ ]

822+ RecordUpd {rupd_expr = expr, rupd_flds = upds}->

823+ [ toHie expr

824+ , toHie $ map (RC RecFieldAssign) upds

825+ ]

826+ ExprWithTySig _ expr sig ->

827+ [ toHie expr

828+ , toHie $ TS (ResolvedScopes [mkLScope expr]) sig

829+ ]

830+ ArithSeq _ _ info ->

831+ [ toHie info

832+ ]

833+ HsSCC _ _ _ expr ->

834+ [ toHie expr

835+ ]

836+ HsCoreAnn _ _ _ expr ->

837+ [ toHie expr

838+ ]

839+ HsProc _ pat cmdtop ->

840+ [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat

841+ , toHie cmdtop

842+ ]

843+ HsStatic _ expr ->

844+ [ toHie expr

845+ ]

846+ HsArrApp _ a b _ _ ->

847+ [ toHie a

848+ , toHie b

849+ ]

850+ HsArrForm _ expr _ cmds ->

851+ [ toHie expr

852+ , toHie cmds

853+ ]

854+ HsTick _ _ expr ->

855+ [ toHie expr

856+ ]

857+ HsBinTick _ _ _ expr ->

858+ [ toHie expr

859+ ]

860+ HsTickPragma _ _ _ _ expr ->

861+ [ toHie expr

862+ ]

863+ HsWrap _ _ a ->

864+ [ toHie $ L mspan a

865+ ]

866+ HsBracket _ b ->

867+ [ toHie b

868+ ]

869+ HsRnBracketOut _ b p ->

870+ [ toHie b

871+ , toHie p

872+ ]

873+ HsTcBracketOut _ b p ->

874+ [ toHie b

875+ , toHie p

876+ ]

877+ HsSpliceE _ x ->

878+ [ toHie $ L mspan x

879+ ]

880+ EWildPat _ -> []

881+ EAsPat _ a b ->

882+ [ toHie $ C Use a

883+ , toHie b

884+ ]

885+ EViewPat _ a b ->

886+ [ toHie a

887+ , toHie b

888+ ]

889+ ELazyPat _ a ->

890+ [ toHie a

891+ ]

892+ XExpr _ -> []

893+

894+instance ( a ~ GhcPass p

895+ , ToHie (LHsExpr a)

896+ , Data (HsTupArg a)

897+ ) => ToHie (LHsTupArg (GhcPass p)) where

898+ toHie (L span arg) = concatM $ makeNode arg span : case arg of

899+ Present _ expr ->

900+ [ toHie expr

901+ ]

902+ Missing _ -> []

903+ XTupArg _ -> []

904+

905+instance ( a ~ GhcPass p

906+ , ToHie (PScoped (LPat a))

907+ , ToHie (LHsExpr a)

908+ , ToHie (SigContext (LSig a))

909+ , ToHie (RScoped (LHsLocalBinds a))

910+ , ToHie (RScoped (ApplicativeArg a))

911+ , ToHie (Located body)

912+ , Data (StmtLR a a (Located body))

913+ , Data (StmtLR a a (Located (HsExpr a)))

914+ ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where

915+ toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of

916+ LastStmt _ body _ _ ->

917+ [ toHie body

918+ ]

919+ BindStmt _ pat body _ _ ->

920+ [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat

921+ , toHie body

922+ ]

923+ ApplicativeStmt _ stmts _ ->

924+ [ concatMapM (toHie . RS scope . snd) stmts

925+ ]

926+ BodyStmt _ body _ _ ->

927+ [ toHie body

928+ ]

929+ LetStmt _ binds ->

930+ [ toHie $ RS scope binds

931+ ]

932+ ParStmt _ parstmts _ _ ->

933+ [ concatMapM (\(ParStmtBlock _ stmts _ _) ->

934+ toHie $ listScopes NoScope stmts)

935+ parstmts

936+ ]

937+ TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->

938+ [ toHie $ listScopes scope stmts

939+ , toHie using

940+ , toHie by

941+ ]

942+ RecStmt {recS_stmts = stmts} ->

943+ [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts

944+ ]

945+ XStmtLR _ -> []

946+

947+instance ( ToHie (LHsExpr a)

948+ , ToHie (PScoped (LPat a))

949+ , ToHie (BindContext (LHsBind a))

950+ , ToHie (SigContext (LSig a))

951+ , ToHie (RScoped (HsValBindsLR a a))

952+ , Data (HsLocalBinds a)

953+ ) => ToHie (RScoped (LHsLocalBinds a)) where

954+ toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of

955+ EmptyLocalBinds _ -> []

956+ HsIPBinds _ _ -> []

957+ HsValBinds _ valBinds ->

958+ [ toHie $ RS (combineScopes scope $ mkScope sp)

959+ valBinds

960+ ]

961+ XHsLocalBindsLR _ -> []

962+

963+instance ( ToHie (BindContext (LHsBind a))

964+ , ToHie (SigContext (LSig a))

965+ , ToHie (RScoped (XXValBindsLR a a))

966+ ) => ToHie (RScoped (HsValBindsLR a a)) where

967+ toHie (RS sc v) = concatM $ case v of

968+ ValBinds _ binds sigs ->

969+ [ toHie $ fmap (BC RegularBind sc) binds

970+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs

971+ ]

972+ XValBindsLR x -> [ toHie $ RS sc x ]

973+

974+instance ToHie (RScoped (NHsValBindsLR GhcTc)) where

975+ toHie (RS sc (NValBinds binds sigs)) = concatM $

976+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)

977+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs

978+ ]

979+instance ToHie (RScoped (NHsValBindsLR GhcRn)) where

980+ toHie (RS sc (NValBinds binds sigs)) = concatM $

981+ [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)

982+ , toHie $ fmap (SC (SI BindSig Nothing)) sigs

983+ ]

984+

985+instance ( ToHie (RContext (LHsRecField a arg))

986+ ) => ToHie (RContext (HsRecFields a arg)) where

987+ toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields

988+

989+instance ( ToHie (RFContext (Located label))

990+ , ToHie arg

991+ , HasLoc arg

992+ , Data label

993+ , Data arg

994+ ) => ToHie (RContext (LHsRecField' label arg)) where

995+ toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of

996+ HsRecField label expr _ ->

997+ [ toHie $ RFC c (getRealSpan $ loc expr) label

998+ , toHie expr

999+ ]

1000+

1001+removeDefSrcSpan :: Name -> Name

1002+removeDefSrcSpan n = setNameLoc n noSrcSpan

1003+

1004+instance ToHie (RFContext (LFieldOcc GhcRn)) where

1005+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1006+ FieldOcc name _ ->

1007+ [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)

1008+ ]

1009+ XFieldOcc _ -> []

1010+

1011+instance ToHie (RFContext (LFieldOcc GhcTc)) where

1012+ toHie (RFC c rhs (L nspan f)) = concatM $ case f of

1013+ FieldOcc var _ ->

1014+ let var' = setVarName var (removeDefSrcSpan $ varName var)

1015+ in [ toHie $ C (RecField c rhs) (L nspan var')

1016+ ]

1017+ XFieldOcc _ -> []

1018+

1019+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where

1020+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1021+ Unambiguous name _ ->

1022+ [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name

1023+ ]

1024+ Ambiguous _name _ ->

1025+ [ ]

1026+ XAmbiguousFieldOcc _ -> []

1027+

1028+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where

1029+ toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of

1030+ Unambiguous var _ ->

1031+ let var' = setVarName var (removeDefSrcSpan $ varName var)

1032+ in [ toHie $ C (RecField c rhs) (L nspan var')

1033+ ]

1034+ Ambiguous var _ ->

1035+ let var' = setVarName var (removeDefSrcSpan $ varName var)

1036+ in [ toHie $ C (RecField c rhs) (L nspan var')

1037+ ]

1038+ XAmbiguousFieldOcc _ -> []

1039+

1040+instance ( a ~ GhcPass p

1041+ , ToHie (PScoped (LPat a))

1042+ , ToHie (BindContext (LHsBind a))

1043+ , ToHie (LHsExpr a)

1044+ , ToHie (SigContext (LSig a))

1045+ , ToHie (RScoped (HsValBindsLR a a))

1046+ , Data (StmtLR a a (Located (HsExpr a)))

1047+ , Data (HsLocalBinds a)

1048+ ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where

1049+ toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM

1050+ [ toHie $ PS Nothing sc NoScope pat

1051+ , toHie expr

1052+ ]

1053+ toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM

1054+ [ toHie $ listScopes NoScope stmts

1055+ , toHie $ PS Nothing sc NoScope pat

1056+ ]

1057+ toHie (RS _ (XApplicativeArg _)) = pure []

1058+

1059+instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where

1060+ toHie (PrefixCon args) = toHie args

1061+ toHie (RecCon rec) = toHie rec

1062+ toHie (InfixCon a b) = concatM [ toHie a, toHie b]

1063+

1064+instance ( ToHie (LHsCmd a)

1065+ , Data (HsCmdTop a)

1066+ ) => ToHie (LHsCmdTop a) where

1067+ toHie (L span top) = concatM $ makeNode top span : case top of

1068+ HsCmdTop _ cmd ->

1069+ [ toHie cmd

1070+ ]

1071+ XCmdTop _ -> []

1072+

1073+instance ( a ~ GhcPass p

1074+ , ToHie (PScoped (LPat a))

1075+ , ToHie (BindContext (LHsBind a))

1076+ , ToHie (LHsExpr a)

1077+ , ToHie (MatchGroup a (LHsCmd a))

1078+ , ToHie (SigContext (LSig a))

1079+ , ToHie (RScoped (HsValBindsLR a a))

1080+ , Data (HsCmd a)

1081+ , Data (HsCmdTop a)

1082+ , Data (StmtLR a a (Located (HsCmd a)))

1083+ , Data (HsLocalBinds a)

1084+ , Data (StmtLR a a (Located (HsExpr a)))

1085+ ) => ToHie (LHsCmd (GhcPass p)) where

1086+ toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of

1087+ HsCmdArrApp _ a b _ _ ->

1088+ [ toHie a

1089+ , toHie b

1090+ ]

1091+ HsCmdArrForm _ a _ _ cmdtops ->

1092+ [ toHie a

1093+ , toHie cmdtops

1094+ ]

1095+ HsCmdApp _ a b ->

1096+ [ toHie a

1097+ , toHie b

1098+ ]

1099+ HsCmdLam _ mg ->

1100+ [ toHie mg

1101+ ]

1102+ HsCmdPar _ a ->

1103+ [ toHie a

1104+ ]

1105+ HsCmdCase _ expr alts ->

1106+ [ toHie expr

1107+ , toHie alts

1108+ ]

1109+ HsCmdIf _ _ a b c ->

1110+ [ toHie a

1111+ , toHie b

1112+ , toHie c

1113+ ]

1114+ HsCmdLet _ binds cmd' ->

1115+ [ toHie $ RS (mkLScope cmd') binds

1116+ , toHie cmd'

1117+ ]

1118+ HsCmdDo _ (L ispan stmts) ->

1119+ [ pure $ locOnly ispan

1120+ , toHie $ listScopes NoScope stmts

1121+ ]

1122+ HsCmdWrap _ _ _ -> []

1123+ XCmd _ -> []

1124+

1125+instance ToHie (TyClGroup GhcRn) where

1126+ toHie (TyClGroup _ classes roles instances) = concatM

1127+ [ toHie classes

1128+ , toHie roles

1129+ , toHie instances

1130+ ]

1131+ toHie (XTyClGroup _) = pure []

1132+

1133+instance ToHie (LTyClDecl GhcRn) where

1134+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1135+ FamDecl {tcdFam = fdecl} ->

1136+ [ toHie (L span fdecl)

1137+ ]

1138+ SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->

1139+ [ toHie $ C (Decl SynDec $ getRealSpan span) name

1140+ , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars

1141+ , toHie typ

1142+ ]

1143+ DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->

1144+ [ toHie $ C (Decl DataDec $ getRealSpan span) name

1145+ , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars

1146+ , toHie defn

1147+ ]

1148+ where

1149+ quant_scope = mkLScope $ dd_ctxt defn

1150+ rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc

1151+ sig_sc = maybe NoScope mkLScope $ dd_kindSig defn

1152+ con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn

1153+ deriv_sc = mkLScope $ dd_derivs defn

1154+ ClassDecl { tcdCtxt = context

1155+ , tcdLName = name

1156+ , tcdTyVars = vars

1157+ , tcdFDs = deps

1158+ , tcdSigs = sigs

1159+ , tcdMeths = meths

1160+ , tcdATs = typs

1161+ , tcdATDefs = deftyps

1162+ } ->

1163+ [ toHie $ C (Decl ClassDec $ getRealSpan span) name

1164+ , toHie context

1165+ , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars

1166+ , toHie deps

1167+ , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs

1168+ , toHie $ fmap (BC InstanceBind ModuleScope) meths

1169+ , toHie typs

1170+ , concatMapM (pure . locOnly . getLoc) deftyps

1171+ , toHie $ map (go . unLoc) deftyps

1172+ ]

1173+ where

1174+ context_scope = mkLScope context

1175+ rhs_scope = foldl1' combineScopes $ map mkScope

1176+ [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]

1177+

1178+ go :: TyFamDefltEqn GhcRn

1179+ -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)

1180+ go (FamEqn a var bndrs pat b rhs) =

1181+ FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs

1182+ go (XFamEqn NoExt) = XFamEqn NoExt

1183+ XTyClDecl _ -> []

1184+

1185+instance ToHie (LFamilyDecl GhcRn) where

1186+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1187+ FamilyDecl _ info name vars _ sig inj ->

1188+ [ toHie $ C (Decl FamDec $ getRealSpan span) name

1189+ , toHie $ TS (ResolvedScopes [rhsSpan]) vars

1190+ , toHie info

1191+ , toHie $ RS injSpan sig

1192+ , toHie inj

1193+ ]

1194+ where

1195+ rhsSpan = sigSpan `combineScopes` injSpan

1196+ sigSpan = mkScope $ getLoc sig

1197+ injSpan = maybe NoScope (mkScope . getLoc) inj

1198+ XFamilyDecl _ -> []

1199+

1200+instance ToHie (FamilyInfo GhcRn) where

1201+ toHie (ClosedTypeFamily (Just eqns)) = concatM $

1202+ [ concatMapM (pure . locOnly . getLoc) eqns

1203+ , toHie $ map go eqns

1204+ ]

1205+ where

1206+ go (L l ib) = TS (ResolvedScopes [mkScope l]) ib

1207+ toHie _ = pure []

1208+

1209+instance ToHie (RScoped (LFamilyResultSig GhcRn)) where

1210+ toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of

1211+ NoSig _ ->

1212+ []

1213+ KindSig _ k ->

1214+ [ toHie k

1215+ ]

1216+ TyVarSig _ bndr ->

1217+ [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr

1218+ ]

1219+ XFamilyResultSig _ -> []

1220+

1221+instance ToHie (Located (FunDep (Located Name))) where

1222+ toHie (L span fd@(lhs, rhs)) = concatM $

1223+ [ makeNode fd span

1224+ , toHie $ map (C Use) lhs

1225+ , toHie $ map (C Use) rhs

1226+ ]

1227+

1228+instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs)

1229+ => ToHie (TScoped (FamEqn GhcRn pats rhs)) where

1230+ toHie (TS _ f) = toHie f

1231+

1232+instance ( ToHie pats

1233+ , ToHie rhs

1234+ , HasLoc pats

1235+ , HasLoc rhs

1236+ ) => ToHie (FamEqn GhcRn pats rhs) where

1237+ toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $

1238+ [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var

1239+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1240+ , toHie pats

1241+ , toHie rhs

1242+ ]

1243+ where scope = combineScopes patsScope rhsScope

1244+ patsScope = mkScope (loc pats)

1245+ rhsScope = mkScope (loc rhs)

1246+ toHie (XFamEqn _) = pure []

1247+

1248+instance ToHie (LInjectivityAnn GhcRn) where

1249+ toHie (L span ann) = concatM $ makeNode ann span : case ann of

1250+ InjectivityAnn lhs rhs ->

1251+ [ toHie $ C Use lhs

1252+ , toHie $ map (C Use) rhs

1253+ ]

1254+

1255+instance ToHie (HsDataDefn GhcRn) where

1256+ toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM

1257+ [ toHie ctx

1258+ , toHie mkind

1259+ , toHie cons

1260+ , toHie derivs

1261+ ]

1262+ toHie (XHsDataDefn _) = pure []

1263+

1264+instance ToHie (HsDeriving GhcRn) where

1265+ toHie (L span clauses) = concatM

1266+ [ pure $ locOnly span

1267+ , toHie clauses

1268+ ]

1269+

1270+instance ToHie (LHsDerivingClause GhcRn) where

1271+ toHie (L span cl) = concatM $ makeNode cl span : case cl of

1272+ HsDerivingClause _ strat (L ispan tys) ->

1273+ [ toHie strat

1274+ , pure $ locOnly ispan

1275+ , toHie $ map (TS (ResolvedScopes [])) tys

1276+ ]

1277+ XHsDerivingClause _ -> []

1278+

1279+instance ToHie (Located (DerivStrategy GhcRn)) where

1280+ toHie (L span strat) = concatM $ makeNode strat span : case strat of

1281+ StockStrategy -> []

1282+ AnyclassStrategy -> []

1283+ NewtypeStrategy -> []

1284+ ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]

1285+

1286+instance ToHie (Located OverlapMode) where

1287+ toHie (L span _) = pure $ locOnly span

1288+

1289+instance ToHie (LConDecl GhcRn) where

1290+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1291+ ConDeclGADT { con_names = names, con_qvars = qvars

1292+ , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->

1293+ [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names

1294+ , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars

1295+ , toHie ctx

1296+ , toHie args

1297+ , toHie typ

1298+ ]

1299+ where

1300+ rhsScope = combineScopes argsScope tyScope

1301+ ctxScope = maybe NoScope mkLScope ctx

1302+ argsScope = condecl_scope args

1303+ tyScope = mkLScope typ

1304+ ConDeclH98 { con_name = name, con_ex_tvs = qvars

1305+ , con_mb_cxt = ctx, con_args = dets } ->

1306+ [ toHie $ C (Decl ConDec $ getRealSpan span) name

1307+ , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars

1308+ , toHie ctx

1309+ , toHie dets

1310+ ]

1311+ where

1312+ rhsScope = combineScopes ctxScope argsScope

1313+ ctxScope = maybe NoScope mkLScope ctx

1314+ argsScope = condecl_scope dets

1315+ XConDecl _ -> []

1316+ where condecl_scope args = case args of

1317+ PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs

1318+ InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)

1319+ RecCon x -> mkLScope x

1320+

1321+instance ToHie (Located [LConDeclField GhcRn]) where

1322+ toHie (L span decls) = concatM $

1323+ [ pure $ locOnly span

1324+ , toHie decls

1325+ ]

1326+

1327+instance ( HasLoc thing

1328+ , ToHie (TScoped thing)

1329+ ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where

1330+ toHie (TS sc (HsIB ibrn a)) = concatM $

1331+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn

1332+ , toHie $ TS sc a

1333+ ]

1334+ where span = loc a

1335+ toHie (TS _ (XHsImplicitBndrs _)) = pure []

1336+

1337+instance ( HasLoc thing

1338+ , ToHie (TScoped thing)

1339+ ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where

1340+ toHie (TS sc (HsWC names a)) = concatM $

1341+ [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names

1342+ , toHie $ TS sc a

1343+ ]

1344+ where span = loc a

1345+ toHie (TS _ (XHsWildCardBndrs _)) = pure []

1346+

1347+instance ToHie (SigContext (LSig GhcRn)) where

1348+ toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of

1349+ TypeSig _ names typ ->

1350+ [ toHie $ map (C TyDecl) names

1351+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1352+ ]

1353+ PatSynSig _ names typ ->

1354+ [ toHie $ map (C TyDecl) names

1355+ , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ

1356+ ]

1357+ ClassOpSig _ _ names typ ->

1358+ [ case styp of

1359+ ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names

1360+ _ -> toHie $ map (C $ TyDecl) names

1361+ , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ

1362+ ]

1363+ IdSig _ _ -> []

1364+ FixSig _ fsig ->

1365+ [ toHie $ L sp fsig

1366+ ]

1367+ InlineSig _ name _ ->

1368+ [ toHie $ (C Use) name

1369+ ]

1370+ SpecSig _ name typs _ ->

1371+ [ toHie $ (C Use) name

1372+ , toHie $ map (TS (ResolvedScopes [])) typs

1373+ ]

1374+ SpecInstSig _ _ typ ->

1375+ [ toHie $ TS (ResolvedScopes []) typ

1376+ ]

1377+ MinimalSig _ _ form ->

1378+ [ toHie form

1379+ ]

1380+ SCCFunSig _ _ name mtxt ->

1381+ [ toHie $ (C Use) name

1382+ , pure $ maybe [] (locOnly . getLoc) mtxt

1383+ ]

1384+ CompleteMatchSig _ _ (L ispan names) typ ->

1385+ [ pure $ locOnly ispan

1386+ , toHie $ map (C Use) names

1387+ , toHie $ fmap (C Use) typ

1388+ ]

1389+ XSig _ -> []

1390+

1391+instance ToHie (LHsType GhcRn) where

1392+ toHie x = toHie $ TS (ResolvedScopes []) x

1393+

1394+instance ToHie (TScoped (LHsType GhcRn)) where

1395+ toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of

1396+ HsForAllTy _ bndrs body ->

1397+ [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs

1398+ , toHie body

1399+ ]

1400+ HsQualTy _ ctx body ->

1401+ [ toHie ctx

1402+ , toHie body

1403+ ]

1404+ HsTyVar _ _ var ->

1405+ [ toHie $ C Use var

1406+ ]

1407+ HsAppTy _ a b ->

1408+ [ toHie a

1409+ , toHie b

1410+ ]

1411+ HsAppKindTy _ ty ki ->

1412+ [ toHie ty

1413+ , toHie $ TS (ResolvedScopes []) ki

1414+ ]

1415+ HsFunTy _ a b ->

1416+ [ toHie a

1417+ , toHie b

1418+ ]

1419+ HsListTy _ a ->

1420+ [ toHie a

1421+ ]

1422+ HsTupleTy _ _ tys ->

1423+ [ toHie tys

1424+ ]

1425+ HsSumTy _ tys ->

1426+ [ toHie tys

1427+ ]

1428+ HsOpTy _ a op b ->

1429+ [ toHie a

1430+ , toHie $ C Use op

1431+ , toHie b

1432+ ]

1433+ HsParTy _ a ->

1434+ [ toHie a

1435+ ]

1436+ HsIParamTy _ ip ty ->

1437+ [ toHie ip

1438+ , toHie ty

1439+ ]

1440+ HsKindSig _ a b ->

1441+ [ toHie a

1442+ , toHie b

1443+ ]

1444+ HsSpliceTy _ a ->

1445+ [ toHie $ L span a

1446+ ]

1447+ HsDocTy _ a _ ->

1448+ [ toHie a

1449+ ]

1450+ HsBangTy _ _ ty ->

1451+ [ toHie ty

1452+ ]

1453+ HsRecTy _ fields ->

1454+ [ toHie fields

1455+ ]

1456+ HsExplicitListTy _ _ tys ->

1457+ [ toHie tys

1458+ ]

1459+ HsExplicitTupleTy _ tys ->

1460+ [ toHie tys

1461+ ]

1462+ HsTyLit _ _ -> []

1463+ HsWildCardTy _ -> []

1464+ HsStarTy _ _ -> []

1465+ XHsType _ -> []

1466+

1467+instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where

1468+ toHie (HsValArg tm) = toHie tm

1469+ toHie (HsTypeArg _ ty) = toHie ty

1470+ toHie (HsArgPar sp) = pure $ locOnly sp

1471+

1472+instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where

1473+ toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1474+ UserTyVar _ var ->

1475+ [ toHie $ C (TyVarBind sc tsc) var

1476+ ]

1477+ KindedTyVar _ var kind ->

1478+ [ toHie $ C (TyVarBind sc tsc) var

1479+ , toHie kind

1480+ ]

1481+ XTyVarBndr _ -> []

1482+

1483+instance ToHie (TScoped (LHsQTyVars GhcRn)) where

1484+ toHie (TS sc (HsQTvs (HsQTvsRn implicits _) vars)) = concatM $

1485+ [ pure $ bindingsOnly bindings

1486+ , toHie $ tvScopes sc NoScope vars

1487+ ]

1488+ where

1489+ varLoc = loc vars

1490+ bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits

1491+ toHie (TS _ (XLHsQTyVars _)) = pure []

1492+

1493+instance ToHie (LHsContext GhcRn) where

1494+ toHie (L span tys) = concatM $

1495+ [ pure $ locOnly span

1496+ , toHie tys

1497+ ]

1498+

1499+instance ToHie (LConDeclField GhcRn) where

1500+ toHie (L span field) = concatM $ makeNode field span : case field of

1501+ ConDeclField _ fields typ _ ->

1502+ [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields

1503+ , toHie typ

1504+ ]

1505+ XConDeclField _ -> []

1506+

1507+instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where

1508+ toHie (From expr) = toHie expr

1509+ toHie (FromThen a b) = concatM $

1510+ [ toHie a

1511+ , toHie b

1512+ ]

1513+ toHie (FromTo a b) = concatM $

1514+ [ toHie a

1515+ , toHie b

1516+ ]

1517+ toHie (FromThenTo a b c) = concatM $

1518+ [ toHie a

1519+ , toHie b

1520+ , toHie c

1521+ ]

1522+

1523+instance ToHie (LSpliceDecl GhcRn) where

1524+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1525+ SpliceDecl _ splice _ ->

1526+ [ toHie splice

1527+ ]

1528+ XSpliceDecl _ -> []

1529+

1530+instance ToHie (HsBracket a) where

1531+ toHie _ = pure []

1532+

1533+instance ToHie PendingRnSplice where

1534+ toHie _ = pure []

1535+

1536+instance ToHie PendingTcSplice where

1537+ toHie _ = pure []

1538+

1539+instance ToHie (LBooleanFormula (Located Name)) where

1540+ toHie (L span form) = concatM $ makeNode form span : case form of

1541+ Var a ->

1542+ [ toHie $ C Use a

1543+ ]

1544+ And forms ->

1545+ [ toHie forms

1546+ ]

1547+ Or forms ->

1548+ [ toHie forms

1549+ ]

1550+ Parens f ->

1551+ [ toHie f

1552+ ]

1553+

1554+instance ToHie (Located HsIPName) where

1555+ toHie (L span e) = makeNode e span

1556+

1557+instance ( ToHie (LHsExpr a)

1558+ , Data (HsSplice a)

1559+ ) => ToHie (Located (HsSplice a)) where

1560+ toHie (L span sp) = concatM $ makeNode sp span : case sp of

1561+ HsTypedSplice _ _ _ expr ->

1562+ [ toHie expr

1563+ ]

1564+ HsUntypedSplice _ _ _ expr ->

1565+ [ toHie expr

1566+ ]

1567+ HsQuasiQuote _ _ _ ispan _ ->

1568+ [ pure $ locOnly ispan

1569+ ]

1570+ HsSpliced _ _ _ ->

1571+ []

1572+ HsSplicedT _ ->

1573+ []

1574+ XSplice _ -> []

1575+

1576+instance ToHie (LRoleAnnotDecl GhcRn) where

1577+ toHie (L span annot) = concatM $ makeNode annot span : case annot of

1578+ RoleAnnotDecl _ var roles ->

1579+ [ toHie $ C Use var

1580+ , concatMapM (pure . locOnly . getLoc) roles

1581+ ]

1582+ XRoleAnnotDecl _ -> []

1583+

1584+instance ToHie (LInstDecl GhcRn) where

1585+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1586+ ClsInstD _ d ->

1587+ [ toHie $ L span d

1588+ ]

1589+ DataFamInstD _ d ->

1590+ [ toHie $ L span d

1591+ ]

1592+ TyFamInstD _ d ->

1593+ [ toHie $ L span d

1594+ ]

1595+ XInstDecl _ -> []

1596+

1597+instance ToHie (LClsInstDecl GhcRn) where

1598+ toHie (L span decl) = concatM

1599+ [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl

1600+ , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl

1601+ , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl

1602+ , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl

1603+ , toHie $ cid_tyfam_insts decl

1604+ , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl

1605+ , toHie $ cid_datafam_insts decl

1606+ , toHie $ cid_overlap_mode decl

1607+ ]

1608+

1609+instance ToHie (LDataFamInstDecl GhcRn) where

1610+ toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1611+

1612+instance ToHie (LTyFamInstDecl GhcRn) where

1613+ toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d

1614+

1615+instance ToHie (Context a)

1616+ => ToHie (PatSynFieldContext (RecordPatSynField a)) where

1617+ toHie (PSC sp (RecordPatSynField a b)) = concatM $

1618+ [ toHie $ C (RecField RecFieldDecl sp) a

1619+ , toHie $ C Use b

1620+ ]

1621+

1622+instance ToHie (LDerivDecl GhcRn) where

1623+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1624+ DerivDecl _ typ strat overlap ->

1625+ [ toHie $ TS (ResolvedScopes []) typ

1626+ , toHie strat

1627+ , toHie overlap

1628+ ]

1629+ XDerivDecl _ -> []

1630+

1631+instance ToHie (LFixitySig GhcRn) where

1632+ toHie (L span sig) = concatM $ makeNode sig span : case sig of

1633+ FixitySig _ vars _ ->

1634+ [ toHie $ map (C Use) vars

1635+ ]

1636+ XFixitySig _ -> []

1637+

1638+instance ToHie (LDefaultDecl GhcRn) where

1639+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1640+ DefaultDecl _ typs ->

1641+ [ toHie typs

1642+ ]

1643+ XDefaultDecl _ -> []

1644+

1645+instance ToHie (LForeignDecl GhcRn) where

1646+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1647+ ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->

1648+ [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name

1649+ , toHie $ TS (ResolvedScopes []) sig

1650+ , toHie fi

1651+ ]

1652+ ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->

1653+ [ toHie $ C Use name

1654+ , toHie $ TS (ResolvedScopes []) sig

1655+ , toHie fe

1656+ ]

1657+ XForeignDecl _ -> []

1658+

1659+instance ToHie ForeignImport where

1660+ toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $

1661+ [ locOnly a

1662+ , locOnly b

1663+ , locOnly c

1664+ ]

1665+

1666+instance ToHie ForeignExport where

1667+ toHie (CExport (L a _) (L b _)) = pure $ concat $

1668+ [ locOnly a

1669+ , locOnly b

1670+ ]

1671+

1672+instance ToHie (LWarnDecls GhcRn) where

1673+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1674+ Warnings _ _ warnings ->

1675+ [ toHie warnings

1676+ ]

1677+ XWarnDecls _ -> []

1678+

1679+instance ToHie (LWarnDecl GhcRn) where

1680+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1681+ Warning _ vars _ ->

1682+ [ toHie $ map (C Use) vars

1683+ ]

1684+ XWarnDecl _ -> []

1685+

1686+instance ToHie (LAnnDecl GhcRn) where

1687+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1688+ HsAnnotation _ _ prov expr ->

1689+ [ toHie prov

1690+ , toHie expr

1691+ ]

1692+ XAnnDecl _ -> []

1693+

1694+instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where

1695+ toHie (ValueAnnProvenance a) = toHie $ C Use a

1696+ toHie (TypeAnnProvenance a) = toHie $ C Use a

1697+ toHie ModuleAnnProvenance = pure []

1698+

1699+instance ToHie (LRuleDecls GhcRn) where

1700+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1701+ HsRules _ _ rules ->

1702+ [ toHie rules

1703+ ]

1704+ XRuleDecls _ -> []

1705+

1706+instance ToHie (LRuleDecl GhcRn) where

1707+ toHie (L _ (XRuleDecl _)) = pure []

1708+ toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM

1709+ [ makeNode r span

1710+ , pure $ locOnly $ getLoc rname

1711+ , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs

1712+ , toHie $ map (RS $ mkScope span) bndrs

1713+ , toHie exprA

1714+ , toHie exprB

1715+ ]

1716+ where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc

1717+ bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)

1718+ exprA_sc = mkLScope exprA

1719+ exprB_sc = mkLScope exprB

1720+

1721+instance ToHie (RScoped (LRuleBndr GhcRn)) where

1722+ toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of

1723+ RuleBndr _ var ->

1724+ [ toHie $ C (ValBind RegularBind sc Nothing) var

1725+ ]

1726+ RuleBndrSig _ var typ ->

1727+ [ toHie $ C (ValBind RegularBind sc Nothing) var

1728+ , toHie $ TS (ResolvedScopes [sc]) typ

1729+ ]

1730+ XRuleBndr _ -> []

1731+

1732+instance ToHie (LImportDecl GhcRn) where

1733+ toHie (L span decl) = concatM $ makeNode decl span : case decl of

1734+ ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->

1735+ [ toHie $ IEC Import name

1736+ , toHie $ fmap (IEC ImportAs) as

1737+ , maybe (pure []) goIE hidden

1738+ ]

1739+ XImportDecl _ -> []

1740+ where

1741+ goIE (hiding, (L sp liens)) = concatM $

1742+ [ pure $ locOnly sp

1743+ , toHie $ map (IEC c) liens

1744+ ]

1745+ where

1746+ c = if hiding then ImportHiding else Import

1747+

1748+instance ToHie (IEContext (LIE GhcRn)) where

1749+ toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of

1750+ IEVar _ n ->

1751+ [ toHie $ IEC c n

1752+ ]

1753+ IEThingAbs _ n ->

1754+ [ toHie $ IEC c n

1755+ ]

1756+ IEThingAll _ n ->

1757+ [ toHie $ IEC c n

1758+ ]

1759+ IEThingWith _ n _ ns flds ->

1760+ [ toHie $ IEC c n

1761+ , toHie $ map (IEC c) ns

1762+ , toHie $ map (IEC c) flds

1763+ ]

1764+ IEModuleContents _ n ->

1765+ [ toHie $ IEC c n

1766+ ]

1767+ IEGroup _ _ _ -> []

1768+ IEDoc _ _ -> []

1769+ IEDocNamed _ _ -> []

1770+ XIE _ -> []

1771+

1772+instance ToHie (IEContext (LIEWrappedName Name)) where

1773+ toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of

1774+ IEName n ->

1775+ [ toHie $ C (IEThing c) n

1776+ ]

1777+ IEPattern p ->

1778+ [ toHie $ C (IEThing c) p

1779+ ]

1780+ IEType n ->

1781+ [ toHie $ C (IEThing c) n

1782+ ]

1783+

1784+instance ToHie (IEContext (Located (FieldLbl Name))) where

1785+ toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of

1786+ FieldLabel _ _ n ->

1787+ [ toHie $ C (IEThing c) $ L span n

1788+ ]

1789+

src/Development/IDE/Compat.hsnew file+19

@@ -0,0 +1,19 @@

1+{-# LANGUAGE CPP #-}

2+module Development.IDE.Compat

3+ (

4+ getProcessID

5+ ) where

7+#ifdef mingw32_HOST_OS

9+import qualified System.Win32.Process as P (getCurrentProcessId)

10+getProcessID :: IO Int

11+getProcessID = fromIntegral <$> P.getCurrentProcessId

12+

13+#else

14+

15+import qualified System.Posix.Process as P (getProcessID)

16+getProcessID :: IO Int

17+getProcessID = fromIntegral <$> P.getProcessID

18+

19+#endif

src/Development/IDE/Core/Compile.hs+296−97

@@ -9,6 +9,7 @@

99-- Given a list of paths to find libraries, and a file to compile, produce a list of 'CoreModule' values.

1010module Development.IDE.Core.Compile

1111 ( TcModuleResult(..)

12+ , RunSimplifier(..)

1213 , compileModule

1314 , parseModule

1415 , typecheckModule

@@ -16,6 +17,13 @@ module Development.IDE.Core.Compile

1617 , addRelativeImport

1718 , mkTcModuleResult

1819 , generateByteCode

20+ , generateAndWriteHieFile

21+ , generateAndWriteHiFile

22+ , getModSummaryFromImports

23+ , loadHieFile

24+ , loadInterface

25+ , loadDepModule

26+ , loadModuleHome

1927 ) where

2028

2129import Development.IDE.Core.RuleTypes

@@ -29,6 +37,7 @@ import Development.IDE.GHC.Util

2937import qualified GHC.LanguageExtensions.Type as GHC

3038import Development.IDE.Types.Options

3139import Development.IDE.Types.Location

40+import Outputable

3241

3342#if MIN_GHC_API_VERSION(8,6,0)

3443import DynamicLoading (initializePlugins)

@@ -37,43 +46,59 @@ import DynamicLoading (initializePlugins)

3746import GHC hiding (parseModule, typecheckModule)

3847import qualified Parser

3948import Lexer

49+#if MIN_GHC_API_VERSION(8,10,0)

50+#else

4051import ErrUtils

52+#endif

4153

42−import qualified GHC

54+import Finder

55+import qualified Development.IDE.GHC.Compat as GHC

56+import qualified Development.IDE.GHC.Compat as Compat

4357import GhcMonad

4458import GhcPlugins as GHC hiding (fst3, (<>))

4559import qualified HeaderInfo as Hdr

46−import HscMain (hscInteractive)

60+import HscMain (hscInteractive, hscSimplify)

61+import LoadIface (readIface)

62+import qualified Maybes

4763import MkIface

64+import NameCache

4865import StringBuffer as SB

66+import TcRnMonad (initIfaceLoad, tcg_th_coreplugins)

67+import TcIface (typecheckIface)

4968import TidyPgm

5069

70+import Control.Exception.Safe

5171import Control.Monad.Extra

5272import Control.Monad.Except

5373import Control.Monad.Trans.Except

54−import Data.Function

55−import Data.Ord

74+import Data.Bifunctor (first, second)

5675import qualified Data.Text as T

5776import Data.IORef

5877import Data.List.Extra

5978import Data.Maybe

60−import Data.Tuple.Extra

6179import qualified Data.Map.Strict as Map

6280import 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)

6387

6488

6589-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.

6690parseModule

6791 :: IdeOptions

6892 -> HscEnv

93+ -> [PackageName]

6994 -> FilePath

7095 -> Maybe SB.StringBuffer

7196 -> IO (IdeResult (StringBuffer, ParsedModule))

72−parseModule IdeOptions{..} env filename mbContents =

97+parseModule IdeOptions{..} env comp_pkgs filename mbContents =

7398 fmap (either (, Nothing) id) $

74− runGhcEnv env $ runExceptT $ do

99+ evalGhcEnv env $ runExceptT $ do

75100 (contents, dflags) <- preprocessor filename mbContents

76− (diag, modu) <- parseFileContents optPreprocessor dflags filename contents

101+ (diag, modu) <- parseFileContents optPreprocessor dflags comp_pkgs filename contents

77102 return (diag, Just (contents, modu))

78103

79104

@@ -85,34 +110,39 @@ computePackageDeps

85110computePackageDeps env pkg = do

86111 let dflags = hsc_dflags env

87112 case lookupInstalledPackage dflags pkg of

88− Nothing -> return $ Left [ideErrorText (toNormalizedFilePath noFilePath) $

113+ Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $

89114 T.pack $ "unknown package: " ++ show pkg]

90115 Just pkgInfo -> return $ Right $ depends pkgInfo

91116

92−

93−-- | Typecheck a single module using the supplied dependencies and packages.

94−typecheckModule

95− :: IdeDefer

96− -> HscEnv

97− -> [TcModuleResult]

98− -> ParsedModule

99− -> IO (IdeResult TcModuleResult)

100−typecheckModule (IdeDefer defer) packageState deps pm =

101− let demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id

102− in

103− fmap (either (, Nothing) (second Just)) $

104− runGhcEnv packageState $

105− catchSrcErrors "typecheck" $ do

106− setupEnv deps

107− let modSummary = pm_mod_summary pm

108− dflags = ms_hspp_opts modSummary

109− modSummary' <- initPlugins modSummary

110− (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->

111− GHC.typecheckModule $ enableTopLevelWarnings

112− $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}

113− tcm2 <- mkTcModuleResult tcm

114− let errorPipeline = unDefer . hideDiag dflags

115− return (map errorPipeline warnings, tcm2)

117+typecheckModule :: IdeDefer

118+ -> HscEnv

119+ -> [(ModSummary, (ModIface, Maybe Linkable))]

120+ -> ParsedModule

121+ -> IO (IdeResult (HscEnv, TcModuleResult))

122+typecheckModule (IdeDefer defer) hsc depsIn pm = do

123+ fmap (either (, Nothing) (second Just . sequence) . sequence) $

124+ runGhcEnv hsc $

125+ catchSrcErrors "typecheck" $ do

126+ -- Currently GetDependencies returns things in topological order so A comes before B if A imports B.

127+ -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces.

128+ -- Long-term we might just want to change the order returned by GetDependencies

129+ let deps = reverse depsIn

130+

131+ setupFinderCache (map fst deps)

132+

133+ let modSummary = pm_mod_summary pm

134+ dflags = ms_hspp_opts modSummary

135+

136+ mapM_ (uncurry loadDepModule . snd) deps

137+ modSummary' <- initPlugins modSummary

138+ (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->

139+ GHC.typecheckModule $ enableTopLevelWarnings

140+ $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}

141+ tcm2 <- mkTcModuleResult tcm

142+ let errorPipeline = unDefer . hideDiag dflags

143+ return (map errorPipeline warnings, tcm2)

144+ where

145+ demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id

116146

117147initPlugins :: GhcMonad m => ModSummary -> m ModSummary

118148initPlugins modSummary = do

@@ -124,18 +154,25 @@ initPlugins modSummary = do

124154 return modSummary

125155#endif

126156

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+

127163-- | Compile a single type-checked module to a 'CoreModule' value, or

128164-- provide errors.

129165compileModule

130− :: HscEnv

131− -> [TcModuleResult]

166+ :: RunSimplifier

167+ -> HscEnv

168+ -> [(ModSummary, HomeModInfo)]

132169 -> TcModuleResult

133170 -> IO (IdeResult (SafeHaskellMode, CgGuts, ModDetails))

134−compileModule packageState deps tmr =

171+compileModule (RunSimplifier simplify) packageState deps tmr =

135172 fmap (either (, Nothing) (second Just)) $

136− runGhcEnv packageState $

173+ evalGhcEnv packageState $

137174 catchSrcErrors "compile" $ do

138− setupEnv (deps ++ [tmr])

175+ setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])

139176

140177 let tm = tmrModule tmr

141178 session <- getSession

@@ -144,20 +181,30 @@ compileModule packageState deps tmr =

144181 let pm' = pm{pm_mod_summary = tweak $ pm_mod_summary pm}

145182 let tm' = tm{tm_parsed_module = pm'}

146183 GHC.dm_core_module <$> GHC.desugarModule tm'

147−

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

148191 -- give variables unique OccNames

149− (guts, details) <- liftIO $ tidyProgram session desugar

192+ (guts, details) <- liftIO $ tidyProgram session desugared_guts

150193 return (map snd warnings, (mg_safe_haskell desugar, guts, details))

151194

152−generateByteCode :: HscEnv -> [TcModuleResult] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable)

195+generateByteCode :: HscEnv -> [(ModSummary, HomeModInfo)] -> TcModuleResult -> CgGuts -> IO (IdeResult Linkable)

153196generateByteCode hscEnv deps tmr guts =

154197 fmap (either (, Nothing) (second Just)) $

155− runGhcEnv hscEnv $

198+ evalGhcEnv hscEnv $

156199 catchSrcErrors "bytecode" $ do

157− setupEnv (deps ++ [tmr])

200+ setupEnv (deps ++ [(tmrModSummary tmr, tmrModInfo tmr)])

158201 session <- getSession

159202 (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \tweak ->

160− liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)

203+#if MIN_GHC_API_VERSION(8,10,0)

204+ liftIO $ hscInteractive session guts (GHC.ms_location $ tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)

205+#else

206+ liftIO $ hscInteractive session guts (tweak $ GHC.pm_mod_summary $ GHC.tm_parsed_module $ tmrModule tmr)

207+#endif

161208 let summary = pm_mod_summary $ tm_parsed_module $ tmrModule tmr

162209 let unlinked = BCOs bytecode sptEntries

163210 let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]

@@ -179,9 +226,10 @@ demoteTypeErrorsToWarnings =

179226enableTopLevelWarnings :: ParsedModule -> ParsedModule

180227enableTopLevelWarnings =

181228 (update_pm_mod_summary . update_hspp_opts)

182− (`wopt_set` Opt_WarnMissingSignatures)

229+ ((`wopt_set` Opt_WarnMissingPatternSynonymSignatures) .

230+ (`wopt_set` Opt_WarnMissingSignatures))

183231 -- the line below would show also warnings for let bindings without signature

184− -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures))

232+ -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures)))

185233

186234update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary

187235update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}

@@ -205,9 +253,9 @@ upgradeWarningToError (nfp, sh, fd) =

205253hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)

206254hideDiag originalFlags (Reason warning, (nfp, _sh, fd))

207255 | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))

208−hideDiag _originalFlags t = t

256+hideDiag _originalFlags t = t

209257

210−addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags

258+addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags

211259addRelativeImport fp modu dflags = dflags

212260 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}

213261

@@ -217,25 +265,81 @@ mkTcModuleResult

217265 -> m TcModuleResult

218266mkTcModuleResult tcm = do

219267 session <- getSession

220− (iface, _) <- liftIO $ mkIfaceTc session Nothing Sf_None details tcGblEnv

268+ let sf = modInfoSafe (tm_checked_module_info tcm)

269+#if MIN_GHC_API_VERSION(8,10,0)

270+ iface <- liftIO $ mkIfaceTc session sf details tcGblEnv

271+#else

272+ (iface, _) <- liftIO $ mkIfaceTc session Nothing sf details tcGblEnv

273+#endif

221274 let mod_info = HomeModInfo iface details Nothing

222275 return $ TcModuleResult tcm mod_info

223276 where

224277 (tcGblEnv, details) = tm_internals_ tcm

225278

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+

226325-- | Setup the environment that GHC needs according to our

227326-- best understanding (!)

228−setupEnv :: GhcMonad m => [TcModuleResult] -> m ()

229−setupEnv tmsIn = do

230− -- if both a .hs-boot file and a .hs file appear here, we want to make sure that the .hs file

231− -- takes precedence, so put the .hs-boot file earlier in the list

232− let isSourceFile = (==HsBootFile) . ms_hsc_src . pm_mod_summary . tm_parsed_module . tmrModule

233− tms = sortBy (compare `on` Down . isSourceFile) tmsIn

327+--

328+-- This involves setting up the finder cache and populating the

329+-- HPT.

330+setupEnv :: GhcMonad m => [(ModSummary, HomeModInfo)] -> m ()

331+setupEnv tms = do

332+ setupFinderCache (map fst tms)

333+ -- load dependent modules, which must be in topological order.

334+ modifySession $ \e ->

335+ foldl' (\e (_, hmi) -> loadModuleHome hmi e) e tms

234336

337+-- | Initialise the finder cache, dependencies should be topologically

338+-- sorted.

339+setupFinderCache :: GhcMonad m => [ModSummary] -> m ()

340+setupFinderCache mss = do

235341 session <- getSession

236342

237− let mss = map (pm_mod_summary . tm_parsed_module . tmrModule) tms

238−

239343 -- set the target and module graph in the session

240344 let graph = mkModuleGraph mss

241345 setSession session { hsc_mod_graph = graph }

@@ -254,26 +358,40 @@ setupEnv tmsIn = do

254358 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache

255359 modifySession $ \s -> s { hsc_FC = newFinderCacheVar }

256360

257− -- load dependent modules, which must be in topological order.

258− mapM_ loadModuleHome tms

259−

260361

261362-- | Load a module, quickly. Input doesn't need to be desugared.

262363-- A module must be loaded before dependent modules can be typechecked.

263364-- This variant of loadModuleHome will *never* cause recompilation, it just

264365-- 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.

265370loadModuleHome

266− :: (GhcMonad m)

267− => TcModuleResult

268− -> m ()

269−loadModuleHome tmr = modifySession $ \e ->

270− e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }

271− where

272− ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr

273− mod_info = tmrModInfo tmr

274− mod = ms_mod_name ms

275−

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

276389

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'

277395

278396-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's

279397-- name and its imports.

@@ -294,30 +412,18 @@ getImportsParsed dflags (L loc parsed) = do

294412 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"

295413 ])

296414

297−

298415-- | Produce a module summary from a StringBuffer.

299416getModSummaryFromBuffer

300417 :: GhcMonad m

301418 => FilePath

302− -> SB.StringBuffer

303419 -> DynFlags

304420 -> GHC.ParsedSource

305421 -> ExceptT [FileDiagnostic] m ModSummary

306−getModSummaryFromBuffer fp contents dflags parsed = do

422+getModSummaryFromBuffer fp dflags parsed = do

307423 (modName, imports) <- liftEither $ getImportsParsed dflags parsed

308424

309− let modLoc = ModLocation

310− { ml_hs_file = Just fp

311− , ml_hi_file = derivedFile "hi"

312− , ml_obj_file = derivedFile "o"

313−#if MIN_GHC_API_VERSION(8,8,0)

314− , ml_hie_file = derivedFile "hie"

315−#endif

316− -- This does not consider the dflags configuration

317− -- (-osuf and -hisuf, object and hi dir.s).

318− -- However, we anyway don't want to generate them.

319− }

320− InstalledUnitId unitId = thisInstalledUnitId dflags

425+ modLoc <- liftIO $ mkHomeModLocation dflags modName fp

426+ let InstalledUnitId unitId = thisInstalledUnitId dflags

321427 return $ ModSummary

322428 { ms_mod = mkModule (fsToUnitId unitId) modName

323429 , ms_location = modLoc

@@ -329,7 +435,7 @@ getModSummaryFromBuffer fp contents dflags parsed = do

329435 , ms_textual_imps = [imp | (False, imp) <- imports]

330436 , ms_hspp_file = fp

331437 , ms_hspp_opts = dflags

332− , ms_hspp_buf = Just contents

438+ , ms_hspp_buf = Nothing

333439

334440 -- defaults:

335441 , ms_hsc_src = sourceType

@@ -342,27 +448,71 @@ getModSummaryFromBuffer fp contents dflags parsed = do

342448 , ms_parsed_mod = Nothing

343449 }

344450 where

345− (sourceType, derivedFile) =

346− let (stem, ext) = splitExtension fp in

347− if "-boot" `isSuffixOf` ext

348− then (HsBootFile, \newExt -> stem <.> newExt ++ "-boot")

349− else (HsSrcFile , \newExt -> stem <.> newExt)

350−

351−

352−-- | Given a buffer, flags, file path and module summary, produce a

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

353498-- parsed module (or errors) and any parse warnings. Does not run any preprocessors

354499parseFileContents

355500 :: GhcMonad m

356501 => (GHC.ParsedSource -> IdePreprocessedSource)

357502 -> DynFlags -- ^ flags to use

503+ -> [PackageName] -- ^ The package imports to ignore

358504 -> FilePath -- ^ the filename (for source locations)

359505 -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)

360506 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)

361−parseFileContents customPreprocessor dflags filename contents = do

507+parseFileContents customPreprocessor dflags comp_pkgs filename contents = do

362508 let loc = mkRealSrcLoc (mkFastString filename) 1 1

363509 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

364513 PFailed _ locErr msgErr ->

365514 throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr

515+#endif

366516 POk pst rdr_module ->

367517 let hpm_annotations =

368518 (Map.fromListWith (++) $ annotations pst,

@@ -386,14 +536,63 @@ parseFileContents customPreprocessor dflags filename contents = do

386536 -- Ok, we got here. It's safe to continue.

387537 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

388538 unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs

539+ let parsed' = removePackageImports comp_pkgs parsed

389540 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

390− ms <- getModSummaryFromBuffer filename contents dflags parsed

541+ ms <- getModSummaryFromBuffer filename dflags parsed'

391542 let pm =

392543 ParsedModule {

393544 pm_mod_summary = ms

394− , pm_parsed_source = parsed

545+ , pm_parsed_source = parsed'

395546 , pm_extra_src_files=[] -- src imports not allowed

396547 , pm_annotations = hpm_annotations

397548 }

398549 warnings = diagFromErrMsgs "parser" dflags warns

399550 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+15−9

@@ -3,8 +3,9 @@

44module Development.IDE.Core.Debouncer

55 ( Debouncer

6− , newDebouncer

76 , registerEvent

7+ , newAsyncDebouncer

8+ , noopDebouncer

89 ) where

910

1011import Control.Concurrent.Extra

@@ -22,13 +23,14 @@ import System.Time.Extra

2223-- by delaying each event for a given time. If another event

2324-- is registered for the same key within that timeframe,

2425-- only the new event will fire.

25−newtype Debouncer k = Debouncer (Var (HashMap k (Async ())))

26+--

27+-- We abstract over the debouncer used so we an use a proper debouncer in the IDE but disable

28+-- debouncing in the DAML CLI compiler.

29+newtype Debouncer k = Debouncer { registerEvent :: Seconds -> k -> IO () -> IO () }

2630

27−-- | Create a new empty debouncer.

28−newDebouncer :: IO (Debouncer k)

29−newDebouncer = do

30− m <- newVar Map.empty

31− pure $ Debouncer m

31+-- | Debouncer used in the IDE that delays events as expected.

32+newAsyncDebouncer :: (Eq k, Hashable k) => IO (Debouncer k)

33+newAsyncDebouncer = Debouncer . asyncRegisterEvent <$> newVar Map.empty

3234

3335-- | Register an event that will fire after the given delay if no other event

3436-- for the same key gets registered until then.

@@ -36,11 +38,15 @@ newDebouncer = do

3638-- If there is a pending event for the same key, the pending event will be killed.

3739-- Events are run unmasked so it is up to the user of `registerEvent`

3840-- to mask if required.

39−registerEvent :: (Eq k, Hashable k) => Debouncer k -> Seconds -> k -> IO () -> IO ()

40−registerEvent (Debouncer d) delay k fire = modifyVar_ d $ \m -> mask_ $ do

41+asyncRegisterEvent :: (Eq k, Hashable k) => Var (HashMap k (Async ())) -> Seconds -> k -> IO () -> IO ()

42+asyncRegisterEvent d delay k fire = modifyVar_ d $ \m -> mask_ $ do

4143 whenJust (Map.lookup k m) cancel

4244 a <- asyncWithUnmask $ \unmask -> unmask $ do

4345 sleep delay

4446 fire

4547 modifyVar_ d (pure . Map.delete k)

4648 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.hs+40−46

@@ -14,13 +14,15 @@ import Control.Monad.Extra

1414import qualified Data.Aeson as A

1515import Data.Binary

1616import qualified Data.ByteString as BS

17−import Data.Map.Strict ( Map )

18−import qualified Data.Map.Strict as Map

17+import Data.HashMap.Strict (HashMap)

18+import qualified Data.HashMap.Strict as HashMap

1919import Data.Maybe

2020import qualified Data.Text as T

2121import Development.IDE.Core.FileStore

22+import Development.IDE.Core.IdeConfiguration

2223import Development.IDE.Core.Shake

2324import Development.IDE.Types.Location

25+import Development.IDE.Types.Logger

2426import Development.Shake

2527import Development.Shake.Classes

2628import GHC.Generics

@@ -30,7 +32,7 @@ import Language.Haskell.LSP.Types.Capabilities

3032import qualified System.Directory as Dir

3133

3234-- | A map for tracking the file existence

33−type FileExistsMap = (Map NormalizedFilePath Bool)

35+type FileExistsMap = (HashMap NormalizedFilePath Bool)

3436

3537-- | A wrapper around a mutable 'FileExistsMap'

3638newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap)

@@ -53,12 +55,12 @@ modifyFileExistsAction f = do

5355modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO ()

5456modifyFileExists state changes = do

5557 FileExistsMapVar var <- getIdeGlobalState state

56− changesMap <- evaluate $ Map.fromList changes

58+ changesMap <- evaluate $ HashMap.fromList changes

5759

5860 -- Masked to ensure that the previous values are flushed together with the map update

5961 mask $ \_ -> do

6062 -- update the map

61− modifyVar_ var $ evaluate . Map.union changesMap

63+ modifyVar_ var $ evaluate . HashMap.union changesMap

6264 -- flush previous values

6365 mapM_ (deleteValue state GetFileExists . fst) changes

6466

@@ -89,20 +91,34 @@ getFileExists fp = use_ GetFileExists fp

8991-- Provides a fast implementation if client supports dynamic watched files.

9092-- Creates a global state as a side effect in that case.

9193fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules ()

92−fileExistsRules getLspId ClientCapabilities{_workspace}

93− | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace

94− , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles

95− , Just True <- _dynamicRegistration

96− = fileExistsRulesFast getLspId

97− | otherwise = fileExistsRulesSlow

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

98108

99109-- Requires an lsp client that provides WatchedFiles notifications.

100110fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()

101−fileExistsRulesFast getLspId vfs = do

102− addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])

111+fileExistsRulesFast getLspId vfs =

103112 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

104120 fileExistsMap <- getFileExistsMapUntracked

105− let mbFilesWatched = Map.lookup file fileExistsMap

121+ let mbFilesWatched = HashMap.lookup file fileExistsMap

106122 case mbFilesWatched of

107123 Just fv -> pure (summarizeExists fv, ([], Just fv))

108124 Nothing -> do

@@ -113,7 +129,7 @@ fileExistsRulesFast getLspId vfs = do

113129 -- taking the FileExistsMap lock to prevent race conditions

114130 -- that would lead to multiple listeners for the same path

115131 modifyFileExistsAction $ \x -> do

116− case Map.insertLookupWithKey (\_ x _ -> x) file exist x of

132+ case HashMap.alterF (,Just exist) file x of

117133 (Nothing, x') -> do

118134 -- if the listener addition fails, we never recover. This is a bug.

119135 addListener eventer file

@@ -134,9 +150,10 @@ fileExistsRulesFast getLspId vfs = do

134150 WorkspaceDidChangeWatchedFiles

135151 (Just (A.toJSON regOptions))

136152 regOptions =

137− DidChangeWatchedFilesRegistrationOptions { watchers = List [watcher] }

138− watcher = FileSystemWatcher { globPattern = fromNormalizedFilePath fp

139− , kind = Just 5 -- Create and Delete events only

153+ DidChangeWatchedFilesRegistrationOptions { _watchers = List [watcher] }

154+ watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True}

155+ watcher = FileSystemWatcher { _globPattern = fromNormalizedFilePath fp

156+ , _kind = Just watchKind

140157 }

141158

142159 eventer $ ReqRegisterCapability req

@@ -145,8 +162,11 @@ summarizeExists :: Bool -> Maybe BS.ByteString

145162summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty

146163

147164fileExistsRulesSlow:: VFSHandle -> Rules ()

148−fileExistsRulesSlow vfs = do

149− defineEarlyCutoff $ \GetFileExists file -> do

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

150170 alwaysRerun

151171 exist <- liftIO $ getFileExistsVFS vfs file

152172 pure (summarizeExists exist, ([], Just exist))

@@ -159,29 +179,3 @@ getFileExistsVFS vfs file = do

159179 handle (\(_ :: IOException) -> return False) $

160180 (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^

161181 Dir.doesFileExist (fromNormalizedFilePath file)

162−

163−--------------------------------------------------------------------------------------------------

164−-- The message definitions below probably belong in haskell-lsp-types

165−

166−data DidChangeWatchedFilesRegistrationOptions = DidChangeWatchedFilesRegistrationOptions

167− { watchers :: List FileSystemWatcher

168− }

169−

170−instance A.ToJSON DidChangeWatchedFilesRegistrationOptions where

171− toJSON DidChangeWatchedFilesRegistrationOptions {..} =

172− A.object ["watchers" A..= watchers]

173−

174−data FileSystemWatcher = FileSystemWatcher

175− { -- | The glob pattern to watch.

176− -- For details on glob pattern syntax, check the spec: https://microsoft.github.io/language-server-protocol/specifications/specification-3-14/#workspace_didChangeWatchedFiles

177− globPattern :: String

178− -- | The kind of event to subscribe to. Defaults to all.

179− -- Defined as a bitmap of Create(1), Change(2), and Delete(4)

180− , kind :: Maybe Int

181− }

182−

183−instance A.ToJSON FileSystemWatcher where

184− toJSON FileSystemWatcher {..} =

185− A.object

186− $ ["globPattern" A..= globPattern]

187− ++ [ "kind" A..= x | Just x <- [kind] ]

src/Development/IDE/Core/FileStore.hs+8−5

@@ -95,11 +95,12 @@ getModificationTimeRule :: VFSHandle -> Rules ()

9595getModificationTimeRule vfs =

9696 defineEarlyCutoff $ \GetModificationTime file -> do

9797 let file' = fromNormalizedFilePath file

98− let wrap time = (Just time, ([], Just $ ModificationTime time))

98+ let wrap time@(l,s) = (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s))

9999 alwaysRerun

100100 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file

101101 case mbVirtual of

102− Just (virtualFileVersion -> ver) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))

102+ Just (virtualFileVersion -> ver) ->

103+ pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))

103104 Nothing -> liftIO $ fmap wrap (getModTime file')

104105 `catch` \(e :: IOException) -> do

105106 let err | isDoesNotExistError e = "File does not exist: " ++ file'

@@ -115,11 +116,13 @@ getModificationTimeRule vfs =

115116 -- We might also want to try speeding this up on Windows at some point.

116117 -- TODO leverage DidChangeWatchedFile lsp notifications on clients that

117118 -- support them, as done for GetFileExists

118− getModTime :: FilePath -> IO BS.ByteString

119+ getModTime :: FilePath -> IO (Int,Int)

119120 getModTime f =

120121#ifdef mingw32_HOST_OS

121122 do time <- Dir.getModificationTime f

122− pure $! BS.pack $ show (toModifiedJulianDay $ utctDay time, diffTimeToPicoseconds $ utctDayTime time)

123+ let !day = fromInteger $ toModifiedJulianDay $ utctDay time

124+ !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time

125+ pure (day, dayTime)

123126#else

124127 withCString f $ \f' ->

125128 alloca $ \secPtr ->

@@ -127,7 +130,7 @@ getModificationTimeRule vfs =

127130 Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr

128131 sec <- peek secPtr

129132 nsec <- peek nsecPtr

130− pure $! BS.pack $ show sec <> "." <> show nsec

133+ pure (fromEnum sec, fromIntegral nsec)

131134

132135-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow

133136-- as doing the FFI call ourselves :(.

src/Development/IDE/Core/IdeConfiguration.hsnew file+71

@@ -0,0 +1,71 @@

1+{-# LANGUAGE DuplicateRecordFields #-}

2+module Development.IDE.Core.IdeConfiguration

3+ ( IdeConfiguration(..)

4+ , registerIdeConfiguration

5+ , parseConfiguration

6+ , parseWorkspaceFolder

7+ , isWorkspaceFile

8+ , modifyWorkspaceFolders

9+ )

10+where

11+

12+import Control.Concurrent.Extra

13+import Control.Monad

14+import Data.HashSet (HashSet, singleton)

15+import Data.Text (Text, isPrefixOf)

16+import Development.IDE.Core.Shake

17+import Development.IDE.Types.Location

18+import Development.Shake

19+import Language.Haskell.LSP.Types

20+import System.FilePath (isRelative)

21+

22+-- | Lsp client relevant configuration details

23+data IdeConfiguration = IdeConfiguration

24+ { workspaceFolders :: HashSet NormalizedUri

25+ }

26+ deriving (Show)

27+

28+newtype IdeConfigurationVar = IdeConfigurationVar {unIdeConfigurationRef :: Var IdeConfiguration}

29+

30+instance IsIdeGlobal IdeConfigurationVar

31+

32+registerIdeConfiguration :: ShakeExtras -> IdeConfiguration -> IO ()

33+registerIdeConfiguration extras =

34+ addIdeGlobalExtras extras . IdeConfigurationVar <=< newVar

35+

36+getIdeConfiguration :: Action IdeConfiguration

37+getIdeConfiguration =

38+ getIdeGlobalAction >>= liftIO . readVar . unIdeConfigurationRef

39+

40+parseConfiguration :: InitializeParams -> IdeConfiguration

41+parseConfiguration InitializeParams {..} =

42+ IdeConfiguration { .. }

43+ where

44+ workspaceFolders =

45+ foldMap (singleton . toNormalizedUri) _rootUri

46+ <> (foldMap . foldMap)

47+ (singleton . parseWorkspaceFolder)

48+ _workspaceFolders

49+

50+parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri

51+parseWorkspaceFolder =

52+ toNormalizedUri . Uri . (_uri :: WorkspaceFolder -> Text)

53+

54+modifyWorkspaceFolders

55+ :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()

56+modifyWorkspaceFolders ide f = do

57+ IdeConfigurationVar var <- getIdeGlobalState ide

58+ IdeConfiguration ws <- readVar var

59+ writeVar var (IdeConfiguration (f ws))

60+

61+isWorkspaceFile :: NormalizedFilePath -> Action Bool

62+isWorkspaceFile file =

63+ if isRelative (fromNormalizedFilePath file)

64+ then return True

65+ else do

66+ IdeConfiguration {..} <- getIdeConfiguration

67+ let toText = getUri . fromNormalizedUri

68+ return $

69+ any

70+ (\root -> toText root `isPrefixOf` toText (filePathToUri' file))

71+ workspaceFolders

src/Development/IDE/Core/OfInterest.hs+10−10

@@ -19,8 +19,8 @@ import GHC.Generics

1919import Data.Typeable

2020import qualified Data.ByteString.UTF8 as BS

2121import Control.Exception

22−import Data.Set (Set)

23−import qualified Data.Set as Set

22+import Data.HashSet (HashSet)

23+import qualified Data.HashSet as HashSet

2424import qualified Data.Text as T

2525import Data.Tuple.Extra

2626import Data.Functor

@@ -31,10 +31,10 @@ import Development.IDE.Types.Logger

3131import Development.IDE.Core.Shake

3232

3333

34−newtype OfInterestVar = OfInterestVar (Var (Set NormalizedFilePath))

34+newtype OfInterestVar = OfInterestVar (Var (HashSet NormalizedFilePath))

3535instance IsIdeGlobal OfInterestVar

3636

37−type instance RuleResult GetFilesOfInterest = Set NormalizedFilePath

37+type instance RuleResult GetFilesOfInterest = HashSet NormalizedFilePath

3838

3939data GetFilesOfInterest = GetFilesOfInterest

4040 deriving (Eq, Show, Typeable, Generic)

@@ -46,7 +46,7 @@ instance Binary GetFilesOfInterest

4646-- | The rule that initialises the files of interest state.

4747ofInterestRules :: Rules ()

4848ofInterestRules = do

49− addIdeGlobal . OfInterestVar =<< liftIO (newVar Set.empty)

49+ addIdeGlobal . OfInterestVar =<< liftIO (newVar HashSet.empty)

5050 defineEarlyCutoff $ \GetFilesOfInterest _file -> assert (null $ fromNormalizedFilePath _file) $ do

5151 alwaysRerun

5252 filesOfInterest <- getFilesOfInterestUntracked

@@ -54,7 +54,7 @@ ofInterestRules = do

5454

5555

5656-- | Get the files that are open in the IDE.

57−getFilesOfInterest :: Action (Set NormalizedFilePath)

57+getFilesOfInterest :: Action (HashSet NormalizedFilePath)

5858getFilesOfInterest = useNoFile_ GetFilesOfInterest

5959

6060

@@ -64,19 +64,19 @@ getFilesOfInterest = useNoFile_ GetFilesOfInterest

6464

6565-- | Set the files-of-interest - not usually necessary or advisable.

6666-- The LSP client will keep this information up to date.

67−setFilesOfInterest :: IdeState -> Set NormalizedFilePath -> IO ()

67+setFilesOfInterest :: IdeState -> HashSet NormalizedFilePath -> IO ()

6868setFilesOfInterest state files = modifyFilesOfInterest state (const files)

6969

70−getFilesOfInterestUntracked :: Action (Set NormalizedFilePath)

70+getFilesOfInterestUntracked :: Action (HashSet NormalizedFilePath)

7171getFilesOfInterestUntracked = do

7272 OfInterestVar var <- getIdeGlobalAction

7373 liftIO $ readVar var

7474

7575-- | Modify the files-of-interest - not usually necessary or advisable.

7676-- The LSP client will keep this information up to date.

77−modifyFilesOfInterest :: IdeState -> (Set NormalizedFilePath -> Set NormalizedFilePath) -> IO ()

77+modifyFilesOfInterest :: IdeState -> (HashSet NormalizedFilePath -> HashSet NormalizedFilePath) -> IO ()

7878modifyFilesOfInterest state f = do

7979 OfInterestVar var <- getIdeGlobalState state

8080 files <- modifyVar var $ pure . dupe . f

81− logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ Set.toList files)

81+ logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ HashSet.toList files)

8282 void $ shakeRun state []

src/Development/IDE/Core/PositionMapping.hs+48−10

@@ -2,10 +2,15 @@

22-- SPDX-License-Identifier: Apache-2.0

33module Development.IDE.Core.PositionMapping

44 ( PositionMapping(..)

5+ , fromCurrentPosition

6+ , toCurrentPosition

7+ , PositionDelta(..)

8+ , addDelta

9+ , mkDelta

510 , toCurrentRange

611 , fromCurrentRange

712 , applyChange

8− , idMapping

13+ , zeroMapping

914 -- toCurrent and fromCurrent are mainly exposed for testing

1015 , toCurrent

1116 , fromCurrent

@@ -14,12 +19,25 @@ module Development.IDE.Core.PositionMapping

1419import Control.Monad

1520import qualified Data.Text as T

1621import Language.Haskell.LSP.Types

22+import Data.List

1723

18−data PositionMapping = PositionMapping

19− { toCurrentPosition :: !(Position -> Maybe Position)

20− , fromCurrentPosition :: !(Position -> Maybe Position)

24+-- The position delta is the difference between two versions

25+data PositionDelta = PositionDelta

26+ { toDelta :: !(Position -> Maybe Position)

27+ , fromDelta :: !(Position -> Maybe Position)

2128 }

2229

30+fromCurrentPosition :: PositionMapping -> Position -> Maybe Position

31+fromCurrentPosition (PositionMapping pm) = fromDelta pm

32+

33+toCurrentPosition :: PositionMapping -> Position -> Maybe Position

34+toCurrentPosition (PositionMapping pm) = toDelta pm

35+

36+-- A position mapping is the difference from the current version to

37+-- a specific version

38+newtype PositionMapping = PositionMapping PositionDelta

39+

40+

2341toCurrentRange :: PositionMapping -> Range -> Maybe Range

2442toCurrentRange mapping (Range a b) =

2543 Range <$> toCurrentPosition mapping a <*> toCurrentPosition mapping b

@@ -28,13 +46,33 @@ fromCurrentRange :: PositionMapping -> Range -> Maybe Range

2846fromCurrentRange mapping (Range a b) =

2947 Range <$> fromCurrentPosition mapping a <*> fromCurrentPosition mapping b

3048

31−idMapping :: PositionMapping

32−idMapping = PositionMapping Just Just

49+zeroMapping :: PositionMapping

50+zeroMapping = PositionMapping idDelta

51+

52+-- | Compose two position mappings. Composes in the same way as function

53+-- composition (ie the second argument is applyed to the position first).

54+composeDelta :: PositionDelta

55+ -> PositionDelta

56+ -> PositionDelta

57+composeDelta (PositionDelta to1 from1) (PositionDelta to2 from2) =

58+ PositionDelta (to1 <=< to2)

59+ (from1 >=> from2)

60+

61+idDelta :: PositionDelta

62+idDelta = PositionDelta Just Just

63+

64+-- | Convert a set of changes into a delta from k to k + 1

65+mkDelta :: [TextDocumentContentChangeEvent] -> PositionDelta

66+mkDelta cs = foldl' applyChange idDelta cs

67+

68+-- | Add a new delta onto a Mapping k n to make a Mapping (k - 1) n

69+addDelta :: PositionDelta -> PositionMapping -> PositionMapping

70+addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm)

3371

34−applyChange :: PositionMapping -> TextDocumentContentChangeEvent -> PositionMapping

35−applyChange posMapping (TextDocumentContentChangeEvent (Just r) _ t) = PositionMapping

36− { toCurrentPosition = toCurrent r t <=< toCurrentPosition posMapping

37− , fromCurrentPosition = fromCurrentPosition posMapping <=< fromCurrent r t

72+applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta

73+applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta

74+ { toDelta = toCurrent r t <=< toDelta

75+ , fromDelta = fromDelta <=< fromCurrent r t

3876 }

3977applyChange posMapping _ = posMapping

4078

src/Development/IDE/Core/Preprocessor.hs+15−13

@@ -29,11 +29,15 @@ import Data.IORef (IORef, modifyIORef, newIORef, readIORef)

2929import Data.Text (Text)

3030import qualified Data.Text as T

3131import Outputable (showSDoc)

32+import Control.DeepSeq (NFData(rnf))

33+import Control.Exception (evaluate)

34+import Control.Monad.IO.Class (MonadIO)

35+import Exception (ExceptionMonad)

3236

3337

3438-- | Given a file and some contents, apply any necessary preprocessors,

3539-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.

36−preprocessor :: GhcMonad m => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)

40+preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)

3741preprocessor filename mbContents = do

3842 -- Perform unlit

3943 (isOnDisk, contents) <-

@@ -96,7 +100,7 @@ data CPPDiag

96100

97101diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic]

98102diagsFromCPPLogs filename logs =

99− map (\d -> (toNormalizedFilePath filename, ShowDiag, cppDiagToDiagnostic d)) $

103+ map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $

100104 go [] logs

101105 where

102106 -- On errors, CPP calls logAction with a real span for the initial log and

@@ -118,7 +122,8 @@ diagsFromCPPLogs filename logs =

118122 _code = Nothing,

119123 _source = Just "CPP",

120124 _message = T.unlines $ cdMessage d,

121− _relatedInformation = Nothing

125+ _relatedInformation = Nothing,

126+ _tags = Nothing

122127 }

123128

124129

@@ -128,13 +133,17 @@ isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]

128133

129134-- | This reads the pragma information directly from the provided buffer.

130135parsePragmasIntoDynFlags

131− :: GhcMonad m

136+ :: (ExceptionMonad m, HasDynFlags m, MonadIO m)

132137 => FilePath

133138 -> SB.StringBuffer

134139 -> m (Either [FileDiagnostic] DynFlags)

135140parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do

136− dflags0 <- getSessionDynFlags

141+ dflags0 <- getDynFlags

137142 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+

138147 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts

139148 return dflags

140149

@@ -166,18 +175,11 @@ runLhs dflags filename contents = withTempDir $ \dir -> do

166175 escape (c:cs) = c : escape cs

167176 escape [] = []

168177

169−

170−modifyOptP :: ([String] -> [String]) -> DynFlags -> DynFlags

171−modifyOptP op = onSettings (onOptP op)

172− where

173− onSettings f x = x{settings = f $ settings x}

174− onOptP f x = x{sOpt_P = f $ sOpt_P x}

175−

176178-- | Run CPP on a file

177179runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer

178180runCpp dflags filename contents = withTempDir $ \dir -> do

179181 let out = dir </> takeFileName filename <.> "out"

180− dflags <- pure $ modifyOptP ("-D__GHCIDE__":) dflags

182+ dflags <- pure $ addOptP "-D__GHCIDE__" dflags

181183

182184 case contents of

183185 Nothing -> do

src/Development/IDE/Core/RuleTypes.hs+50−11

@@ -15,7 +15,6 @@ import Control.DeepSeq

1515import Data.Binary

1616import Development.IDE.Import.DependencyInformation

1717import Development.IDE.GHC.Util

18−import Development.IDE.Types.Location

1918import Data.Hashable

2019import Data.Typeable

2120import qualified Data.Set as S

@@ -25,9 +24,9 @@ import GHC.Generics (Generic)

2524import GHC

2625import Module (InstalledUnitId)

2726import HscTypes (CgGuts, Linkable, HomeModInfo, ModDetails)

28−import Development.IDE.GHC.Compat

2927

3028import Development.IDE.Spans.Type

29+import Development.IDE.Import.FindImports (ArtifactsLocation)

3130

3231

3332-- NOTATION

@@ -58,6 +57,22 @@ instance Show TcModuleResult where

5857instance NFData TcModuleResult where

5958 rnf = rwhnf

6059

60+tmrModSummary :: TcModuleResult -> ModSummary

61+tmrModSummary = pm_mod_summary . tm_parsed_module . tmrModule

62+

63+data HiFileResult = HiFileResult

64+ { hirModSummary :: !ModSummary

65+ -- Bang patterns here are important to stop the result retaining

66+ -- a reference to a typechecked module

67+ , hirModIface :: !ModIface

68+ }

69+

70+instance NFData HiFileResult where

71+ rnf = rwhnf

72+

73+instance Show HiFileResult where

74+ show = show . hirModSummary

75+

6176-- | The type checked version of this file, requires TypeCheck+

6277type instance RuleResult TypeCheck = TcModuleResult

6378

@@ -75,16 +90,24 @@ type instance RuleResult GhcSession = HscEnvEq

7590

7691-- | Resolve the imports in a module to the file path of a module

7792-- in the same package or the package id of another package.

78−type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe NormalizedFilePath)], S.Set InstalledUnitId)

93+type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId)

7994

8095-- | This rule is used to report import cycles. It depends on GetDependencyInformation.

8196-- We cannot report the cycles directly from GetDependencyInformation since

8297-- we can only report diagnostics for the current file.

8398type instance RuleResult ReportImportCycles = ()

8499

85−-- | Read the given HIE file.

86−type instance RuleResult GetHieFile = HieFile

100+-- | Read the module interface file

101+type instance RuleResult GetHiFile = HiFileResult

102+

103+-- | Get a module interface, either from an interface file or a typechecked module

104+type instance RuleResult GetModIface = HiFileResult

87105

106+type instance RuleResult IsFileOfInterest = Bool

107+

108+-- | Generate a ModSummary that has enough information to be used to get .hi and .hie files.

109+-- without needing to parse the entire source

110+type instance RuleResult GetModSummary = ModSummary

88111

89112data GetParsedModule = GetParsedModule

90113 deriving (Eq, Show, Typeable, Generic)

@@ -146,10 +169,26 @@ instance Hashable GhcSession

146169instance NFData GhcSession

147170instance Binary GhcSession

148171

149−-- Note that we embed the filepath here instead of using the filepath associated with Shake keys.

150−-- Otherwise we will garbage collect the result since files in package dependencies will not be declared reachable.

151−data GetHieFile = GetHieFile FilePath

172+data GetHiFile = GetHiFile

173+ deriving (Eq, Show, Typeable, Generic)

174+instance Hashable GetHiFile

175+instance NFData GetHiFile

176+instance Binary GetHiFile

177+

178+data GetModIface = GetModIface

179+ deriving (Eq, Show, Typeable, Generic)

180+instance Hashable GetModIface

181+instance NFData GetModIface

182+instance Binary GetModIface

183+

184+data IsFileOfInterest = IsFileOfInterest

185+ deriving (Eq, Show, Typeable, Generic)

186+instance Hashable IsFileOfInterest

187+instance NFData IsFileOfInterest

188+instance Binary IsFileOfInterest

189+

190+data GetModSummary = GetModSummary

152191 deriving (Eq, Show, Typeable, Generic)

153−instance Hashable GetHieFile

154−instance NFData GetHieFile

155−instance Binary GetHieFile

192+instance Hashable GetModSummary

193+instance NFData GetModSummary

194+instance Binary GetModSummary

src/Development/IDE/Core/Rules.hs+420−118

@@ -1,16 +1,18 @@

22-- SPDX-License-Identifier: Apache-2.0

4−{-# LANGUAGE TypeFamilies #-}

5−{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE CPP #-}

5+{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE FlexibleInstances #-}

67{-# LANGUAGE DuplicateRecordFields #-}

8+#include "ghc-api-version.h"

810-- | A Shake implementation of the compiler service, built

911-- using the "Shaker" abstraction layer for in-memory use.

1012--

1113module Development.IDE.Core.Rules(

1214 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),

13− Priority(..),

15+ Priority(..), GhcSessionIO(..), GhcSessionFun(..),

1416 priorityTypeCheck,

1517 priorityGenerateCore,

1618 priorityFilesOfInterest,

@@ -26,11 +28,13 @@ module Development.IDE.Core.Rules(

2628

2729import Fingerprint

2830

29−import Data.Binary

30−import Control.Monad

31+import Data.Binary hiding (get, put)

32+import Data.Bifunctor (first, second)

33+import Control.Monad.Extra

3134import Control.Monad.Trans.Class

3235import Control.Monad.Trans.Maybe

3336import Development.IDE.Core.Compile

37+import Development.IDE.Core.OfInterest

3438import Development.IDE.Types.Options

3539import Development.IDE.Spans.Calculate

3640import Development.IDE.Import.DependencyInformation

@@ -39,34 +43,39 @@ import Development.IDE.Core.FileExists

3943import Development.IDE.Core.FileStore (getFileContents)

4044import Development.IDE.Types.Diagnostics

4145import Development.IDE.Types.Location

46+import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)

4247import Development.IDE.GHC.Util

43−import Data.Coerce

48+import Development.IDE.GHC.WithDynFlags

4449import Data.Either.Extra

4550import Data.Maybe

4651import Data.Foldable

4752import qualified Data.IntMap.Strict as IntMap

48−import qualified Data.IntSet as IntSet

53+import Data.IntMap.Strict (IntMap)

4954import Data.List

55+import Data.Ord

5056import qualified Data.Set as Set

5157import qualified Data.Text as T

5258import Development.IDE.GHC.Error

5359import Development.Shake hiding (Diagnostic)

5460import Development.IDE.Core.RuleTypes

5561import Development.IDE.Spans.Type

62+import qualified Data.ByteString.Char8 as BS

5663

57−import GHC hiding (parseModule, typecheckModule)

5864import qualified GHC.LanguageExtensions as LangExt

59−import Development.IDE.GHC.Compat (hie_file_result, readHieFile)

60−import UniqSupply

61−import NameCache

6265import HscTypes

63−import DynFlags (xopt)

66+import PackageConfig

67+import DynFlags (gopt_set, xopt)

6468import GHC.Generics(Generic)

6569

6670import qualified Development.IDE.Spans.AtPoint as AtPoint

6771import Development.IDE.Core.Service

6872import Development.IDE.Core.Shake

69−import Development.Shake.Classes

73+import Development.Shake.Classes hiding (get, put)

74+import Control.Monad.Trans.Except (runExceptT)

75+import Data.ByteString (ByteString)

76+import Control.Concurrent.Async (concurrently)

77+

78+import Control.Monad.State

7079

7180-- | This is useful for rules to convert rules that can only produce errors or

7281-- a result into the more general IdeResult type that supports producing

@@ -80,14 +89,14 @@ useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v

8089useE k = MaybeT . use k

8190

8291useNoFileE :: IdeRule k v => k -> MaybeT Action v

83−useNoFileE k = useE k ""

92+useNoFileE k = useE k emptyFilePath

8493

8594usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]

8695usesE k = MaybeT . fmap sequence . uses k

8796

8897defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()

8998defineNoFile f = define $ \k file -> do

90− if file == "" then do res <- f k; return ([], Just res) else

99+ if file == emptyFilePath then do res <- f k; return ([], Just res) else

91100 fail $ "Rule " ++ show k ++ " should always be called with the empty string for a file"

92101

93102

@@ -111,9 +120,58 @@ getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)

111120getDefinition file pos = fmap join $ runMaybeT $ do

112121 opts <- lift getIdeOptions

113122 spans <- useE GetSpanInfo file

114− pkgState <- hscEnv <$> useE GhcSession file

115− let getHieFile x = useNoFile (GetHieFile x)

116− lift $ AtPoint.gotoDefinition getHieFile opts pkgState (spansExprs spans) pos

123+ lift $ AtPoint.gotoDefinition (getHieFile file) opts (spansExprs spans) pos

124+

125+getHieFile

126+ :: NormalizedFilePath -- ^ file we're editing

127+ -> Module -- ^ module dep we want info for

128+ -> Action (Maybe (HieFile, FilePath)) -- ^ hie stuff for the module

129+getHieFile file mod = do

130+ TransitiveDependencies {transitiveNamedModuleDeps} <- use_ GetDependencies file

131+ case find (\x -> nmdModuleName x == moduleName mod) transitiveNamedModuleDeps of

132+ Just NamedModuleDep{nmdFilePath=nfp} -> do

133+ let modPath = fromNormalizedFilePath nfp

134+ (_diags, hieFile) <- getHomeHieFile nfp

135+ return $ (, modPath) <$> hieFile

136+ _ -> getPackageHieFile mod file

137+

138+

139+getHomeHieFile :: NormalizedFilePath -> Action ([a], Maybe HieFile)

140+getHomeHieFile f = do

141+ ms <- use_ GetModSummary f

142+ let normal_hie_f = toNormalizedFilePath' hie_f

143+ hie_f = ml_hie_file $ ms_location ms

144+ mbHieTimestamp <- use GetModificationTime normal_hie_f

145+ srcTimestamp <- use_ GetModificationTime f

146+ let isUpToDate

147+ | Just d <- mbHieTimestamp = comparing modificationTime d srcTimestamp == GT

148+ | otherwise = False

149+

150+ unless isUpToDate $

151+ void $ use_ TypeCheck f

152+

153+ hf <- liftIO $ whenMaybe isUpToDate (loadHieFile hie_f)

154+ return ([], hf)

155+

156+getPackageHieFile :: Module -- ^ Package Module to load .hie file for

157+ -> NormalizedFilePath -- ^ Path of home module importing the package module

158+ -> Action (Maybe (HieFile, FilePath))

159+getPackageHieFile mod file = do

160+ pkgState <- hscEnv <$> use_ GhcSession file

161+ IdeOptions {..} <- getIdeOptions

162+ let unitId = moduleUnitId mod

163+ case lookupPackageConfig unitId pkgState of

164+ Just pkgConfig -> do

165+ -- 'optLocateHieFile' returns Nothing if the file does not exist

166+ hieFile <- liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod

167+ path <- liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod

168+ case (hieFile, path) of

169+ (Just hiePath, Just modPath) ->

170+ -- deliberately loaded outside the Shake graph

171+ -- to avoid dependencies on non-workspace files

172+ liftIO $ Just . (, modPath) <$> loadHieFile hiePath

173+ _ -> return Nothing

174+ _ -> return Nothing

117175

118176-- | Parse the contents of a daml file.

119177getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)

@@ -133,31 +191,60 @@ priorityFilesOfInterest :: Priority

133191priorityFilesOfInterest = Priority (-2)

134192

135193getParsedModuleRule :: Rules ()

136−getParsedModuleRule =

137− defineEarlyCutoff $ \GetParsedModule file -> do

138− (_, contents) <- getFileContents file

139− packageState <- hscEnv <$> use_ GhcSession file

140− opt <- getIdeOptions

141− (diag, res) <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) (fmap textToStringBuffer contents)

142− case res of

143− Nothing -> pure (Nothing, (diag, Nothing))

144− Just (contents, modu) -> do

145− mbFingerprint <- if isNothing $ optShakeFiles opt

146− then pure Nothing

147− else liftIO $ Just . fingerprintToBS <$> fingerprintFromStringBuffer contents

148− pure (mbFingerprint, (diag, Just modu))

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))

149235

150236getLocatedImportsRule :: Rules ()

151237getLocatedImportsRule =

152238 define $ \GetLocatedImports file -> do

153− pm <- use_ GetParsedModule file

154− let ms = pm_mod_summary pm

239+ ms <- use_ GetModSummary file

155240 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]

156− env <- hscEnv <$> use_ GhcSession file

157− let dflags = addRelativeImport file pm $ hsc_dflags env

241+ env_eq <- use_ GhcSession file

242+ let env = hscEnv env_eq

243+ let import_dirs = deps env_eq

244+ let dflags = addRelativeImport file (moduleName $ ms_mod ms) $ hsc_dflags env

158245 opt <- getIdeOptions

159246 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do

160− diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource

247+ diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getFileExists modName mbPkgName isSource

161248 case diagOrImp of

162249 Left diags -> pure (diags, Left (modName, Nothing))

163250 Right (FileImport path) -> pure ([], Left (modName, Just path))

@@ -171,48 +258,109 @@ getLocatedImportsRule =

171258 Nothing -> pure (concat diags, Nothing)

172259 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))

173260

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+ )

174269

175270-- | Given a target file path, construct the raw dependency results by following

176271-- imports recursively.

177−rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation

178−rawDependencyInformation f = do

179− let (initialId, initialMap) = getPathId f emptyPathIdMap

180− go (IntSet.singleton $ getFilePathId initialId)

181− (RawDependencyInformation IntMap.empty initialMap)

272+rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation

273+rawDependencyInformation fs = do

274+ (rdi, ss) <- execRawDepM (mapM_ go fs)

275+ let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss

276+ return (rdi { rawBootMap = bm })

182277 where

183− go fs rawDepInfo =

184− case IntSet.minView fs of

185− -- Queue is empty

186− Nothing -> pure rawDepInfo

187− -- Pop f from the queue and process it

188− Just (f, fs) -> do

189− let fId = FilePathId f

190− importsOrErr <- use GetLocatedImports $ idToPath (rawPathIdMap rawDepInfo) fId

191− case importsOrErr of

192− Nothing ->

193− -- File doesn’t parse

194− let rawDepInfo' = insertImport fId (Left ModuleParseError) rawDepInfo

195− in go fs rawDepInfo'

196− Just (modImports, pkgImports) -> do

197− let f :: PathIdMap -> (a, Maybe NormalizedFilePath) -> (PathIdMap, (a, Maybe FilePathId))

198− f pathMap (imp, mbPath) = case mbPath of

199− Nothing -> (pathMap, (imp, Nothing))

200− Just path ->

201− let (pathId, pathMap') = getPathId path pathMap

202− in (pathMap', (imp, Just pathId))

203− -- Convert paths in imports to ids and update the path map

204− let (pathIdMap, modImports') = mapAccumL f (rawPathIdMap rawDepInfo) modImports

205− -- Files that we haven’t seen before are added to the queue.

206− let newFiles =

207− IntSet.fromList (coerce $ mapMaybe snd modImports')

208− IntSet.\\ IntMap.keysSet (rawImports rawDepInfo)

209− let rawDepInfo' = insertImport fId (Right $ ModuleImports modImports' pkgImports) rawDepInfo

210− go (newFiles `IntSet.union` fs) (rawDepInfo' { rawPathIdMap = pathIdMap })

278+ go :: NormalizedFilePath -- ^ Current module being processed

279+ -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId

280+ go f = do

281+ -- First check to see if we have already processed the FilePath

282+ -- If we have, just return its Id but don't update any of the state.

283+ -- Otherwise, we need to process its imports.

284+ checkAlreadyProcessed f $ do

285+ al <- lift $ modSummaryToArtifactsLocation f <$> use_ GetModSummary f

286+ -- Get a fresh FilePathId for the new file

287+ fId <- getFreshFid al

288+ -- Adding an edge to the bootmap so we can make sure to

289+ -- insert boot nodes before the real files.

290+ addBootMap al fId

291+ -- Try to parse the imports of the file

292+ importsOrErr <- lift $ use GetLocatedImports f

293+ case importsOrErr of

294+ Nothing -> do

295+ -- File doesn't parse so add the module as a failure into the

296+ -- dependency information, continue processing the other

297+ -- elements in the queue

298+ modifyRawDepInfo (insertImport fId (Left ModuleParseError))

299+ return fId

300+ Just (modImports, pkgImports) -> do

301+ -- Get NFPs of the imports which have corresponding files

302+ -- Imports either come locally from a file or from a package.

303+ let (no_file, with_file) = splitImports modImports

304+ (mns, ls) = unzip with_file

305+ -- Recursively process all the imports we just learnt about

306+ -- and get back a list of their FilePathIds

307+ fids <- mapM (go . artifactFilePath) ls

308+ -- Associate together the ModuleName with the FilePathId

309+ let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids)

310+ -- Insert into the map the information about this modules

311+ -- imports.

312+ modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports' pkgImports)

313+ return fId

314+

315+

316+ checkAlreadyProcessed :: NormalizedFilePath -> RawDepM FilePathId -> RawDepM FilePathId

317+ checkAlreadyProcessed nfp k = do

318+ (rawDepInfo, _) <- get

319+ maybe k return (lookupPathToId (rawPathIdMap rawDepInfo) nfp)

320+

321+ modifyRawDepInfo :: (RawDependencyInformation -> RawDependencyInformation) -> RawDepM ()

322+ modifyRawDepInfo f = modify (first f)

323+

324+ addBootMap :: ArtifactsLocation -> FilePathId -> RawDepM ()

325+ addBootMap al fId =

326+ modify (\(rd, ss) -> (rd, if isBootLocation al

327+ then IntMap.insert (getFilePathId fId) al ss

328+ else ss))

329+

330+ getFreshFid :: ArtifactsLocation -> RawDepM FilePathId

331+ getFreshFid al = do

332+ (rawDepInfo, ss) <- get

333+ let (fId, path_map) = getPathId al (rawPathIdMap rawDepInfo)

334+ -- Insert the File into the bootmap if it's a boot module

335+ let rawDepInfo' = rawDepInfo { rawPathIdMap = path_map }

336+ put (rawDepInfo', ss)

337+ return fId

338+

339+ -- Split in (package imports, local imports)

340+ splitImports :: [(Located ModuleName, Maybe ArtifactsLocation)]

341+ -> ([Located ModuleName], [(Located ModuleName, ArtifactsLocation)])

342+ splitImports = foldr splitImportsLoop ([],[])

343+

344+ splitImportsLoop (imp, Nothing) (ns, ls) = (imp:ns, ls)

345+ splitImportsLoop (imp, Just artifact) (ns, ls) = (ns, (imp,artifact) : ls)

346+

347+ updateBootMap pm boot_mod_id ArtifactsLocation{..} bm =

348+ if not artifactIsSource

349+ then

350+ let msource_mod_id = lookupPathToId (rawPathIdMap pm) (toNormalizedFilePath' $ dropBootSuffix artifactModLocation)

351+ in case msource_mod_id of

352+ Just source_mod_id -> insertBootId source_mod_id (FilePathId boot_mod_id) bm

353+ Nothing -> bm

354+ else bm

355+

356+ dropBootSuffix :: ModLocation -> FilePath

357+ dropBootSuffix (ModLocation (Just hs_src) _ _) = reverse . drop (length @[] "-boot") . reverse $ hs_src

358+ dropBootSuffix _ = error "dropBootSuffix"

211359

212360getDependencyInformationRule :: Rules ()

213361getDependencyInformationRule =

214362 define $ \GetDependencyInformation file -> do

215− rawDepInfo <- rawDependencyInformation file

363+ rawDepInfo <- rawDependencyInformation [file]

216364 pure ([], Just $ processDependencyInformation rawDepInfo)

217365

218366reportImportCyclesRule :: Rules ()

@@ -240,12 +388,13 @@ reportImportCyclesRule =

240388 , _message = "Cyclic module dependency between " <> showCycle mods

241389 , _code = Nothing

242390 , _relatedInformation = Nothing

391+ , _tags = Nothing

243392 }

244393 where loc = srcSpanToLocation (getLoc imp)

245− fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)

394+ fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp)

246395 getModuleName file = do

247− pm <- use_ GetParsedModule file

248− pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)

396+ ms <- use_ GetModSummary file

397+ pure (moduleNameString . moduleName . ms_mod $ ms)

249398 showCycle mods = T.intercalate ", " (map T.pack mods)

250399

251400-- returns all transitive dependencies in topological order.

@@ -253,7 +402,7 @@ reportImportCyclesRule =

253402getDependenciesRule :: Rules ()

254403getDependenciesRule =

255404 defineEarlyCutoff $ \GetDependencies file -> do

256− depInfo@DependencyInformation{..} <- use_ GetDependencyInformation file

405+ depInfo <- use_ GetDependencyInformation file

257406 let allFiles = reachableModules depInfo

258407 _ <- uses_ ReportImportCycles allFiles

259408 opts <- getIdeOptions

@@ -265,50 +414,101 @@ getSpanInfoRule :: Rules ()

265414getSpanInfoRule =

266415 define $ \GetSpanInfo file -> do

267416 tc <- use_ TypeCheck file

268− deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file

269− tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)

270− (fileImports, _) <- use_ GetLocatedImports file

271417 packageState <- hscEnv <$> use_ GhcSession file

272− x <- liftIO $ getSrcSpanInfos packageState fileImports tc tms

418+ deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file

419+ let tdeps = transitiveModuleDeps deps

420+

421+-- When possible, rely on the haddocks embedded in our interface files

422+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'

423+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)

424+ let parsedDeps = []

425+#else

426+ parsedDeps <- uses_ GetParsedModule tdeps

427+#endif

428+

429+ ifaces <- uses_ GetModIface tdeps

430+ (fileImports, _) <- use_ GetLocatedImports file

431+ let imports = second (fmap artifactFilePath) <$> fileImports

432+ x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps (map hirModIface ifaces)

273433 return ([], Just x)

274434

275435-- Typechecks a module.

276436typeCheckRule :: Rules ()

277−typeCheckRule =

278− define $ \TypeCheck file -> do

279− pm <- use_ GetParsedModule file

280− deps <- use_ GetDependencies file

281− packageState <- hscEnv <$> use_ GhcSession file

282− -- Figure out whether we need TemplateHaskell or QuasiQuotes support

283− let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph packageState

284− file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)

285− any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq

286− tms <- if any_uses_th_qq

287− -- If we use TH or QQ, we must obtain the bytecode

288− then do

289− bytecodes <- uses_ GenerateByteCode (transitiveModuleDeps deps)

290− tmrs <- uses_ TypeCheck (transitiveModuleDeps deps)

291− pure (zipWith addByteCode bytecodes tmrs)

292− else uses_ TypeCheck (transitiveModuleDeps deps)

293− setPriority priorityTypeCheck

294− IdeOptions{ optDefer = defer} <- getIdeOptions

295− liftIO $ typecheckModule defer packageState tms pm

296− where

297− uses_th_qq dflags = xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags

298− addByteCode :: Linkable -> TcModuleResult -> TcModuleResult

299− addByteCode lm tmr = tmr { tmrModInfo = (tmrModInfo tmr) { hm_linkable = Just lm } }

300−

301−generateCore :: NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))

302−generateCore file = do

437+typeCheckRule = define $ \TypeCheck file -> do

438+ pm <- use_ GetParsedModule file

439+ -- do not generate interface files as this rule is called

440+ -- for files of interest on every keystroke

441+ typeCheckRuleDefinition file pm SkipGenerationOfInterfaceFiles

442+

443+data GenerateInterfaceFiles

444+ = DoGenerateInterfaceFiles

445+ | SkipGenerationOfInterfaceFiles

446+ deriving (Show)

447+

448+-- This is factored out so it can be directly called from the GetModIface

449+-- rule. Directly calling this rule means that on the initial load we can

450+-- garbage collect all the intermediate typechecked modules rather than

451+-- retain the information forever in the shake graph.

452+typeCheckRuleDefinition

453+ :: NormalizedFilePath -- ^ Path to source file

454+ -> ParsedModule

455+ -> GenerateInterfaceFiles -- ^ Should generate .hi and .hie files ?

456+ -> Action (IdeResult TcModuleResult)

457+typeCheckRuleDefinition file pm generateArtifacts = do

458+ deps <- use_ GetDependencies file

459+ hsc <- hscEnv <$> use_ GhcSession file

460+ -- Figure out whether we need TemplateHaskell or QuasiQuotes support

461+ let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph hsc

462+ file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)

463+ any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq

464+ mirs <- uses_ GetModIface (transitiveModuleDeps deps)

465+ bytecodes <- if any_uses_th_qq

466+ then -- If we use TH or QQ, we must obtain the bytecode

467+ fmap Just <$> uses_ GenerateByteCode (transitiveModuleDeps deps)

468+ else

469+ pure $ repeat Nothing

470+

471+ setPriority priorityTypeCheck

472+ IdeOptions { optDefer = defer } <- getIdeOptions

473+

474+ addUsageDependencies $ liftIO $ do

475+ res <- typecheckModule defer hsc (zipWith unpack mirs bytecodes) pm

476+ case res of

477+ (diags, Just (hsc,tcm)) | DoGenerateInterfaceFiles <- generateArtifacts -> do

478+ diagsHie <- generateAndWriteHieFile hsc (tmrModule tcm)

479+ diagsHi <- generateAndWriteHiFile hsc tcm

480+ return (diags <> diagsHi <> diagsHie, Just tcm)

481+ (diags, res) ->

482+ return (diags, snd <$> res)

483+ where

484+ unpack HiFileResult{..} bc = (hirModSummary, (hirModIface, bc))

485+ uses_th_qq dflags =

486+ xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags

487+

488+ addUsageDependencies :: Action (a, Maybe TcModuleResult) -> Action (a, Maybe TcModuleResult)

489+ addUsageDependencies a = do

490+ r@(_, mtc) <- a

491+ forM_ mtc $ \tc -> do

492+ let used_files = mapMaybe udep (mi_usages (hm_iface (tmrModInfo tc)))

493+ udep (UsageFile fp _h) = Just fp

494+ udep _ = Nothing

495+ -- Add a dependency on these files which are added by things like

496+ -- qAddDependentFile

497+ void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files)

498+ return r

499+

500+

501+generateCore :: RunSimplifier -> NormalizedFilePath -> Action (IdeResult (SafeHaskellMode, CgGuts, ModDetails))

502+generateCore runSimplifier file = do

303503 deps <- use_ GetDependencies file

304504 (tm:tms) <- uses_ TypeCheck (file:transitiveModuleDeps deps)

305505 setPriority priorityGenerateCore

306506 packageState <- hscEnv <$> use_ GhcSession file

307− liftIO $ compileModule packageState tms tm

507+ liftIO $ compileModule runSimplifier packageState [(tmrModSummary x, tmrModInfo x) | x <- tms] tm

308508

309509generateCoreRule :: Rules ()

310510generateCoreRule =

311− define $ \GenerateCore -> generateCore

511+ define $ \GenerateCore -> generateCore (RunSimplifier True)

312512

313513generateByteCodeRule :: Rules ()

314514generateByteCodeRule =

@@ -317,7 +517,7 @@ generateByteCodeRule =

317517 (tm : tms) <- uses_ TypeCheck (file: transitiveModuleDeps deps)

318518 session <- hscEnv <$> use_ GhcSession file

319519 (_, guts, _) <- use_ GenerateCore file

320− liftIO $ generateByteCode session tms tm guts

520+ liftIO $ generateByteCode session [(tmrModSummary x, tmrModInfo x) | x <- tms] tm guts

321521

322522-- A local rule type to get caching. We want to use newCache, but it has

323523-- thread killed exception issues, so we lift it to a full rule.

@@ -329,7 +529,7 @@ instance Hashable GhcSessionIO

329529instance NFData GhcSessionIO

330530instance Binary GhcSessionIO

331531

332−newtype GhcSessionFun = GhcSessionFun (FilePath -> Action HscEnvEq)

532+newtype GhcSessionFun = GhcSessionFun (FilePath -> Action (IdeResult HscEnvEq))

333533instance Show GhcSessionFun where show _ = "GhcSessionFun"

334534instance NFData GhcSessionFun where rnf !_ = ()

335535

@@ -338,20 +538,119 @@ loadGhcSession :: Rules ()

338538loadGhcSession = do

339539 defineNoFile $ \GhcSessionIO -> do

340540 opts <- getIdeOptions

341− liftIO $ GhcSessionFun <$> optGhcSession opts

541+ GhcSessionFun <$> optGhcSession opts

542+ -- This function should always be rerun because it consults a cache to

543+ -- see what HscEnv needs to be used for the file, which can change.

544+ -- However, it should also cut-off early if it's the same HscEnv as

545+ -- last time

342546 defineEarlyCutoff $ \GhcSession file -> do

343547 GhcSessionFun fun <- useNoFile_ GhcSessionIO

548+ alwaysRerun

344549 val <- fun $ fromNormalizedFilePath file

345− opts <- getIdeOptions

346− return ("" <$ optShakeFiles opts, ([], Just val))

347550

551+ -- TODO: What was this doing before?

552+ opts <- getIdeOptions

553+ let cutoffHash =

554+ case optShakeFiles opts of

555+ -- optShakeFiles is only set in the DAML case.

556+ -- https://github.com/digital-asset/ghcide/pull/522#discussion_r428622915

557+ Just {} -> ""

558+ -- Hash the HscEnvEq returned so cutoff if it didn't change

559+ -- from last time

560+ Nothing -> BS.pack (show (hash (snd val)))

561+ return (Just cutoffHash, val)

562+

563+getHiFileRule :: Rules ()

564+getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do

565+ -- get all dependencies interface files, to check for freshness

566+ (deps,_) <- use_ GetLocatedImports f

567+ depHis <- traverse (use GetHiFile) (mapMaybe (fmap artifactFilePath . snd) deps)

568+

569+ ms <- use_ GetModSummary f

570+ let hiFile = toNormalizedFilePath'

571+ $ case ms_hsc_src ms of

572+ HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)

573+ _ -> ml_hi_file $ ms_location ms

574+

575+ case sequence depHis of

576+ Nothing -> pure (Nothing, ([], Nothing))

577+ Just deps -> do

578+ gotHiFile <- getFileExists hiFile

579+ if not gotHiFile

580+ then pure (Nothing, ([], Nothing))

581+ else do

582+ hiVersion <- use_ GetModificationTime hiFile

583+ modVersion <- use_ GetModificationTime f

584+ let sourceModified = modificationTime hiVersion < modificationTime modVersion

585+ if sourceModified

586+ then do

587+ pure (Nothing, ([], Nothing))

588+ else do

589+ session <- hscEnv <$> use_ GhcSession f

590+ r <- liftIO $ loadInterface session ms deps

591+ case r of

592+ Right iface -> do

593+ let result = HiFileResult ms iface

594+ return (Just (fingerprintToBS (getModuleHash iface)), ([], Just result))

595+ Left err -> do

596+ let diag = ideErrorWithSource (Just "interface file loading") (Just DsError) f . T.pack $ err

597+ return (Nothing, (pure diag, Nothing))

598+

599+getModSummaryRule :: Rules ()

600+getModSummaryRule = define $ \GetModSummary f -> do

601+ dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f

602+ (_, mFileContent) <- getFileContents f

603+ modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $

604+ getModSummaryFromImports (fromNormalizedFilePath f) (textToStringBuffer <$> mFileContent)

605+ return $ either (,Nothing) (([], ) . Just) modS

606+

607+getModIfaceRule :: Rules ()

608+getModIfaceRule = define $ \GetModIface f -> do

609+ fileOfInterest <- use_ IsFileOfInterest f

610+ let useHiFile =

611+ -- Never load interface files for files of interest

612+ not fileOfInterest

613+ mbHiFile <- if useHiFile then use GetHiFile f else return Nothing

614+ case mbHiFile of

615+ Just x ->

616+ return ([], Just x)

617+ Nothing

618+ | fileOfInterest -> do

619+ -- For files of interest only, create a Shake dependency on typecheck

620+ tmr <- use TypeCheck f

621+ return ([], extract tmr)

622+ | otherwise -> do

623+ -- the interface file does not exist or is out of date.

624+ -- Invoke typechecking directly to update it without incurring a dependency

625+ -- on the parsed module and the typecheck rules

626+ sess <- use_ GhcSession f

627+ let hsc = hscEnv sess

628+ -- After parsing the module remove all package imports referring to

629+ -- these packages as we have already dealt with what they map to.

630+ comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)

631+ opt <- getIdeOptions

632+ (_, contents) <- getFileContents f

633+ -- Embed --haddocks in the interface file

634+ hsc <- pure hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock}

635+ (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f contents

636+ case mb_pm of

637+ Nothing -> return (diags, Nothing)

638+ Just pm -> do

639+ (diags', tmr) <- typeCheckRuleDefinition f pm DoGenerateInterfaceFiles

640+ -- Bang pattern is important to avoid leaking 'tmr'

641+ let !res = extract tmr

642+ return (diags <> diags', res)

643+ where

644+ extract Nothing = Nothing

645+ extract (Just tmr) =

646+ -- Bang patterns are important to force the inner fields

647+ Just $! HiFileResult (tmrModSummary tmr) (hm_iface $ tmrModInfo tmr)

348648

349−getHieFileRule :: Rules ()

350−getHieFileRule =

351− defineNoFile $ \(GetHieFile f) -> do

352− u <- liftIO $ mkSplitUniqSupply 'a'

353− let nameCache = initNameCache u []

354− liftIO $ fmap (hie_file_result . fst) $ readHieFile nameCache f

649+isFileOfInterestRule :: Rules ()

650+isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do

651+ filesOfInterest <- getFilesOfInterest

652+ let res = f `elem` filesOfInterest

653+ return (Just (if res then "1" else ""), ([], Just res))

355654

356655-- | A rule that wires per-file rules together

357656mainRule :: Rules ()

@@ -366,4 +665,7 @@ mainRule = do

366665 generateCoreRule

367666 generateByteCodeRule

368667 loadGhcSession

369− getHieFileRule

668+ getHiFileRule

669+ getModIfaceRule

670+ isFileOfInterestRule

671+ getModSummaryRule

src/Development/IDE/Core/Service.hs+4−1

@@ -23,6 +23,7 @@ import Control.Concurrent.Async

2323import Data.Maybe

2424import Development.IDE.Types.Options (IdeOptions(..))

2525import Control.Monad

26+import Development.IDE.Core.Debouncer

2627import Development.IDE.Core.FileStore (VFSHandle, fileStoreRules)

2728import Development.IDE.Core.FileExists (fileExistsRules)

2829import Development.IDE.Core.OfInterest

@@ -49,14 +50,16 @@ initialise :: LSP.ClientCapabilities

4950 -> IO LSP.LspId

5051 -> (LSP.FromServerMessage -> IO ())

5152 -> Logger

53+ -> Debouncer LSP.NormalizedUri

5254 -> IdeOptions

5355 -> VFSHandle

5456 -> IO IdeState

55−initialise caps mainRule getLspId toDiags logger options vfs =

57+initialise caps mainRule getLspId toDiags logger debouncer options vfs =

5658 shakeOpen

5759 getLspId

5860 toDiags

5961 logger

62+ debouncer

6063 (optShakeProfiling options)

6164 (optReportProgress options)

6265 shakeOptions

src/Development/IDE/Core/Shake.hs+94−81

@@ -19,8 +19,8 @@

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,

23− ShakeExtras(..), getShakeExtras,

22+ IdeState, shakeExtras,

23+ ShakeExtras(..), getShakeExtras, getShakeExtrasRules,

2424 IdeRule, IdeResult, GetModificationTime(..),

2525 shakeOpen, shakeShut,

2626 shakeRun,

@@ -30,13 +30,13 @@ module Development.IDE.Core.Shake(

3030 define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,

3131 getDiagnostics, unsafeClearDiagnostics,

3232 getHiddenDiagnostics,

33− IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,

33+ IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,

3434 garbageCollect,

3535 setPriority,

3636 sendEvent,

3737 ideLogger,

3838 actionLogger,

39− FileVersion(..),

39+ FileVersion(..), modificationTime,

4040 Priority(..),

4141 updatePositionMapping,

4242 deleteValue,

@@ -49,12 +49,11 @@ import Development.Shake.Classes

4949import Development.Shake.Rule

5050import qualified Data.HashMap.Strict as HMap

5151import qualified Data.Map.Strict as Map

52−import qualified Data.Map.Merge.Strict as Map

5352import qualified Data.ByteString.Char8 as BS

5453import Data.Dynamic

5554import Data.Maybe

5655import Data.Map.Strict (Map)

57−import Data.List.Extra (foldl', partition, takeEnd)

56+import Data.List.Extra (partition, takeEnd)

5857import qualified Data.Set as Set

5958import qualified Data.Text as T

6059import Data.Traversable (for)

@@ -70,7 +69,7 @@ import Development.IDE.Types.Location

7069import Development.IDE.Types.Options

7170import Control.Concurrent.Async

7271import Control.Concurrent.Extra

73−import Control.Exception

72+import Control.Exception.Extra

7473import Control.DeepSeq

7574import System.Time.Extra

7675import Data.Typeable

@@ -95,13 +94,15 @@ data ShakeExtras = ShakeExtras

9594 ,state :: Var Values

9695 ,diagnostics :: Var DiagnosticStore

9796 ,hiddenDiagnostics :: Var DiagnosticStore

98− ,publishedDiagnostics :: Var (Map NormalizedUri [Diagnostic])

97+ ,publishedDiagnostics :: Var (HMap.HashMap NormalizedUri [Diagnostic])

9998 -- ^ This represents the set of diagnostics that we have published.

10099 -- Due to debouncing not every change might get published.

101− ,positionMapping :: Var (Map NormalizedUri (Map TextDocumentVersion PositionMapping))

100+ ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))

102101 -- ^ Map from a text document version to a PositionMapping that describes how to map

103102 -- positions in a version of that document to positions in the latest version

104− ,inProgress :: Var (Map NormalizedFilePath Int)

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)

105106 -- ^ How many rules are running for each file

106107 }

107108

@@ -115,22 +116,29 @@ getShakeExtrasRules = do

115116 Just x <- getShakeExtraRules @ShakeExtras

116117 return x

117118

118−

119−

120119class Typeable a => IsIdeGlobal a where

121120

122121addIdeGlobal :: IsIdeGlobal a => a -> Rules ()

123−addIdeGlobal x@(typeOf -> ty) = do

124− ShakeExtras{globals} <- getShakeExtrasRules

122+addIdeGlobal x = do

123+ extras <- getShakeExtrasRules

124+ liftIO $ addIdeGlobalExtras extras x

125+

126+addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()

127+addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =

125128 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of

126− Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty

129+ Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty

127130 Nothing -> return $! HMap.insert ty (toDyn x) mp

128131

129132

130133getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a

131134getIdeGlobalExtras ShakeExtras{globals} = do

132− Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals

133− return $ fromDyn x $ error "Serious error, corrupt globals"

135+ let typ = typeRep (Proxy :: Proxy a)

136+ x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals

137+ case x of

138+ Just x

139+ | Just x <- fromDynamic x -> pure x

140+ | otherwise -> errorIO $ "Internal error, getIdeGlobalExtras, wrong type for " ++ show typ ++ " (got " ++ show (dynTypeRep x) ++ ")"

141+ Nothing -> errorIO $ "Internal error, getIdeGlobalExtras, no entry for " ++ show typ

134142

135143getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a

136144getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras

@@ -153,7 +161,7 @@ instance Eq Key where

153161 | otherwise = False

154162

155163instance Hashable Key where

156− hashWithSalt salt (Key key) = hashWithSalt salt key

164+ hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)

157165

158166-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,

159167-- and a value is in the Maybe. For operations that throw an error you

@@ -163,9 +171,6 @@ instance Hashable Key where

163171-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh

164172-- errors but still failed.

165173--

166−-- A rule on a file should only return diagnostics for that given file. It should

167−-- not propagate diagnostic errors through multiple phases.

168−type IdeResult v = ([FileDiagnostic], Maybe v)

169174

170175data Value v

171176 = Succeeded TextDocumentVersion v

@@ -200,14 +205,14 @@ valueVersion = \case

200205 Failed -> Nothing

201206

202207mappingForVersion

203− :: Map NormalizedUri (Map TextDocumentVersion PositionMapping)

208+ :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))

204209 -> NormalizedFilePath

205210 -> TextDocumentVersion

206211 -> PositionMapping

207212mappingForVersion allMappings file ver =

208− fromMaybe idMapping $

213+ maybe zeroMapping snd $

209214 Map.lookup ver =<<

210− Map.lookup (filePathToUri' file) allMappings

215+ HMap.lookup (filePathToUri' file) allMappings

211216

212217type IdeRule k v =

213218 ( Shake.RuleResult k ~ v

@@ -238,7 +243,6 @@ shakeRunDatabaseProfile mbProfileDir shakeDb acts = do

238243 shakeProfileDatabase shakeDb $ dir </> file

239244 return (dir </> file)

240245 return (res, proFile)

241− where

242246

243247{-# NOINLINE profileStartTime #-}

244248profileStartTime :: String

@@ -294,21 +298,21 @@ seqValue v b = case v of

294298shakeOpen :: IO LSP.LspId

295299 -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler

296300 -> Logger

301+ -> Debouncer NormalizedUri

297302 -> Maybe FilePath

298303 -> IdeReportProgress

299304 -> ShakeOptions

300305 -> Rules ()

301306 -> IO IdeState

302−shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do

303− inProgress <- newVar Map.empty

307+shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) opts rules = do

308+ inProgress <- newVar HMap.empty

304309 shakeExtras <- do

305310 globals <- newVar HMap.empty

306311 state <- newVar HMap.empty

307312 diagnostics <- newVar mempty

308313 hiddenDiagnostics <- newVar mempty

309314 publishedDiagnostics <- newVar mempty

310− debouncer <- newDebouncer

311− positionMapping <- newVar Map.empty

315+ positionMapping <- newVar HMap.empty

312316 pure ShakeExtras{..}

313317 (shakeDb, shakeClose) <-

314318 shakeOpenDatabase

@@ -323,7 +327,7 @@ shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgr

323327 shakeDb <- shakeDb

324328 return IdeState{..}

325329

326−lspShakeProgress :: Show a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (Map a Int) -> IO ()

330+lspShakeProgress :: Hashable a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (HMap.HashMap a Int) -> IO ()

327331lspShakeProgress getLspId sendMsg inProgress = do

328332 -- first sleep a bit, so we only show progress messages if it's going to take

329333 -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)

@@ -356,8 +360,8 @@ lspShakeProgress getLspId sendMsg inProgress = do

356360 loop id prev = do

357361 sleep sample

358362 current <- readVar inProgress

359− let done = length $ filter (== 0) $ Map.elems current

360− let todo = Map.size current

363+ let done = length $ filter (== 0) $ HMap.elems current

364+ let todo = HMap.size current

361365 let next = Just $ T.pack $ show done <> "/" <> show todo

362366 when (next /= prev) $

363367 sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification

@@ -413,8 +417,8 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =

413417 Right _ -> "completed"

414418 profile = case res of

415419 Right (_, Just fp) ->

416− let link = case filePathToUri' $ toNormalizedFilePath fp of

417− NormalizedUri x -> x

420+ let link = case filePathToUri' $ toNormalizedFilePath' fp of

421+ NormalizedUri _ x -> x

418422 in ", profile saved at " <> T.unpack link

419423 _ -> ""

420424 let logMsg = logDebug logger $ T.pack $

@@ -452,9 +456,9 @@ garbageCollect keep = do

452456 return $! dupe values

453457 modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags

454458 modifyVar_ hiddenDiagnostics $ \hdiags -> return $! filterDiagnostics keep hdiags

455− modifyVar_ publishedDiagnostics $ \diags -> return $! Map.filterWithKey (\uri _ -> keep (fromUri uri)) diags

459+ modifyVar_ publishedDiagnostics $ \diags -> return $! HMap.filterWithKey (\uri _ -> keep (fromUri uri)) diags

456460 let versionsForFile =

457− Map.fromListWith Set.union $

461+ HMap.fromListWith Set.union $

458462 mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $

459463 HMap.toList newState

460464 modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings

@@ -472,25 +476,25 @@ useWithStale :: IdeRule k v

472476useWithStale key file = head <$> usesWithStale key [file]

473477

474478useNoFile :: IdeRule k v => k -> Action (Maybe v)

475−useNoFile key = use key ""

479+useNoFile key = use key emptyFilePath

476480

477481use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v

478482use_ key file = head <$> uses_ key [file]

479483

480484useNoFile_ :: IdeRule k v => k -> Action v

481−useNoFile_ key = use_ key ""

485+useNoFile_ key = use_ key emptyFilePath

482486

483487uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]

484488uses_ key files = do

485489 res <- uses key files

486490 case sequence res of

487− Nothing -> liftIO $ throwIO BadDependency

491+ Nothing -> liftIO $ throwIO $ BadDependency (show key)

488492 Just v -> return v

489493

490494

491495-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency

492496-- which short-circuits the rest of the action

493−data BadDependency = BadDependency deriving Show

497+data BadDependency = BadDependency String deriving Show

494498instance Exception BadDependency

495499

496500isBadDependency :: SomeException -> Bool

@@ -509,12 +513,10 @@ instance Show k => Show (Q k) where

509513

510514-- | Invariant: the 'v' must be in normal form (fully evaluated).

511515-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database

512−-- Note (MK) I am not sure why we need the ShakeValue here, maybe we

513−-- can just remove it?

514−data A v = A (Value v) ShakeValue

516+newtype A v = A (Value v)

515517 deriving Show

516518

517−instance NFData (A v) where rnf (A v x) = v `seq` rnf x

519+instance NFData (A v) where rnf (A v) = v `seq` ()

518520

519521-- In the Shake database we only store one type of key/result pairs,

520522-- namely Q (question) / A (answer).

@@ -524,19 +526,22 @@ type instance RuleResult (Q k) = A (RuleResult k)

524526-- | Return up2date results. Stale results will be ignored.

525527uses :: IdeRule k v

526528 => k -> [NormalizedFilePath] -> Action [Maybe v]

527−uses key files = map (\(A value _) -> currentValue value) <$> apply (map (Q . (key,)) files)

529+uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files)

528530

529531-- | Return the last computed result which might be stale.

530532usesWithStale :: IdeRule k v

531533 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]

532534usesWithStale key files = do

533− values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)

534− mapM (uncurry lastValue) (zip files values)

535+ values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files)

536+ zipWithM lastValue files values

535537

536538

537−withProgress :: Ord a => Var (Map a Int) -> a -> Action b -> Action b

539+withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b

538540withProgress var file = actionBracket (f succ) (const $ f pred) . const

539− where f shift = modifyVar_ var $ return . Map.alter (Just . shift . fromMaybe 0) file

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

540545

541546

542547defineEarlyCutoff

@@ -553,16 +558,16 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old

553558 case v of

554559 -- No changes in the dependencies and we have

555560 -- an existing result.

556− Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)

561+ Just v -> return $ Just $ RunResult ChangedNothing old $ A v

557562 _ -> return Nothing

558563 _ -> return Nothing

559564 case val of

560565 Just res -> return res

561566 Nothing -> do

562567 (bs, (diags, res)) <- actionCatch

563− (do v <- op key file; liftIO $ evaluate $ force $ v) $

568+ (do v <- op key file; liftIO $ evaluate $ force v) $

564569 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))

565− modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file

570+ modTime <- liftIO $ (currentValue =<<) <$> getValues state GetModificationTime file

566571 (bs, res) <- case res of

567572 Nothing -> do

568573 staleV <- liftIO $ getValues state key file

@@ -572,7 +577,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old

572577 Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)

573578 Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)

574579 Failed -> (toShakeValue ShakeResult bs, Failed)

575− Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)

580+ Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)

576581 liftIO $ setValues state key file res

577582 updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags

578583 let eq = case (bs, fmap decodeShakeValue old) of

@@ -584,7 +589,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old

584589 return $ RunResult

585590 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)

586591 (encodeShakeValue bs) $

587− A res bs

592+ A res

588593

589594

590595-- | Rule type, input file

@@ -655,12 +660,12 @@ defineOnDisk act = addBuiltinRule noLint noIdentity $

655660needOnDisk :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> NormalizedFilePath -> Action ()

656661needOnDisk k file = do

657662 successfull <- apply1 (QDisk k file)

658− liftIO $ unless successfull $ throwIO BadDependency

663+ liftIO $ unless successfull $ throwIO $ BadDependency (show k)

659664

660665needOnDisks :: (Shake.ShakeValue k, RuleResult k ~ ()) => k -> [NormalizedFilePath] -> Action ()

661666needOnDisks k files = do

662667 successfulls <- apply $ map (QDisk k) files

663− liftIO $ unless (and successfulls) $ throwIO BadDependency

668+ liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k)

664669

665670toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue

666671toShakeValue = maybe ShakeNoCutoff

@@ -699,7 +704,7 @@ updateFileDiagnostics ::

699704 -> [(ShowDiagnostic,Diagnostic)] -- ^ current results

700705 -> Action ()

701706updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do

702− modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp

707+ modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp

703708 let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current

704709 mask_ $ do

705710 -- Mask async exceptions to ensure that updated diagnostics are always

@@ -712,7 +717,7 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, published

712717 let newDiags = getFileDiagnostics fp newDiagsStore

713718 _ <- evaluate newDiagsStore

714719 _ <- evaluate newDiags

715− pure $! (newDiagsStore, newDiags)

720+ pure (newDiagsStore, newDiags)

716721 modifyVar_ hiddenDiagnostics $ \old -> do

717722 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)

718723 (T.pack $ show k) (map snd currentHidden) old

@@ -724,10 +729,10 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, published

724729 let delay = if null newDiags then 0.1 else 0

725730 registerEvent debouncer delay uri $ do

726731 mask_ $ modifyVar_ publishedDiagnostics $ \published -> do

727− let lastPublish = Map.findWithDefault [] uri published

732+ let lastPublish = HMap.lookupDefault [] uri published

728733 when (lastPublish /= newDiags) $

729734 eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags

730− pure $! Map.insert uri newDiags published

735+ pure $! HMap.insert uri newDiags published

731736

732737publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage

733738publishDiagnosticsNotification uri diags =

@@ -738,7 +743,7 @@ publishDiagnosticsNotification uri diags =

738743newtype Priority = Priority Double

739744

740745setPriority :: Priority -> Action ()

741−setPriority (Priority p) = deprioritize p

746+setPriority (Priority p) = reschedule p

742747

743748sendEvent :: LSP.FromServerMessage -> Action ()

744749sendEvent e = do

@@ -763,19 +768,22 @@ instance Binary GetModificationTime

763768-- | Get the modification time of a file.

764769type instance RuleResult GetModificationTime = FileVersion

765770

766−-- | We store the modification time as a ByteString since we need

767−-- a ByteString anyway for Shake and we do not care about how times

768−-- are represented.

769−data FileVersion = VFSVersion Int | ModificationTime BS.ByteString

771+data FileVersion

772+ = VFSVersion !Int

773+ | ModificationTime

774+ !Int -- ^ Large unit (platform dependent, do not make assumptions)

775+ !Int -- ^ Small unit (platform dependent, do not make assumptions)

770776 deriving (Show, Generic)

771777

772778instance NFData FileVersion

773779

774780vfsVersion :: FileVersion -> Maybe Int

775781vfsVersion (VFSVersion i) = Just i

776−vfsVersion (ModificationTime _) = Nothing

777−

782+vfsVersion ModificationTime{} = Nothing

778783

784+modificationTime :: FileVersion -> Maybe (Int, Int)

785+modificationTime VFSVersion{} = Nothing

786+modificationTime (ModificationTime large small) = Just (large, small)

779787

780788getDiagnosticsFromStore :: StoreItem -> [Diagnostic]

781789getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags

@@ -800,7 +808,7 @@ getAllDiagnostics ::

800808 DiagnosticStore ->

801809 [FileDiagnostic]

802810getAllDiagnostics =

803− concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . Map.toList

811+ concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList

804812

805813getFileDiagnostics ::

806814 NormalizedFilePath ->

@@ -808,29 +816,34 @@ getFileDiagnostics ::

808816 [LSP.Diagnostic]

809817getFileDiagnostics fp ds =

810818 maybe [] getDiagnosticsFromStore $

811− Map.lookup (filePathToUri' fp) ds

819+ HMap.lookup (filePathToUri' fp) ds

812820

813821filterDiagnostics ::

814822 (NormalizedFilePath -> Bool) ->

815823 DiagnosticStore ->

816824 DiagnosticStore

817825filterDiagnostics keep =

818− Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)

826+ HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri)

819827

820828filterVersionMap

821− :: Map NormalizedUri (Set.Set TextDocumentVersion)

822− -> Map NormalizedUri (Map TextDocumentVersion a)

823− -> Map NormalizedUri (Map TextDocumentVersion a)

829+ :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)

830+ -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)

831+ -> HMap.HashMap NormalizedUri (Map TextDocumentVersion a)

824832filterVersionMap =

825− Map.merge Map.dropMissing Map.dropMissing $

826− Map.zipWithMatched $ \_ versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep

833+ HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep

827834

828835updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()

829−updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do

836+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do

830837 modifyVar_ positionMapping $ \allMappings -> do

831838 let uri = toNormalizedUri _uri

832− let mappingForUri = Map.findWithDefault Map.empty uri allMappings

833− let updatedMapping =

834− Map.insert _version idMapping $

835− Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri

836− pure $! Map.insert uri updatedMapping allMappings

839+ let mappingForUri = HMap.lookupDefault Map.empty uri allMappings

840+ let (_, updatedMapping) =

841+ -- Very important to use mapAccum here so that the tails of

842+ -- each mapping can be shared, otherwise quadratic space is

843+ -- used which is evident in long running sessions.

844+ Map.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc)))

845+ zeroMapping

846+ (Map.insert _version (shared_change, zeroMapping) mappingForUri)

847+ pure $! HMap.insert uri updatedMapping allMappings

848+ where

849+ shared_change = mkDelta changes

src/Development/IDE/GHC/CPP.hs+26−1

@@ -19,7 +19,8 @@

1919--

2020-----------------------------------------------------------------------------

2121

22−module Development.IDE.GHC.CPP(doCpp) where

22+module Development.IDE.GHC.CPP(doCpp, addOptP)

23+where

2324

2425import Development.IDE.GHC.Compat

2526import Packages

@@ -33,6 +34,10 @@ import LlvmCodeGen (llvmVersionList)

3334#elif MIN_GHC_API_VERSION(8,8,0)

3435import LlvmCodeGen (LlvmVersion (..))

3536#endif

37+#if MIN_GHC_API_VERSION (8,10,0)

38+import Fingerprint

39+import ToolSettings

40+#endif

3641

3742import System.Directory

3843import System.FilePath

@@ -59,7 +64,11 @@ doCpp dflags raw input_fn output_fn = do

5964 let verbFlags = getVerbFlags dflags

6065

6166 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

6270 | otherwise = SysTools.runCc

71+#endif

6372 dflags (SysTools.Option "-E" : args)

6473

6574 let target_defs =

@@ -158,6 +167,22 @@ getBackendDefs dflags | hscTarget dflags == HscLlvm = do

158167getBackendDefs _ =

159168 return []

160169

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+

161186-- ---------------------------------------------------------------------------

162187-- Macros (cribbed from Cabal)

163188

src/Development/IDE/GHC/Compat.hs+189−19

@@ -7,22 +7,38 @@

88-- | Attempt at hiding the GHC version differences we can.

99module Development.IDE.GHC.Compat(

10+ getHeaderImports,

1011 HieFileResult(..),

11− HieFile(..),

12+ HieFile,

13+ hieExportNames,

14+ hie_module,

1215 mkHieFile,

1316 writeHieFile,

1417 readHieFile,

18+ supportsHieFiles,

19+ setDefaultHieDir,

20+ dontWriteHieFiles,

21+#if !MIN_GHC_API_VERSION(8,8,0)

22+ ml_hie_file,

23+#endif

1524 hPutStringBuffer,

1625 includePathsGlobal,

1726 includePathsQuote,

1827 addIncludePathsQuote,

28+ getModuleHash,

29+ getPackageName,

1930 pattern DerivD,

2031 pattern ForD,

2132 pattern InstD,

2233 pattern TyClD,

2334 pattern ValD,

2435 pattern ClassOpSig,

36+ pattern IEThingAll,

2537 pattern IEThingWith,

38+ GHC.ModLocation,

39+ Module.addBootSuffix,

40+ pattern ModLocation,

41+ getConArgs,

2642

2743 module GHC

2844 ) where

@@ -30,41 +46,62 @@ module Development.IDE.GHC.Compat(

3046import StringBuffer

3147import DynFlags

3248import FieldLabel

49+import Fingerprint (Fingerprint)

50+import qualified Module

51+import Packages

3352

3453import qualified GHC

35−import GHC hiding (ClassOpSig, DerivD, ForD, IEThingWith, InstD, TyClD, ValD)

54+import GHC hiding (

55+ ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation

56+#if MIN_GHC_API_VERSION(8,6,0)

57+ , getConArgs

58+#endif

59+ )

60+import qualified HeaderInfo as Hdr

61+import Avail

62+import ErrUtils (ErrorMessages)

63+import FastString (FastString)

64+

65+#if MIN_GHC_API_VERSION(8,10,0)

66+import HscTypes (mi_mod_hash)

67+#endif

3668

3769#if MIN_GHC_API_VERSION(8,8,0)

38−import HieAst

70+import Control.Applicative ((<|>))

71+import Development.IDE.GHC.HieAst (mkHieFile)

3972import HieBin

4073import HieTypes

74+

75+supportsHieFiles :: Bool

76+supportsHieFiles = True

77+

78+hieExportNames :: HieFile -> [(SrcSpan, Name)]

79+hieExportNames = nameListFromAvails . hie_exports

80+

4181#else

42−import GhcPlugins

82+

83+#if MIN_GHC_API_VERSION(8,6,0)

84+import BinIface

85+import Data.IORef

86+import IfaceEnv

87+#endif

88+

89+import Binary

90+import Control.Exception (catch)

91+import Data.ByteString (ByteString)

92+import GhcPlugins hiding (ModLocation)

4393import NameCache

44−import Avail

4594import TcRnTypes

4695import System.IO

4796import Foreign.ForeignPtr

97+import MkIface

4898

4999

50−#if !MIN_GHC_API_VERSION(8,8,0)

51100hPutStringBuffer :: Handle -> StringBuffer -> IO ()

52101hPutStringBuffer hdl (StringBuffer buf len cur)

53102 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->

54103 hPutBuf hdl ptr len

55−#endif

56−

57−mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile

58−mkHieFile _ _ _ = return (HieFile () [])

59−

60−writeHieFile :: FilePath -> HieFile -> IO ()

61−writeHieFile _ _ = return ()

62104

63−readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())

64−readHieFile _ _ = return (HieFileResult (HieFile () []), ())

65−

66−data HieFile = HieFile {hie_module :: (), hie_exports :: [AvailInfo]}

67−data HieFileResult = HieFileResult { hie_file_result :: HieFile }

68105#endif

69106

70107#if !MIN_GHC_API_VERSION(8,6,0)

@@ -136,4 +173,137 @@ pattern IEThingWith a b c d <-

136173 GHC.IEThingWith _ a b c d

137174#else

138175 GHC.IEThingWith a b c d

139−#endif

176+#endif

177+

178+pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation

179+pattern ModLocation a b c <-

180+#if MIN_GHC_API_VERSION(8,8,0)

181+ GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c ""

182+#else

183+ GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c

184+#endif

185+

186+pattern IEThingAll :: LIEWrappedName (IdP pass) -> IE pass

187+pattern IEThingAll a <-

188+#if MIN_GHC_API_VERSION(8,6,0)

189+ GHC.IEThingAll _ a

190+#else

191+ GHC.IEThingAll a

192+#endif

193+

194+setDefaultHieDir :: FilePath -> DynFlags -> DynFlags

195+setDefaultHieDir _f d =

196+#if MIN_GHC_API_VERSION(8,8,0)

197+ d { hieDir = hieDir d <|> Just _f}

198+#else

199+ d

200+#endif

201+

202+dontWriteHieFiles :: DynFlags -> DynFlags

203+dontWriteHieFiles d =

204+#if MIN_GHC_API_VERSION(8,8,0)

205+ gopt_unset d Opt_WriteHie

206+#else

207+ d

208+#endif

209+

210+nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)]

211+nameListFromAvails as =

212+ map (\n -> (nameSrcSpan n, n)) (concatMap availNames as)

213+

214+#if !MIN_GHC_API_VERSION(8,8,0)

215+-- Reimplementations of functions for HIE files for GHC 8.6

216+

217+mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> ByteString -> Hsc HieFile

218+mkHieFile ms ts _ _ = return (HieFile (ms_mod ms) es)

219+ where

220+ es = nameListFromAvails (mkIfaceExports (tcg_exports ts))

221+

222+ml_hie_file :: GHC.ModLocation -> FilePath

223+ml_hie_file ml = ml_hi_file ml ++ ".hie"

224+

225+data HieFile = HieFile {hie_module :: Module, hie_exports :: [(SrcSpan, Name)]}

226+

227+hieExportNames :: HieFile -> [(SrcSpan, Name)]

228+hieExportNames = hie_exports

229+

230+instance Binary HieFile where

231+ put_ bh (HieFile m es) = do

232+ put_ bh m

233+ put_ bh es

234+

235+ get bh = do

236+ mod <- get bh

237+ es <- get bh

238+ return (HieFile mod es)

239+

240+data HieFileResult = HieFileResult { hie_file_result :: HieFile }

241+

242+writeHieFile :: FilePath -> HieFile -> IO ()

243+readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())

244+supportsHieFiles :: Bool

245+

246+#if MIN_GHC_API_VERSION(8,6,0)

247+

248+writeHieFile fp hie = do

249+ bh <- openBinMem (1024 * 1024)

250+ putWithUserData (const $ return ()) bh hie

251+ writeBinMem bh fp

252+

253+readHieFile nc fp = do

254+ bh <- readBinMem fp

255+ nc' <- newIORef nc

256+ hie_file <- getWithUserData (NCU (atomicModifyIORef' nc')) bh

257+ return (HieFileResult hie_file, ())

258+

259+supportsHieFiles = True

260+

261+#else

262+

263+supportsHieFiles = False

264+

265+writeHieFile _ _ = return ()

266+

267+readHieFile _ _ = return undefined

268+

269+#endif

270+

271+#endif

272+

273+getHeaderImports

274+ :: DynFlags

275+ -> StringBuffer

276+ -> FilePath

277+ -> FilePath

278+ -> IO

279+ ( Either

280+ ErrorMessages

281+ ( [(Maybe FastString, Located ModuleName)]

282+ , [(Maybe FastString, Located ModuleName)]

283+ , Located ModuleName

284+ )

285+ )

286+#if MIN_GHC_API_VERSION(8,8,0)

287+getHeaderImports = Hdr.getImports

288+#else

289+getHeaderImports a b c d =

290+ catch (Right <$> Hdr.getImports a b c d)

291+ (return . Left . srcErrorMessages)

292+#endif

293+

294+getModuleHash :: ModIface -> Fingerprint

295+#if MIN_GHC_API_VERSION(8,10,0)

296+getModuleHash = mi_mod_hash . mi_final_exts

297+#else

298+getModuleHash = mi_mod_hash

299+#endif

300+

301+getConArgs :: ConDecl pass -> HsConDeclDetails pass

302+#if MIN_GHC_API_VERSION(8,6,0)

303+getConArgs = GHC.getConArgs

304+#else

305+getConArgs = GHC.getConDetails

306+#endif

307+

308+getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName

309+getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i))

src/Development/IDE/GHC/Error.hs+27−4

@@ -9,6 +9,7 @@ module Development.IDE.GHC.Error

99 , diagFromStrings

1010 , diagFromGhcException

1111 , catchSrcErrors

12+ , mergeDiagnostics

1213

1314 -- * utilities working with spans

1415 , srcSpanToLocation

@@ -36,11 +37,12 @@ import Panic

3637import ErrUtils

3738import SrcLoc

3839import qualified Outputable as Out

40+import Exception (ExceptionMonad)

3941

4042

4143

4244diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic

43−diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename loc,ShowDiag,)

45+diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ srcSpanToFilename loc,ShowDiag,)

4446 Diagnostic

4547 { _range = srcSpanToRange loc

4648 , _severity = Just sev

@@ -48,18 +50,39 @@ diagFromText diagSource sev loc msg = (toNormalizedFilePath $ srcSpanToFilename

4850 , _message = msg

4951 , _code = Nothing

5052 , _relatedInformation = Nothing

53+ , _tags = Nothing

5154 }

5255

5356-- | Produce a GHC-style error from a source span and a message.

5457diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic]

5558diagFromErrMsg diagSource dflags e =

56− [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $ ErrUtils.pprLocErrMsg e

59+ [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ Out.showSDoc dflags $

60+ ErrUtils.formatErrDoc dflags $ ErrUtils.errMsgDoc e

5761 | Just sev <- [toDSeverity $ errMsgSeverity e]]

5862

5963

6064diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]

6165diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList

6266

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

6386

6487-- | Convert a GHC SrcSpan to a DAML compiler Range

6588srcSpanToRange :: SrcSpan -> Range

@@ -80,7 +103,7 @@ srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real

80103srcSpanToLocation :: SrcSpan -> Location

81104srcSpanToLocation src =

82105 -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code

83− Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath $ srcSpanToFilename src) (srcSpanToRange src)

106+ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ srcSpanToFilename src) (srcSpanToRange src)

84107

85108isInsideSrcSpan :: Position -> SrcSpan -> Bool

86109p `isInsideSrcSpan` r = sp <= p && p <= ep

@@ -127,7 +150,7 @@ realSpan = \case

127150

128151-- | Run something in a Ghc monad and catch the errors (SourceErrors and

129152-- compiler-internal exceptions like Panic or InstallationError).

130−catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)

153+catchSrcErrors :: (HasDynFlags m, ExceptionMonad m) => T.Text -> m a -> m (Either [FileDiagnostic] a)

131154catchSrcErrors fromWhere ghcM = do

132155 dflags <- getDynFlags

133156 handleGhcException (ghcExceptionToDiagnostics dflags) $

src/Development/IDE/GHC/Orphans.hs+10−3

@@ -1,8 +1,10 @@

22-- SPDX-License-Identifier: Apache-2.0

4+{-# LANGUAGE CPP #-}

45{-# LANGUAGE FlexibleInstances #-}

56{-# OPTIONS_GHC -Wno-orphans #-}

7+#include "ghc-api-version.h"

79-- | Orphan instances for GHC.

810-- Note that the 'NFData' instances may not be law abiding.

@@ -31,7 +33,7 @@ instance NFData Linkable where rnf = rwhnf

3133instance Show InstalledUnitId where

3234 show = installedUnitIdString

3335

34−instance NFData InstalledUnitId where rnf = rwhnf

36+instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS

3537

3638instance NFData SB.StringBuffer where rnf = rwhnf

3739

@@ -40,8 +42,8 @@ instance Show Module where

4042

4143instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint

4244

43−instance NFData (GenLocated SrcSpan ModuleName) where

44− rnf = rwhnf

45+instance (NFData l, NFData e) => NFData (GenLocated l e) where

46+ rnf (L l e) = rnf l `seq` rnf e

4547

4648instance Show ModSummary where

4749 show = show . ms_mod

@@ -52,6 +54,11 @@ instance Show ParsedModule where

5254instance NFData ModSummary where

5355 rnf = rwhnf

5456

57+#if !MIN_GHC_API_VERSION(8,10,0)

58+instance NFData FastString where

59+ rnf = rwhnf

60+#endif

61+

5562instance NFData ParsedModule where

5663 rnf = rwhnf

5764

src/Development/IDE/GHC/Util.hs+102−53

@@ -1,42 +1,44 @@

22-- SPDX-License-Identifier: Apache-2.0

4−{-# OPTIONS_GHC -Wno-missing-fields #-} -- to enable prettyPrint

5−{-# LANGUAGE CPP #-}

6−#include "ghc-api-version.h"

7−

84-- | General utility functions, mostly focused around GHC operations.

95module Development.IDE.GHC.Util(

106 -- * HcsEnv and environment

11− HscEnvEq, hscEnv, newHscEnvEq,

7+ HscEnvEq(GhcVersionMismatch, compileTime, runTime), hscEnv, newHscEnvEq,

128 modifyDynFlags,

13− fakeDynFlags,

9+ evalGhcEnv,

1410 runGhcEnv,

11+ deps,

1512 -- * GHC wrappers

1613 prettyPrint,

14+ printRdrName,

15+ printName,

16+ ParseResult(..), runParser,

1717 lookupPackageConfig,

18+ textToStringBuffer,

19+ stringBufferToByteString,

1820 moduleImportPath,

1921 cgGutsToCoreModule,

2022 fingerprintToBS,

2123 fingerprintFromStringBuffer,

2224 -- * General utilities

23− textToStringBuffer,

2425 readFileUtf8,

2526 hDuplicateTo',

27+ setDefaultHieDir,

28+ dontWriteHieFiles

2629 ) where

2730

28−import Config

2931import Control.Concurrent

3032import Data.List.Extra

33+import Data.ByteString.Internal (ByteString(..))

3134import Data.Maybe

3235import Data.Typeable

3336import qualified Data.ByteString.Internal as BS

3437import Fingerprint

35−import GHC

3638import GhcMonad

37−import GhcPlugins hiding (Unique)

38−import Data.IORef

3939import Control.Exception

40+import Data.IORef

41+import Data.Version (showVersion, Version)

4042import FileCleanup

4143import Foreign.Ptr

4244import Foreign.ForeignPtr

@@ -47,16 +49,27 @@ import GHC.IO.Encoding

4749import GHC.IO.Exception

4850import GHC.IO.Handle.Types

4951import GHC.IO.Handle.Internals

50−import Platform

5152import Data.Unique

5253import Development.Shake.Classes

5354import qualified Data.Text as T

5455import qualified Data.Text.Encoding as T

5556import qualified Data.Text.Encoding.Error as T

5657import qualified Data.ByteString as BS

58+import Lexer

5759import StringBuffer

5860import 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)

5971

72+import Development.IDE.GHC.Compat as GHC

6073import Development.IDE.Types.Location

6174

6275

@@ -89,87 +102,123 @@ lookupPackageConfig unitId env =

89102textToStringBuffer :: T.Text -> StringBuffer

90103textToStringBuffer = stringToStringBuffer . T.unpack

91104

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

92115

93−-- | Pretty print a GHC value using 'fakeDynFlags'.

116+-- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.

94117prettyPrint :: Outputable a => a -> String

95−prettyPrint = showSDoc fakeDynFlags . ppr

118+prettyPrint = showSDoc unsafeGlobalDynFlags . ppr

119+

120+-- | Pretty print a 'RdrName' wrapping operators in parens

121+printRdrName :: RdrName -> String

122+printRdrName name = showSDocUnsafe $ parenSymOcc rn (ppr rn)

123+ where

124+ rn = rdrNameOcc name

125+

126+-- | Pretty print a 'Name' wrapping operators in parens

127+printName :: Name -> String

128+printName = printRdrName . nameRdrName

96129

97130-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required

98131-- pieces, but designed to be more efficient than a standard 'runGhc'.

99−runGhcEnv :: HscEnv -> Ghc a -> IO a

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)

100138runGhcEnv env act = do

101139 filesToClean <- newIORef emptyFilesToClean

102140 dirsToClean <- newIORef mempty

103141 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}

104142 ref <- newIORef env{hsc_dflags=dflags}

105− unGhc act (Session ref) `finally` do

143+ res <- unGhc act (Session ref) `finally` do

106144 cleanTempFiles dflags

107145 cleanTempDirs dflags

108−

109−-- | A 'DynFlags' value where most things are undefined. It's sufficient to call pretty printing,

110−-- but not much else.

111−fakeDynFlags :: DynFlags

112−fakeDynFlags = defaultDynFlags settings mempty

113− where

114− settings = Settings

115− { sTargetPlatform = platform

116− , sPlatformConstants = platformConstants

117− , sProgramName = "ghc"

118− , sProjectVersion = cProjectVersion

119−#if MIN_GHC_API_VERSION(8,6,0)

120− , sOpt_P_fingerprint = fingerprint0

121−#endif

122− }

123− platform = Platform

124− { platformWordSize=8

125− , platformOS=OSUnknown

126− , platformUnregisterised=True

127− }

128− platformConstants = PlatformConstants

129− { pc_DYNAMIC_BY_DEFAULT=False

130− , pc_WORD_SIZE=8

131− }

146+ (,res) <$> readIORef ref

132147

133148-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.

134149-- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory

135150-- @\/usr\/Test@ should be on the include path to find sibling modules.

136−moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath

151+moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath

137152-- The call to takeDirectory is required since DAML does not require that

138153-- the file name matches the module name in the last component.

139154-- Once that has changed we can get rid of this.

140−moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm

155+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn

141156 -- This happens for single-component modules since takeDirectory "A" == "."

142157 | modDir == "." = Just pathDir

143158 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir

144159 where

145− ms = GHC.pm_mod_summary pm

146− mod' = GHC.ms_mod ms

147160 -- A for module A.B

148161 modDir =

149162 takeDirectory $

150− fromNormalizedFilePath $ toNormalizedFilePath $

151− moduleNameSlashes $ GHC.moduleName mod'

163+ fromNormalizedFilePath $ toNormalizedFilePath' $

164+ moduleNameSlashes mn

152165

153166-- | An 'HscEnv' with equality. Two values are considered equal

154167-- if they are created with the same call to 'newHscEnvEq'.

155−data HscEnvEq = HscEnvEq Unique HscEnv

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+ }

156176

157177-- | Unwrap an 'HsEnvEq'.

158178hscEnv :: HscEnvEq -> HscEnv

159−hscEnv (HscEnvEq _ x) = x

179+hscEnv = either error id . hscEnv'

180+

181+hscEnv' :: HscEnvEq -> Either String HscEnv

182+hscEnv' (HscEnvEq _ x _) = Right x

183+hscEnv' GhcVersionMismatch{..} = Left $

184+ unwords

185+ ["ghcide compiled against GHC"

186+ ,showVersion compileTime

187+ ,"but currently using"

188+ ,showVersion runTime

189+ ,". This is unsupported, ghcide must be compiled with the same GHC version as the project."

190+ ]

191+

192+deps :: HscEnvEq -> [(InstalledUnitId, DynFlags)]

193+deps (HscEnvEq _ _ u) = u

194+deps GhcVersionMismatch{} = []

160195

161196-- | Wrap an 'HscEnv' into an 'HscEnvEq'.

162−newHscEnvEq :: HscEnv -> IO HscEnvEq

163−newHscEnvEq e = do u <- newUnique; return $ HscEnvEq u e

197+newHscEnvEq :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq

198+newHscEnvEq e uids = do u <- newUnique; return $ HscEnvEq u e uids

164199

165200instance Show HscEnvEq where

166− show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)

201+ show (HscEnvEq a _ _) = "HscEnvEq " ++ show (hashUnique a)

202+ show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)

167203

168204instance Eq HscEnvEq where

169− HscEnvEq a _ == HscEnvEq b _ = a == b

205+ HscEnvEq a _ _ == HscEnvEq b _ _ = a == b

206+ GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d

207+ _ == _ = False

170208

171209instance NFData HscEnvEq where

172− rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()

210+ rnf (HscEnvEq a b c) = rnf (hashUnique a) `seq` b `seq` c `seq` ()

211+ rnf GhcVersionMismatch{} = rnf runTime

212+

213+instance Hashable HscEnvEq where

214+ hashWithSalt s (HscEnvEq a _b _c) = hashWithSalt s a

215+ hashWithSalt salt GhcVersionMismatch{..} = hashWithSalt salt (compileTime, runTime)

216+

217+-- Fake instance needed to persuade Shake to accept this type as a key.

218+-- No harm done as ghcide never persists these keys currently

219+instance Binary HscEnvEq where

220+ put _ = error "not really"

221+ get = error "not really"

173222

174223-- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error.

175224readFileUtf8 :: FilePath -> IO T.Text

src/Development/IDE/GHC/WithDynFlags.hsnew file+30

@@ -0,0 +1,30 @@

1+module Development.IDE.GHC.WithDynFlags

2+( WithDynFlags

3+, evalWithDynFlags

4+) where

6+import Control.Monad.Trans.Reader (ask, ReaderT(..))

7+import GHC (DynFlags)

8+import Control.Monad.IO.Class (MonadIO)

9+import Exception (ExceptionMonad(..))

10+import Control.Monad.Trans.Class (MonadTrans(..))

11+import GhcPlugins (HasDynFlags(..))

12+

13+-- | A monad transformer implementing the 'HasDynFlags' effect

14+newtype WithDynFlags m a = WithDynFlags {withDynFlags :: ReaderT DynFlags m a}

15+ deriving (Applicative, Functor, Monad, MonadIO, MonadTrans)

16+

17+evalWithDynFlags :: DynFlags -> WithDynFlags m a -> m a

18+evalWithDynFlags dflags = flip runReaderT dflags . withDynFlags

19+

20+instance Monad m => HasDynFlags (WithDynFlags m) where

21+ getDynFlags = WithDynFlags ask

22+

23+instance ExceptionMonad m => ExceptionMonad (WithDynFlags m) where

24+ gmask f = WithDynFlags $ ReaderT $ \env ->

25+ gmask $ \restore ->

26+ let restore' = lift . restore . flip runReaderT env . withDynFlags

27+ in runReaderT (withDynFlags $ f restore') env

28+

29+ gcatch (WithDynFlags act) handle = WithDynFlags $ ReaderT $ \env ->

30+ gcatch (runReaderT act env) (flip runReaderT env . withDynFlags . handle)

src/Development/IDE/Import/DependencyInformation.hs+121−34

@@ -9,26 +9,33 @@ module Development.IDE.Import.DependencyInformation

99 , ModuleParseError(..)

1010 , TransitiveDependencies(..)

1111 , FilePathId(..)

12+ , NamedModuleDep(..)

1213

1314 , PathIdMap

1415 , emptyPathIdMap

1516 , getPathId

17+ , lookupPathToId

1618 , insertImport

1719 , pathToId

1820 , idToPath

1921 , reachableModules

20−

2122 , processDependencyInformation

2223 , transitiveDeps

24+

25+ , BootIdMap

26+ , insertBootId

2327 ) where

2428

2529import Control.DeepSeq

2630import Data.Bifunctor

2731import Data.Coerce

2832import Data.List

33+import Data.Tuple.Extra hiding (first, second)

2934import Development.IDE.GHC.Orphans()

3035import Data.Either

3136import Data.Graph

37+import Data.HashMap.Strict (HashMap)

38+import qualified Data.HashMap.Strict as HMS

3239import Data.List.NonEmpty (NonEmpty(..), nonEmpty)

3340import qualified Data.List.NonEmpty as NonEmpty

3441import Data.IntMap (IntMap)

@@ -36,16 +43,14 @@ import qualified Data.IntMap.Strict as IntMap

3643import qualified Data.IntMap.Lazy as IntMapLazy

3744import Data.IntSet (IntSet)

3845import qualified Data.IntSet as IntSet

39−import Data.Map (Map)

40−import qualified Data.Map.Strict as MS

4146import Data.Maybe

4247import Data.Set (Set)

4348import qualified Data.Set as Set

44−import Data.Tuple.Extra (fst3)

4549import GHC.Generics (Generic)

4650

4751import Development.IDE.Types.Diagnostics

4852import Development.IDE.Types.Location

53+import Development.IDE.Import.FindImports (ArtifactsLocation(..))

4954

5055import GHC

5156import Module

@@ -57,69 +62,100 @@ data ModuleImports = ModuleImports

5762 -- that module on disk (if we found it)

5863 , packageImports :: !(Set InstalledUnitId)

5964 -- ^ Transitive package dependencies unioned for all imports.

60− }

65+ } deriving Show

6166

62−-- | For processing dependency information, we need lots of maps and sets

63−-- of filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet

64−-- instead and only convert at the edges

65−-- and

67+-- | For processing dependency information, we need lots of maps and sets of

68+-- filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet

69+-- instead and only convert at the edges.

6670newtype FilePathId = FilePathId { getFilePathId :: Int }

6771 deriving (Show, NFData, Eq, Ord)

6872

73+-- | Map from 'FilePathId'

74+type FilePathIdMap = IntMap

75+

76+-- | Set of 'FilePathId's

77+type FilePathIdSet = IntSet

78+

6979data PathIdMap = PathIdMap

70− { idToPathMap :: !(IntMap NormalizedFilePath)

71− , pathToIdMap :: !(Map NormalizedFilePath FilePathId)

80+ { idToPathMap :: !(FilePathIdMap ArtifactsLocation)

81+ , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)

7282 }

7383 deriving (Show, Generic)

7484

7585instance NFData PathIdMap

7686

7787emptyPathIdMap :: PathIdMap

78−emptyPathIdMap = PathIdMap IntMap.empty MS.empty

88+emptyPathIdMap = PathIdMap IntMap.empty HMS.empty

7989

80−getPathId :: NormalizedFilePath -> PathIdMap -> (FilePathId, PathIdMap)

90+getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap)

8191getPathId path m@PathIdMap{..} =

82− case MS.lookup path pathToIdMap of

92+ case HMS.lookup (artifactFilePath path) pathToIdMap of

8393 Nothing ->

84− let !newId = FilePathId $ MS.size pathToIdMap

94+ let !newId = FilePathId $ HMS.size pathToIdMap

8595 in (newId, insertPathId path newId m)

8696 Just id -> (id, m)

8797

88−insertPathId :: NormalizedFilePath -> FilePathId -> PathIdMap -> PathIdMap

98+insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap

8999insertPathId path id PathIdMap{..} =

90− PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (MS.insert path id pathToIdMap)

100+ PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert (artifactFilePath path) id pathToIdMap)

91101

92102insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation

93103insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }

94104

95105pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId

96−pathToId PathIdMap{pathToIdMap} path = pathToIdMap MS.! path

106+pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path

107+

108+lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId

109+lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap

97110

98111idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath

99−idToPath PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id

112+idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId

113+

114+idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation

115+idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id

116+

117+type BootIdMap = FilePathIdMap FilePathId

118+

119+insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap

120+insertBootId k = IntMap.insert (getFilePathId k)

100121

101122-- | Unprocessed results that we find by following imports recursively.

102123data RawDependencyInformation = RawDependencyInformation

103− { rawImports :: !(IntMap (Either ModuleParseError ModuleImports))

124+ { rawImports :: !(FilePathIdMap (Either ModuleParseError ModuleImports))

104125 , rawPathIdMap :: !PathIdMap

105− }

106−

107−pkgDependencies :: RawDependencyInformation -> IntMap (Set InstalledUnitId)

126+ -- The rawBootMap maps the FilePathId of a hs-boot file to its

127+ -- corresponding hs file. It is used when topologically sorting as we

128+ -- need to add edges between .hs-boot and .hs so that the .hs files

129+ -- appear later in the sort.

130+ , rawBootMap :: !BootIdMap

131+ } deriving Show

132+

133+pkgDependencies :: RawDependencyInformation -> FilePathIdMap (Set InstalledUnitId)

108134pkgDependencies RawDependencyInformation{..} =

109135 IntMap.map (either (const Set.empty) packageImports) rawImports

110136

111137data DependencyInformation =

112138 DependencyInformation

113− { depErrorNodes :: !(IntMap (NonEmpty NodeError))

139+ { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError))

114140 -- ^ Nodes that cannot be processed correctly.

115− , depModuleDeps :: !(IntMap IntSet)

141+ , depModuleNames :: !(FilePathIdMap ShowableModuleName)

142+ , depModuleDeps :: !(FilePathIdMap FilePathIdSet)

116143 -- ^ For a non-error node, this contains the set of module immediate dependencies

117144 -- in the same package.

118− , depPkgDeps :: !(IntMap (Set InstalledUnitId))

145+ , depPkgDeps :: !(FilePathIdMap (Set InstalledUnitId))

119146 -- ^ For a non-error node, this contains the set of immediate pkg deps.

120147 , depPathIdMap :: !PathIdMap

148+ -- ^ Map from FilePath to FilePathId

149+ , depBootMap :: !BootIdMap

150+ -- ^ Map from hs-boot file to the corresponding hs file

121151 } deriving (Show, Generic)

122152

153+newtype ShowableModuleName =

154+ ShowableModuleName {showableModuleName :: ModuleName}

155+ deriving NFData

156+

157+instance Show ShowableModuleName where show = moduleNameString . showableModuleName

158+

123159reachableModules :: DependencyInformation -> [NormalizedFilePath]

124160reachableModules DependencyInformation{..} =

125161 map (idToPath depPathIdMap . FilePathId) $ IntMap.keys depErrorNodes <> IntMap.keys depModuleDeps

@@ -186,23 +222,32 @@ processDependencyInformation rawDepInfo@RawDependencyInformation{..} =

186222 DependencyInformation

187223 { depErrorNodes = IntMap.fromList errorNodes

188224 , depModuleDeps = moduleDeps

225+ , depModuleNames = IntMap.fromList $ coerce moduleNames

189226 , depPkgDeps = pkgDependencies rawDepInfo

190227 , depPathIdMap = rawPathIdMap

228+ , depBootMap = rawBootMap

191229 }

192230 where resultGraph = buildResultGraph rawImports

193231 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph

232+ moduleNames :: [(FilePathId, ModuleName)]

233+ moduleNames =

234+ [ (fId, modName) | (_, imports) <- successNodes, (L _ modName, fId) <- imports]

194235 successEdges :: [(FilePathId, FilePathId, [FilePathId])]

195236 successEdges =

196− map (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports)) successNodes

237+ map

238+ (\(file, imports) -> (FilePathId file, FilePathId file, map snd imports))

239+ successNodes

197240 moduleDeps =

198− IntMap.fromList $ map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs)) successEdges

241+ IntMap.fromList $

242+ map (\(_, FilePathId v, vs) -> (v, IntSet.fromList $ coerce vs))

243+ successEdges

199244

200245-- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:

201246-- 1. Mark each node that is part of an import cycle as an error node.

202247-- 2. Mark each node that has a parse error as an error node.

203248-- 3. Mark each node whose immediate children could not be located as an error.

204249-- 4. Recursively propagate errors to parents if they are not already error nodes.

205−buildResultGraph :: IntMap (Either ModuleParseError ModuleImports) -> IntMap NodeResult

250+buildResultGraph :: FilePathIdMap (Either ModuleParseError ModuleImports) -> FilePathIdMap NodeResult

206251buildResultGraph g = propagatedErrors

207252 where

208253 sccs = stronglyConnComp (graphEdges g)

@@ -249,7 +294,7 @@ buildResultGraph g = propagatedErrors

249294 Right ModuleImports{moduleImports} ->

250295 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports

251296

252−graphEdges :: IntMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]

297+graphEdges :: FilePathIdMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]

253298graphEdges g =

254299 map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g

255300 where deps :: Either e ModuleImports -> [FilePathId]

@@ -261,29 +306,71 @@ partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest

261306partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest

262307partitionSCC [] = ([], [])

263308

309+

264310transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies

265311transitiveDeps DependencyInformation{..} file = do

266312 let !fileId = pathToId depPathIdMap file

267313 reachableVs <-

314+ -- Delete the starting node

268315 IntSet.delete (getFilePathId fileId) .

269316 IntSet.fromList . map (fst3 . fromVertex) .

270317 reachable g <$> toVertex (getFilePathId fileId)

271− let transitiveModuleDepIds = filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs

318+ let transitiveModuleDepIds =

319+ filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs

272320 let transitivePkgDeps =

273321 Set.toList $ Set.unions $

274322 map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $

275323 getFilePathId fileId : transitiveModuleDepIds

276− let transitiveModuleDeps = map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds

324+ let transitiveModuleDeps =

325+ map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds

326+ let transitiveNamedModuleDeps =

327+ [ NamedModuleDep (idToPath depPathIdMap (FilePathId fid)) mn artifactModLocation

328+ | (fid, ShowableModuleName mn) <- IntMap.toList depModuleNames

329+ , let ArtifactsLocation{artifactModLocation} = idToPathMap depPathIdMap IntMap.! fid

330+ ]

277331 pure TransitiveDependencies {..}

278− where (g, fromVertex, toVertex) = graphFromEdges (map (\(f, fs) -> (f, f, IntSet.toList fs)) $ IntMap.toList depModuleDeps)

279− vs = topSort g

332+ where

333+ (g, fromVertex, toVertex) = graphFromEdges edges

334+ edges = map (\(f, fs) -> (f, f, IntSet.toList fs ++ boot_edge f)) $ IntMap.toList depModuleDeps

335+

336+ -- Need to add an edge between the .hs and .hs-boot file if it exists

337+ -- so the .hs file gets loaded after the .hs-boot file and the right

338+ -- stuff ends up in the HPT. If you don't have this check then GHC will

339+ -- fail to work with ghcide.

340+ boot_edge f = [getFilePathId f' | Just f' <- [IntMap.lookup f depBootMap]]

341+

342+ vs = topSort g

280343

281344data TransitiveDependencies = TransitiveDependencies

282345 { transitiveModuleDeps :: [NormalizedFilePath]

283346 -- ^ Transitive module dependencies in topological order.

284347 -- The module itself is not included.

348+ , transitiveNamedModuleDeps :: [NamedModuleDep]

349+ -- ^ Transitive module dependencies in topological order.

350+ -- The module itself is not included.

285351 , transitivePkgDeps :: [InstalledUnitId]

286352 -- ^ Transitive pkg dependencies in unspecified order.

287353 } deriving (Eq, Show, Generic)

288354

289355instance NFData TransitiveDependencies

356+

357+data NamedModuleDep = NamedModuleDep {

358+ nmdFilePath :: !NormalizedFilePath,

359+ nmdModuleName :: !ModuleName,

360+ nmdModLocation :: !ModLocation

361+ }

362+ deriving Generic

363+

364+instance Eq NamedModuleDep where

365+ a == b = nmdFilePath a == nmdFilePath b

366+

367+instance NFData NamedModuleDep where

368+ rnf NamedModuleDep{..} =

369+ rnf nmdFilePath `seq`

370+ rnf nmdModuleName `seq`

371+ -- 'ModLocation' lacks an 'NFData' instance

372+ rwhnf nmdModLocation

373+

374+instance Show NamedModuleDep where

375+ show NamedModuleDep{..} = show nmdFilePath

376+

src/Development/IDE/Import/FindImports.hs+63−17

@@ -7,16 +7,19 @@

77module Development.IDE.Import.FindImports

88 ( locateModule

99 , Import(..)

10+ , ArtifactsLocation(..)

11+ , modSummaryToArtifactsLocation

12+ , isBootLocation

13+ , mkImportDirs

1014 ) where

1115

1216import Development.IDE.GHC.Error as ErrUtils

1317import Development.IDE.GHC.Orphans()

1418import Development.IDE.Types.Diagnostics

1519import Development.IDE.Types.Location

20+import Development.IDE.GHC.Compat

1621-- GHC imports

17−import DynFlags

1822import FastString

19−import GHC

2023import qualified Module as M

2124import Packages

2225import Outputable (showSDoc, ppr, pprPanic)

@@ -27,64 +30,107 @@ import Control.DeepSeq

2730import Control.Monad.Extra

2831import Control.Monad.IO.Class

2932import System.FilePath

33+import DriverPhases

34+import Data.Maybe

3035

3136data Import

32− = FileImport !NormalizedFilePath

37+ = FileImport !ArtifactsLocation

3338 | PackageImport !M.InstalledUnitId

3439 deriving (Show)

3540

41+data ArtifactsLocation = ArtifactsLocation

42+ { artifactFilePath :: !NormalizedFilePath

43+ , artifactModLocation :: !ModLocation

44+ , artifactIsSource :: !Bool -- ^ True if a module is a source input

45+ }

46+ deriving (Show)

47+

48+instance NFData ArtifactsLocation where

49+ rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource

50+

51+isBootLocation :: ArtifactsLocation -> Bool

52+isBootLocation = not . artifactIsSource

53+

3654instance NFData Import where

3755 rnf (FileImport x) = rnf x

3856 rnf (PackageImport x) = rnf x

3957

58+modSummaryToArtifactsLocation :: NormalizedFilePath -> ModSummary -> ArtifactsLocation

59+modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location ms) (isSource (ms_hsc_src ms))

60+ where

61+ isSource HsSrcFile = True

62+ isSource _ = False

63+

4064

4165-- | locate a module in the file system. Where we go from *daml to Haskell

4266locateModuleFile :: MonadIO m

43− => DynFlags

67+ => [[FilePath]]

4468 -> [String]

4569 -> (NormalizedFilePath -> m Bool)

4670 -> Bool

4771 -> ModuleName

4872 -> m (Maybe NormalizedFilePath)

49−locateModuleFile dflags exts doesExist isSource modName = do

50− let candidates =

51− [ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)

52− | prefix <- importPaths dflags, ext <- exts]

53− findM doesExist candidates

73+locateModuleFile import_dirss exts doesExist isSource modName = do

74+ let candidates import_dirs =

75+ [ toNormalizedFilePath' (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)

76+ | prefix <- import_dirs , ext <- exts]

77+ findM doesExist (concatMap candidates import_dirss)

5478 where

5579 maybeBoot ext

5680 | isSource = ext ++ "-boot"

5781 | otherwise = ext

5882

83+-- | This function is used to map a package name to a set of import paths.

84+-- It only returns Just for unit-ids which are possible to import into the

85+-- current module. In particular, it will return Nothing for 'main' components

86+-- as they can never be imported into another package.

87+mkImportDirs :: DynFlags -> (M.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath])

88+mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i

89+

5990-- | locate a module in either the file system or the package database. Where we go from *daml to

6091-- Haskell

6192locateModule

6293 :: MonadIO m

6394 => DynFlags

95+ -> [(M.InstalledUnitId, DynFlags)] -- Sets import directories to look in

6496 -> [String]

6597 -> (NormalizedFilePath -> m Bool)

6698 -> Located ModuleName

6799 -> Maybe FastString

68100 -> Bool

69101 -> m (Either [FileDiagnostic] Import)

70−locateModule dflags exts doesExist modName mbPkgName isSource = do

102+locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do

71103 case mbPkgName of

72104 -- "this" means that we should only look in the current package

73105 Just "this" -> do

74− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName

75− case mbFile of

76− Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []

77− Just file -> return $ Right $ FileImport file

106+ lookupLocal [importPaths dflags]

78107 -- if a package name is given we only go look for a package

79− Just _pkgName -> lookupInPackageDB dflags

108+ Just pkgName

109+ | Just dirs <- lookup (PackageName pkgName) import_paths

110+ -> lookupLocal [dirs]

111+ | otherwise -> lookupInPackageDB dflags

80112 Nothing -> do

81113 -- first try to find the module as a file. If we can't find it try to find it in the package

82114 -- database.

83− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName

115+ -- Here the importPaths for the current modules are added to the front of the import paths from the other components.

116+ -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in

117+ -- each component will end up being found in the wrong place and cause a multi-cradle match failure.

118+ mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts doesExist isSource $ unLoc modName

84119 case mbFile of

85120 Nothing -> lookupInPackageDB dflags

86− Just file -> return $ Right $ FileImport file

121+ Just file -> toModLocation file

87122 where

123+ import_paths = mapMaybe (mkImportDirs dflags) comp_info

124+ toModLocation file = liftIO $ do

125+ loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)

126+ return $ Right $ FileImport $ ArtifactsLocation file loc (not isSource)

127+

128+ lookupLocal dirs = do

129+ mbFile <- locateModuleFile dirs exts doesExist isSource $ unLoc modName

130+ case mbFile of

131+ Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []

132+ Just file -> toModLocation file

133+

88134 lookupInPackageDB dfs =

89135 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of

90136 LookupFound _m pkgConfig -> return $ Right $ PackageImport $ unitId pkgConfig

src/Development/IDE/LSP/HoverDefinition.hs+5−2

@@ -6,6 +6,9 @@

66module Development.IDE.LSP.HoverDefinition

77 ( setHandlersHover

88 , setHandlersDefinition

9+ -- * For haskell-language-server

10+ , hover

11+ , gotoDefinition

912 ) where

1013

1114import Development.IDE.Core.Rules

@@ -29,7 +32,7 @@ foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover

2932foundHover (mbRange, contents) =

3033 Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange

3134

32−setHandlersDefinition, setHandlersHover :: PartialHandlers

35+setHandlersDefinition, setHandlersHover :: PartialHandlers c

3336setHandlersDefinition = PartialHandlers $ \WithMessage{..} x ->

3437 return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition}

3538setHandlersHover = PartialHandlers $ \WithMessage{..} x ->

@@ -52,7 +55,7 @@ request label getResults notFound found ide (TextDocumentPositionParams (TextDoc

5255

5356logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b

5457logAndRunRequest label getResults ide pos path = do

55− let filePath = toNormalizedFilePath path

58+ let filePath = toNormalizedFilePath' path

5659 logInfo (ideLogger ide) $

5760 label <> " request at position " <> T.pack (showPosition pos) <>

5861 " in file: " <> T.pack path

src/Development/IDE/LSP/LanguageServer.hs+52−28

@@ -28,21 +28,25 @@ import GHC.IO.Handle (hDuplicate)

2828import System.IO

2929import Control.Monad.Extra

3030

31+import Development.IDE.Core.IdeConfiguration

32+import Development.IDE.Core.Shake

3133import Development.IDE.LSP.HoverDefinition

3234import Development.IDE.LSP.Notifications

3335import Development.IDE.LSP.Outline

34−import Development.IDE.Core.Service

3536import Development.IDE.Types.Logger

3637import Development.IDE.Core.FileStore

3738import Language.Haskell.LSP.Core (LspFuncs(..))

3839import Language.Haskell.LSP.Messages

3940

4041runLanguageServer

41− :: LSP.Options

42− -> PartialHandlers

42+ :: forall config. (Show config)

43+ => LSP.Options

44+ -> PartialHandlers config

45+ -> (InitializeRequest -> Either T.Text config)

46+ -> (DidChangeConfigurationNotification -> Either T.Text config)

4347 -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)

4448 -> IO ()

45−runLanguageServer options userHandlers getIdeState = do

49+runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do

4650 -- Move stdout to another file descriptor and duplicate stderr

4751 -- to stdout. This guards against stray prints from corrupting the JSON-RPC

4852 -- message stream.

@@ -59,7 +63,7 @@ runLanguageServer options userHandlers getIdeState = do

5963

6064 -- Send everything over a channel, since you need to wait until after initialise before

6165 -- LspFuncs is available

62− clientMsgChan :: Chan Message <- newChan

66+ clientMsgChan :: Chan (Message config) <- newChan

6367

6468 -- These barriers are signaled when the threads reading from these chans exit.

6569 -- This should not happen but if it does, we will make sure that the whole server

@@ -78,6 +82,7 @@ runLanguageServer options userHandlers getIdeState = do

7882 let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id} -> do

7983 atomically $ modifyTVar pendingRequests (Set.insert _id)

8084 writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f

85+ let withInitialize f = Just $ \r -> writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x)

8186 let cancelRequest reqId = atomically $ do

8287 queued <- readTVar pendingRequests

8388 -- We want to avoid that the list of cancelled requests

@@ -94,6 +99,7 @@ runLanguageServer options userHandlers getIdeState = do

9499 cancelled <- readTVar cancelledRequests

95100 unless (reqId `Set.member` cancelled) retry

96101 let PartialHandlers parts =

102+ initializeRequestHandler <>

97103 setHandlersIgnore <> -- least important

98104 setHandlersDefinition <> setHandlersHover <>

99105 setHandlersOutline <>

@@ -102,11 +108,11 @@ runLanguageServer options userHandlers getIdeState = do

102108 cancelHandler cancelRequest

103109 -- Cancel requests are special since they need to be handled

104110 -- out of order to be useful. Existing handlers are run afterwards.

105− handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest} def

111+ handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def

106112

107113 let initializeCallbacks = LSP.InitializeCallbacks

108− { LSP.onInitialConfiguration = const $ Right ()

109− , LSP.onConfigurationChange = const $ Right ()

114+ { LSP.onInitialConfiguration = onInitialConfig

115+ , LSP.onConfigurationChange = onConfigChange

110116 , LSP.onStartup = handleInit (signalBarrier clientMsgBarrier ()) clearReqId waitForCancel clientMsgChan

111117 }

112118

@@ -121,9 +127,11 @@ runLanguageServer options userHandlers getIdeState = do

121127 , void $ waitBarrier clientMsgBarrier

122128 ]

123129 where

124− handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs () -> IO (Maybe err)

130+ handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan (Message config) -> LSP.LspFuncs config -> IO (Maybe err)

125131 handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do

132+

126133 ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities

134+

127135 _ <- flip forkFinally (const exitClientMsg) $ forever $ do

128136 msg <- readChan clientMsgChan

129137 case msg of

@@ -136,17 +144,23 @@ runLanguageServer options userHandlers getIdeState = do

136144 Response x@RequestMessage{_id, _params} wrap act ->

137145 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

138146 \case

139− Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing (Just e)

140− Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just r) Nothing

147+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)

148+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)

141149 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->

142150 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

143151 \(res, newReq) -> do

144− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing

145− case newReq of

146− Nothing -> return ()

147− Just (rm, newReqParams) -> do

152+ case res of

153+ Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)

154+ Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)

155+ whenJust newReq $ \(rm, newReqParams) -> do

148156 reqId <- getNextReqId

149157 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

150164 pure Nothing

151165

152166 checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =

@@ -161,28 +175,39 @@ runLanguageServer options userHandlers getIdeState = do

161175 Left () -> do

162176 logDebug (ideLogger ide) $ T.pack $

163177 "Cancelled request " <> show _id

164− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $

165− Just $ ResponseError RequestCancelled "" Nothing

178+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left

179+ $ ResponseError RequestCancelled "" Nothing

166180 Right res -> k res

167181 ) $ \(e :: SomeException) -> do

168182 logError (ideLogger ide) $ T.pack $

169183 "Unexpected exception on request, please report!\n" ++

170184 "Message: " ++ show msg ++ "\n" ++

171185 "Exception: " ++ show e

172− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $

173− Just $ ResponseError InternalError (T.pack $ show e) Nothing

186+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left

187+ $ ResponseError InternalError (T.pack $ show e) Nothing

174188

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)

175200

176201-- | Things that get sent to us, but we don't deal with.

177202-- Set them to avoid a warning in VS Code output.

178−setHandlersIgnore :: PartialHandlers

203+setHandlersIgnore :: PartialHandlers config

179204setHandlersIgnore = PartialHandlers $ \_ x -> return x

180205 {LSP.initializedHandler = none

181206 ,LSP.responseHandler = none

182207 }

183208 where none = Just $ const $ return ()

184209

185−cancelHandler :: (LspId -> IO ()) -> PartialHandlers

210+cancelHandler :: (LspId -> IO ()) -> PartialHandlers config

186211cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x

187212 {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do

188213 cancelRequest _id

@@ -192,19 +217,18 @@ cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x

192217

193218-- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety

194219-- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)

195−data Message

196− = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs () -> IdeState -> req -> IO (Either ResponseError resp))

220+data Message c

221+ = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp))

197222 -- | Used for cases in which we need to send not only a response,

198223 -- but also an additional request to the client.

199224 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.

200− | 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)))

201− | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs () -> IdeState -> req -> IO ())

202−

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 ())

203229

204230modifyOptions :: LSP.Options -> LSP.Options

205231modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS

206− , LSP.executeCommandCommands = Just ["typesignature.add"]

207− , LSP.completionTriggerCharacters = Just "."

208232 }

209233 where

210234 tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}

src/Development/IDE/LSP/Notifications.hs+14−5

@@ -13,6 +13,7 @@ import qualified Language.Haskell.LSP.Core as LSP

1313import Language.Haskell.LSP.Types

1414import qualified Language.Haskell.LSP.Types as LSP

1515

16+import Development.IDE.Core.IdeConfiguration

1617import Development.IDE.Core.Service

1718import Development.IDE.Types.Location

1819import Development.IDE.Types.Logger

@@ -20,7 +21,7 @@ import Development.IDE.Types.Logger

2021import Control.Monad.Extra

2122import Data.Foldable as F

2223import Data.Maybe

23−import qualified Data.Set as S

24+import qualified Data.HashSet as S

2425import qualified Data.Text as Text

2526

2627import Development.IDE.Core.FileStore (setSomethingModified)

@@ -29,9 +30,9 @@ import Development.IDE.Core.OfInterest

2930

3031

3132whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()

32−whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath

33+whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'

3334

34−setHandlersNotifications :: PartialHandlers

35+setHandlersNotifications :: PartialHandlers c

3536setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x

3637 {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $

3738 \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do

@@ -61,7 +62,7 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x

6162 let events =

6263 mapMaybe

6364 (\(FileEvent uri ev) ->

64− (, ev /= FcDeleted) . toNormalizedFilePath

65+ (, ev /= FcDeleted) . toNormalizedFilePath'

6566 <$> LSP.uriToFilePath uri

6667 )

6768 ( F.toList fileEvents )

@@ -69,4 +70,12 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x

6970 logInfo (ideLogger ide) $ "Files created or deleted: " <> msg

7071 modifyFileExists ide events

7172 setSomethingModified ide

72− }

73+

74+ ,LSP.didChangeWorkspaceFoldersNotificationHandler = withNotification (LSP.didChangeWorkspaceFoldersNotificationHandler x) $

75+ \_ ide (DidChangeWorkspaceFoldersParams events) -> do

76+ let add = S.union

77+ substract = flip S.difference

78+ modifyWorkspaceFolders ide

79+ $ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events))

80+ . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events))

81+ }

src/Development/IDE/LSP/Outline.hs+47−8

@@ -4,6 +4,8 @@

55module Development.IDE.LSP.Outline

66 ( setHandlersOutline

7+ -- * For haskell-language-server

8+ , moduleOutline

79 )

810where

911

@@ -28,20 +30,20 @@ import Outputable ( Outputable

2830 , showSDocUnsafe

2931 )

3032

31−setHandlersOutline :: PartialHandlers

33+setHandlersOutline :: PartialHandlers c

3234setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x

3335 { LSP.documentSymbolHandler = withResponse RspDocumentSymbols moduleOutline

3436 }

3537

3638moduleOutline

37− :: LSP.LspFuncs () -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)

39+ :: LSP.LspFuncs c -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)

3840moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }

3941 = case uriToFilePath uri of

40− Just (toNormalizedFilePath -> fp) -> do

42+ Just (toNormalizedFilePath' -> fp) -> do

4143 mb_decls <- runAction ideState $ use GetParsedModule fp

4244 pure $ Right $ case mb_decls of

4345 Nothing -> DSDocumentSymbols (List [])

44− Just (ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } })

46+ Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } }

4547 -> let

4648 declSymbols = mapMaybe documentSymbolForDecl hsmodDecls

4749 moduleSymbol = hsmodName <&> \(L l m) ->

@@ -50,7 +52,9 @@ moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentI

5052 , _kind = SkFile

5153 , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0

5254 }

53− importSymbols = mapMaybe documentSymbolForImport hsmodImports

55+ importSymbols = maybe [] pure $

56+ documentSymbolForImportSummary

57+ (mapMaybe documentSymbolForImport hsmodImports)

5458 allSymbols = case moduleSymbol of

5559 Nothing -> importSymbols <> declSymbols

5660 Just x ->

@@ -104,27 +108,39 @@ documentSymbolForDecl (L l (TyClD DataDecl { tcdLName = L _ name, tcdDataDefn =

104108 { _name = showRdrName n

105109 , _kind = SkConstructor

106110 , _selectionRange = srcSpanToRange l'

111+ , _children = conArgRecordFields (getConArgs x)

107112 }

108113 | L l x <- dd_cons

109114 , L l' n <- getConNames x

110115 ]

111116 }

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

112128documentSymbolForDecl (L l (TyClD SynDecl { tcdLName = L l' n })) = Just

113129 (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n

114130 , _kind = SkTypeParameter

115131 , _selectionRange = srcSpanToRange l'

116132 }

117−documentSymbolForDecl (L l (InstD (ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })))

133+documentSymbolForDecl (L l (InstD ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } }))

118134 = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty

119135 , _kind = SkInterface

120136 }

121−documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) }))

137+documentSymbolForDecl (L l (InstD DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))

122138 = Just (defDocumentSymbol l :: DocumentSymbol)

123139 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

124140 (map pprText feqn_pats)

125141 , _kind = SkInterface

126142 }

127−documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } }) }))

143+documentSymbolForDecl (L l (InstD TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } }))

128144 = Just (defDocumentSymbol l :: DocumentSymbol)

129145 { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords

130146 (map pprText feqn_pats)

@@ -167,12 +183,35 @@ documentSymbolForDecl (L l (ForD x)) = Just

167183

168184documentSymbolForDecl _ = Nothing

169185

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+

170205documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol

171206documentSymbolForImport (L l ImportDecl { ideclName, ideclQualified }) = Just

172207 (defDocumentSymbol l :: DocumentSymbol)

173208 { _name = "import " <> pprText ideclName

174209 , _kind = SkModule

210+#if MIN_GHC_API_VERSION(8,10,0)

211+ , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" }

212+#else

175213 , _detail = if ideclQualified then Just "qualified" else Nothing

214+#endif

176215 }

177216#if MIN_GHC_API_VERSION(8,6,0)

178217documentSymbolForImport (L _ XImportDecl {}) = Nothing

src/Development/IDE/LSP/Server.hs+11−9

@@ -16,30 +16,32 @@ import qualified Language.Haskell.LSP.Core as LSP

1616import qualified Language.Haskell.LSP.Messages as LSP

1717import Development.IDE.Core.Service

1818

19−data WithMessage = WithMessage

19+data WithMessage c = WithMessage

2020 {withResponse :: forall m req resp . (Show m, Show req) =>

2121 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

22− (LSP.LspFuncs () -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work

22+ (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work

2323 Maybe (LSP.Handler (RequestMessage m req resp))

2424 ,withNotification :: forall m req . (Show m, Show req) =>

2525 Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler

26− (LSP.LspFuncs () -> IdeState -> req -> IO ()) -> -- actual work

26+ (LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work

2727 Maybe (LSP.Handler (NotificationMessage m req))

28− ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.

28+ ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody .

2929 (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) =>

3030 (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response

3131 (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req

32− (LSP.LspFuncs () -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work

32+ (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work

3333 Maybe (LSP.Handler (RequestMessage m req resp))

34+ , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())

35+ -> Maybe (LSP.Handler InitializeRequest)

3436 }

3537

36−newtype PartialHandlers = PartialHandlers (WithMessage -> LSP.Handlers -> IO LSP.Handlers)

38+newtype PartialHandlers c = PartialHandlers (WithMessage c -> LSP.Handlers -> IO LSP.Handlers)

3739

38−instance Default PartialHandlers where

40+instance Default (PartialHandlers c) where

3941 def = PartialHandlers $ \_ x -> pure x

4042

41−instance Semigroup PartialHandlers where

43+instance Semigroup (PartialHandlers c) where

4244 PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w

4345

44−instance Monoid PartialHandlers where

46+instance Monoid (PartialHandlers c) where

4547 mempty = def

src/Development/IDE/Plugin.hs+34−8

@@ -1,34 +1,60 @@

2−module Development.IDE.Plugin(Plugin(..), codeActionPlugin) where

2+module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules,makeLspCommandId,getPid) where

44import Data.Default

5+import qualified Data.Text as T

56import Development.Shake

67import Development.IDE.LSP.Server

89import Language.Haskell.LSP.Types

10+import Development.IDE.Compat

911import Development.IDE.Core.Rules

1012import qualified Language.Haskell.LSP.Core as LSP

1113import Language.Haskell.LSP.Messages

1214

1315

14−data Plugin = Plugin

16+data Plugin c = Plugin

1517 {pluginRules :: Rules ()

16− ,pluginHandler :: PartialHandlers

18+ ,pluginHandler :: PartialHandlers c

1719 }

1820

19−instance Default Plugin where

21+instance Default (Plugin c) where

2022 def = Plugin mempty def

2123

22−instance Semigroup Plugin where

24+instance Semigroup (Plugin c) where

2325 Plugin x1 y1 <> Plugin x2 y2 = Plugin (x1<>x2) (y1<>y2)

2426

25−instance Monoid Plugin where

27+instance Monoid (Plugin c) where

2628 mempty = def

2729

2830

29−codeActionPlugin :: (LSP.LspFuncs () -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin

30−codeActionPlugin f = Plugin mempty $ PartialHandlers $ \WithMessage{..} x -> return x{

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{

3136 LSP.codeActionHandler = withResponse RspCodeAction g

3237 }

3338 where

3439 g lsp state (CodeActionParams a b c _) = fmap List <$> f lsp state a b c

40+

41+-- | Prefix to uniquely identify commands sent to the client. This

42+-- has two parts

43+--

44+-- - A representation of the process id to make sure that a client has

45+-- unique commands if it is running multiple servers, since some

46+-- clients have a global command table and get confused otherwise.

47+--

48+-- - A string to identify ghcide, to ease integration into

49+-- haskell-language-server, which routes commands to plugins based

50+-- on that.

51+makeLspCommandId :: T.Text -> IO T.Text

52+makeLspCommandId command = do

53+ pid <- getPid

54+ return $ pid <> ":ghcide:" <> command

55+

56+-- | Get the operating system process id for the running server

57+-- instance. This should be the same for the lifetime of the instance,

58+-- and different from that of any other currently running instance.

59+getPid :: IO T.Text

60+getPid = T.pack . show <$> getProcessID

src/Development/IDE/Plugin/CodeAction.hs+157−92

@@ -6,7 +6,16 @@

66#include "ghc-api-version.h"

88-- | Go to the definition of a variable.

9−module Development.IDE.Plugin.CodeAction(plugin) where

9+module Development.IDE.Plugin.CodeAction

10+ (

11+ plugin

12+

13+ -- * For haskell-language-server

14+ , codeAction

15+ , codeLens

16+ , rulePackageExports

17+ , executeAddSignatureCommand

18+ ) where

1019

1120import Language.Haskell.LSP.Types

1221import Control.Monad (join)

@@ -17,9 +26,14 @@ import Development.IDE.Core.RuleTypes

1726import Development.IDE.Core.Service

1827import Development.IDE.Core.Shake

1928import Development.IDE.GHC.Error

29+import Development.IDE.GHC.Util

2030import 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

2134import Development.IDE.Types.Location

2235import Development.IDE.Types.Options

36+import Development.Shake (Rules)

2337import qualified Data.HashMap.Strict as Map

2438import qualified Language.Haskell.LSP.Core as LSP

2539import Language.Haskell.LSP.VFS

@@ -32,18 +46,23 @@ import Data.Maybe

3246import Data.List.Extra

3347import qualified Data.Text as T

3448import Data.Tuple.Extra ((&&&))

49+import HscTypes

50+import Parser

3551import Text.Regex.TDFA ((=~), (=~~))

3652import Text.Regex.TDFA.Text()

3753import Outputable (ppr, showSDocUnsafe)

3854import DynFlags (xFlags, FlagSpec(..))

3955import GHC.LanguageExtensions.Type (Extension)

4056

41−plugin :: Plugin

42−plugin = codeActionPlugin codeAction <> Plugin mempty setHandlersCodeLens

57+plugin :: Plugin c

58+plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens

59+

60+rules :: Rules ()

61+rules = rulePackageExports

4362

4463-- | Generate code actions.

4564codeAction

46− :: LSP.LspFuncs ()

65+ :: LSP.LspFuncs c

4766 -> IdeState

4867 -> TextDocumentIdentifier

4968 -> Range

@@ -54,30 +73,35 @@ codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diag

5473 -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg

5574 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri

5675 let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents

57− (ideOptions, parsedModule) <- runAction state $

58− (,) <$> getIdeOptions

59− <*> (getParsedModule . toNormalizedFilePath) `traverse` uriToFilePath uri

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

6083 pure $ Right

6184 [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing

62− | x <- xs, (title, tedit) <- suggestAction ideOptions ( join parsedModule ) text x

85+ | x <- xs, (title, tedit) <- suggestAction dflags (fromMaybe mempty pkgExports) ideOptions ( join parsedModule ) text x

6386 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

6487 ]

6588

6689-- | Generate code lenses.

6790codeLens

68− :: LSP.LspFuncs ()

91+ :: LSP.LspFuncs c

6992 -> IdeState

7093 -> CodeLensParams

7194 -> IO (Either ResponseError (List CodeLens))

7295codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do

96+ commandId <- makeLspCommandId "typesignature.add"

7397 fmap (Right . List) $ case uriToFilePath' uri of

74− Just (toNormalizedFilePath -> filePath) -> do

98+ Just (toNormalizedFilePath' -> filePath) -> do

7599 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath

76100 diag <- getDiagnostics ideState

77101 hDiag <- getHiddenDiagnostics ideState

78102 pure

79− [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing

80− | (dFile, _, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag ++ hDiag

103+ [ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing

104+ | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag

81105 , dFile == filePath

82106 , (title, tedit) <- suggestSignature False dDiag

83107 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

@@ -86,22 +110,33 @@ codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri}

86110

87111-- | Execute the "typesignature.add" command.

88112executeAddSignatureCommand

89− :: LSP.LspFuncs ()

113+ :: LSP.LspFuncs c

90114 -> IdeState

91115 -> ExecuteCommandParams

92− -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

116+ -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

93117executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}

94− | _command == "typesignature.add"

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

95123 , Just (List [edit]) <- _arguments

96124 , Success wedit <- fromJSON edit

97− = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))

125+ = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))

98126 | otherwise

99− = return (Null, Nothing)

100−

101−suggestAction :: IdeOptions -> Maybe ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

102−suggestAction ideOptions parsedModule text diag = concat

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

103138 [ suggestAddExtension diag

104− , suggestExtendImport text diag

139+ , suggestExtendImport dflags text diag

105140 , suggestFillHole diag

106141 , suggestFillTypeWildcard diag

107142 , suggestFixConstructorImport text diag

@@ -111,17 +146,19 @@ suggestAction ideOptions parsedModule text diag = concat

111146 ] ++ concat

112147 [ suggestNewDefinition ideOptions pm text diag

113148 ++ suggestRemoveRedundantImport pm text diag

149+ ++ suggestNewImport packageExports pm diag

114150 | Just pm <- [parsedModule]]

115151

116152

117153suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

118−suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range@Range{..},..}

154+suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..}

119155-- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant

120156 | Just [_, bindings] <- matchRegex _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant"

121157 , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == _range ) hsmodImports

122158 , Just c <- contents

123159 , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)

124160 , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)

161+ , not (null ranges')

125162 = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]

126163

127164-- File.hs:16:1: warning:

@@ -133,7 +170,7 @@ suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmod

133170 | otherwise = []

134171

135172suggestReplaceIdentifier :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

136−suggestReplaceIdentifier contents Diagnostic{_range=_range@Range{..},..}

173+suggestReplaceIdentifier contents Diagnostic{_range=_range,..}

137174-- File.hs:52:41: error:

138175-- * Variable not in scope:

139176-- suggestAcion :: Maybe T.Text -> Range -> Range

@@ -180,7 +217,7 @@ newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ

180217

181218

182219suggestFillTypeWildcard :: Diagnostic -> [(T.Text, [TextEdit])]

183−suggestFillTypeWildcard Diagnostic{_range=_range@Range{..},..}

220+suggestFillTypeWildcard Diagnostic{_range=_range,..}

184221-- Foo.hs:3:8: error:

185222-- * Found type wildcard `_' standing for `p -> p1 -> p'

186223

@@ -191,7 +228,7 @@ suggestFillTypeWildcard Diagnostic{_range=_range@Range{..},..}

191228 | otherwise = []

192229

193230suggestAddExtension :: Diagnostic -> [(T.Text, [TextEdit])]

194−suggestAddExtension Diagnostic{_range=_range@Range{..},..}

231+suggestAddExtension Diagnostic{_range=_range,..}

195232-- File.hs:22:8: error:

196233-- Illegal lambda-case (use -XLambdaCase)

197234-- File.hs:22:6: error:

@@ -221,7 +258,7 @@ ghcExtensions :: Map.HashMap T.Text Extension

221258ghcExtensions = Map.fromList . map ( ( T.pack . flagSpecName ) &&& flagSpecFlag ) $ xFlags

222259

223260suggestModuleTypo :: Diagnostic -> [(T.Text, [TextEdit])]

224−suggestModuleTypo Diagnostic{_range=_range@Range{..},..}

261+suggestModuleTypo Diagnostic{_range=_range,..}

225262-- src/Development/IDE/Core/Compile.hs:58:1: error:

226263-- Could not find module ‘Data.Cha’

227264-- Perhaps you meant Data.Char (from base-4.12.0.0)

@@ -233,7 +270,7 @@ suggestModuleTypo Diagnostic{_range=_range@Range{..},..}

233270 | otherwise = []

234271

235272suggestFillHole :: Diagnostic -> [(T.Text, [TextEdit])]

236−suggestFillHole Diagnostic{_range=_range@Range{..},..}

273+suggestFillHole Diagnostic{_range=_range,..}

237274-- ...Development/IDE/LSP/CodeAction.hs:103:9: warning:

238275-- * Found hole: _ :: Int -> String

239276-- * In the expression: _

@@ -268,20 +305,22 @@ suggestFillHole Diagnostic{_range=_range@Range{..},..}

268305

269306 | otherwise = []

270307

271−suggestExtendImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

272−suggestExtendImport contents Diagnostic{_range=_range,..}

308+suggestExtendImport :: Maybe DynFlags -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

309+suggestExtendImport (Just dflags) contents Diagnostic{_range=_range,..}

273310 | Just [binding, mod, srcspan] <-

274311 matchRegex _message

275312 "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\$(.*)\$.$"

276313 , Just c <- contents

314+ , POk _ (L _ name) <- runParser dflags (T.unpack binding) parseIdentifier

277315 = let range = case [ x | (x,"") <- readSrcSpan (T.unpack srcspan)] of

278316 [s] -> let x = srcSpanToRange s

279317 in x{_end = (_end x){_character = succ (_character (_end x))}}

280318 _ -> error "bug in srcspan parser"

281319 importLine = textInRange range c

282320 in [("Add " <> binding <> " to the import list of " <> mod

283− , [TextEdit range (addBindingToImportList binding importLine)])]

321+ , [TextEdit range (addBindingToImportList (T.pack $ printRdrName name) importLine)])]

284322 | otherwise = []

323+suggestExtendImport Nothing _ _ = []

285324

286325suggestFixConstructorImport :: Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

287326suggestFixConstructorImport _ Diagnostic{_range=_range,..}

@@ -299,29 +338,103 @@ suggestFixConstructorImport _ Diagnostic{_range=_range,..}

299338

300339suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]

301340suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}

302− | "Top-level binding with no type signature" `T.isInfixOf` _message = let

303− signature = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message

304− startOfLine = Position (_line _start) 0

305− beforeLine = Range startOfLine startOfLine

306− title = if isQuickFix then "add signature: " <> signature else signature

307− action = TextEdit beforeLine $ signature <> "\n"

308− in [(title, [action])]

309−suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}

310− | "Polymorphic local binding with no type signature" `T.isInfixOf` _message = let

341+ | _message =~

342+ ("(Top-level binding|Polymorphic local binding|Pattern synonym) with no type signature" :: T.Text) = let

311343 signature = removeInitialForAll

312344 $ T.takeWhile (\x -> x/='*' && x/='•')

313345 $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message

314− startOfLine = Position (_line _start) (_character _start)

346+ startOfLine = Position (_line _start) startCharacter

315347 beforeLine = Range startOfLine startOfLine

316348 title = if isQuickFix then "add signature: " <> signature else signature

317− action = TextEdit beforeLine $ signature <> "\n" <> T.replicate (_character _start) " "

349+ action = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " "

318350 in [(title, [action])]

319351 where removeInitialForAll :: T.Text -> T.Text

320352 removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))

321353 | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))

322354 | otherwise = nm <> ty

355+ startCharacter

356+ | "Polymorphic local binding" `T.isPrefixOf` _message

357+ = _character _start

358+ | otherwise

359+ = 0

360+

323361suggestSignature _ _ = []

324362

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+

325438topOfHoleFitsMarker :: T.Text

326439topOfHoleFitsMarker =

327440#if MIN_GHC_API_VERSION(8,6,0)

@@ -332,7 +445,7 @@ topOfHoleFitsMarker =

332445

333446mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit

334447mkRenameEdit contents range name =

335− if fromMaybe False maybeIsInfixFunction

448+ if maybeIsInfixFunction == Just True

336449 then TextEdit range ("`" <> name <> "`")

337450 else TextEdit range name

338451 where

@@ -414,7 +527,7 @@ rangesForBinding _ _ = []

414527rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]

415528rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]

416529rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]

417−rangesForBinding' b (L l x@IEThingAll{}) | showSDocUnsafe (ppr x) == b = [l]

530+rangesForBinding' b (L l (IEThingAll x)) | showSDocUnsafe (ppr x) == b = [l]

418531rangesForBinding' b (L l (IEThingWith thing _ inners labels))

419532 | showSDocUnsafe (ppr thing) == b = [l]

420533 | otherwise =

@@ -444,7 +557,7 @@ matchRegex message regex = case unifySpaces message =~~ regex of

444557 Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, bindings) -> Just bindings

445558 Nothing -> Nothing

446559

447−setHandlersCodeLens :: PartialHandlers

560+setHandlersCodeLens :: PartialHandlers c

448561setHandlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{

449562 LSP.codeLensHandler = withResponse RspCodeLens codeLens,

450563 LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand

@@ -455,51 +568,3 @@ filterNewlines = T.concat . T.lines

455568

456569unifySpaces :: T.Text -> T.Text

457570unifySpaces = T.unwords . T.words

458−

459−--------------------------------------------------------------------------------

460−

461−type PositionIndexedString = [(Position, Char)]

462−

463−indexedByPosition :: String -> PositionIndexedString

464−indexedByPosition = unfoldr f . (Position 0 0,) where

465− f (_, []) = Nothing

466− f (p@(Position l _), '\n' : rest) = Just ((p,'\n'), (Position (l+1) 0, rest))

467− f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c+1), rest))

468−

469−-- | Returns a tuple (before, contents, after)

470−unconsRange :: Range -> PositionIndexedString -> (PositionIndexedString, PositionIndexedString, PositionIndexedString)

471−unconsRange Range {..} indexedString = (before, mid, after)

472− where

473− (before, rest) = span ((/= _start) . fst) indexedString

474− (mid, after) = span ((/= _end) . fst) rest

475−

476−stripRange :: Range -> PositionIndexedString -> PositionIndexedString

477−stripRange r s = case unconsRange r s of

478− (b, _, a) -> b ++ a

479−

480−extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]

481−extendAllToIncludeCommaIfPossible _ [] = []

482−extendAllToIncludeCommaIfPossible indexedString (r : rr) = r' : extendAllToIncludeCommaIfPossible indexedString' rr

483− where

484− r' = case extendToIncludeCommaIfPossible indexedString r of

485− [] -> r

486− r' : _ -> r'

487− indexedString' = stripRange r' indexedString

488−

489−-- | Returns a sorted list of ranges with extended selections includindg preceding or trailing commas

490−extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]

491−extendToIncludeCommaIfPossible indexedString range =

492− -- a, |b|, c ===> a|, b|, c

493− [ range{_start = start'}

494− | (start', ',') : _ <- [before']

495− ]

496− ++

497− -- a, |b|, c ===> a, |b, |c

498− [ range{_end = end'}

499− | (_, ',') : rest <- [after']

500− , let (end', _) : _ = dropWhile (isSpace . snd) rest

501− ]

502− where

503− (before, _, after) = unconsRange range indexedString

504− after' = dropWhile (isSpace . snd) after

505− before' = dropWhile (isSpace . snd) (reverse before)

src/Development/IDE/Plugin/CodeAction/PositionIndexed.hsnew file+112

@@ -0,0 +1,112 @@

1+-- | Position indexed streams of characters

2+module Development.IDE.Plugin.CodeAction.PositionIndexed

3+ ( PositionIndexed

4+ , PositionIndexedString

5+ , indexedByPosition

6+ , indexedByPositionStartingFrom

7+ , extendAllToIncludeCommaIfPossible

8+ , mergeRanges

9+ )

10+where

11+

12+import Data.Char

13+import Data.List

14+import Language.Haskell.LSP.Types

15+

16+type PositionIndexed a = [(Position, a)]

17+

18+type PositionIndexedString = PositionIndexed Char

19+

20+-- | Add position indexing to a String.

21+--

22+-- > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡

23+-- > [ ((0,0),'h')

24+-- > , ((0,1),'e')

25+-- > , ((0,2),'y')

26+-- > , ((0,3),'\n')

27+-- > , ((1,0),' ')

28+-- > , ((1,1),'h')

29+-- > , ((1,2),'o')

30+-- > ]

31+indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString

32+indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where

33+ f (_, []) = Nothing

34+ f (p@(Position l _), '\n' : rest) =

35+ Just ((p, '\n'), (Position (l + 1) 0, rest))

36+ f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest))

37+

38+-- | Add position indexing to a String.

39+--

40+-- > indexedByPosition = indexedByPositionStartingFrom (Position 0 0)

41+indexedByPosition :: String -> PositionIndexedString

42+indexedByPosition = indexedByPositionStartingFrom (Position 0 0)

43+

44+-- | Returns a tuple (before, contents, after) if the range is present.

45+-- The range is present only if both its start and end positions are present

46+unconsRange

47+ :: Range

48+ -> PositionIndexed a

49+ -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a)

50+unconsRange Range {..} indexedString

51+ | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString

52+ , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest

53+ = Just (before, mid, after)

54+ | otherwise

55+ = Nothing

56+

57+-- | Strips out all the positions included in the range.

58+-- Returns 'Nothing' if the start or end of the range are not included in the input.

59+stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a)

60+stripRange r s = case unconsRange r s of

61+ Just (b, _, a) -> Just (b ++ a)

62+ Nothing -> Nothing

63+

64+-- | Returns the smallest possible set of disjoint ranges that is equivalent to the input.

65+-- Assumes input ranges are sorted on the start positions.

66+mergeRanges :: [Range] -> [Range]

67+mergeRanges (r : r' : rest)

68+ |

69+ -- r' is contained in r

70+ _end r > _end r' = mergeRanges (r : rest)

71+ |

72+ -- r and r' are overlapping

73+ _end r > _start r' = mergeRanges (r { _end = _end r' } : rest)

74+

75+ | otherwise = r : mergeRanges (r' : rest)

76+mergeRanges other = other

77+

78+-- | Returns a sorted list of ranges with extended selections including preceding or trailing commas

79+--

80+-- @

81+-- a, |b|, c ===> a|, b|, c

82+-- a, b, |c| ===> a, b|, c|

83+-- a, |b|, |c| ===> a|, b||, c|

84+-- @

85+extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]

86+extendAllToIncludeCommaIfPossible indexedString =

87+ mergeRanges . go indexedString . sortOn _start

88+ where

89+ go _ [] = []

90+ go input (r : rr)

91+ | r' : _ <- extendToIncludeCommaIfPossible input r

92+ , Just input' <- stripRange r' input

93+ = r' : go input' rr

94+ | otherwise

95+ = go input rr

96+

97+extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]

98+extendToIncludeCommaIfPossible indexedString range

99+ | Just (before, _, after) <- unconsRange range indexedString

100+ , after' <- dropWhile (isSpace . snd) after

101+ , before' <- dropWhile (isSpace . snd) (reverse before)

102+ =

103+ -- a, |b|, c ===> a|, b|, c

104+ [ range { _start = start' } | (start', ',') : _ <- [before'] ]

105+ ++

106+ -- a, |b|, c ===> a, |b, |c

107+ [ range { _end = end' }

108+ | (_, ',') : rest <- [after']

109+ , let (end', _) : _ = dropWhile (isSpace . snd) rest

110+ ]

111+ | otherwise

112+ = [range]

src/Development/IDE/Plugin/CodeAction/RuleTypes.hsnew file+61

@@ -0,0 +1,61 @@

1+{-# LANGUAGE TypeFamilies #-}

2+module Development.IDE.Plugin.CodeAction.RuleTypes

3+ (PackageExports(..), PackageExportsMap

4+ ,IdentInfo(..)

5+ ,mkIdentInfos

6+ ) where

8+import Avail (AvailInfo(..))

9+import Data.Hashable (Hashable)

10+import Control.DeepSeq (NFData)

11+import Data.Binary (Binary)

12+import Data.Text (pack, Text)

13+import Development.IDE.GHC.Util

14+import Development.Shake (RuleResult)

15+import Data.HashMap.Strict (HashMap)

16+import Data.Typeable (Typeable)

17+import GHC.Generics (Generic)

18+import Name

19+import FieldLabel (flSelector)

20+

21+type Identifier = Text

22+type ModuleName = Text

23+

24+data IdentInfo = IdentInfo

25+ { name :: !Identifier

26+ , rendered :: Text

27+ , parent :: !(Maybe Text)

28+ , isDatacon :: !Bool

29+ }

30+ deriving (Eq, Generic, Show)

31+

32+instance NFData IdentInfo

33+

34+mkIdentInfos :: AvailInfo -> [IdentInfo]

35+mkIdentInfos (Avail n) =

36+ [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)]

37+mkIdentInfos (AvailTC parent (n:nn) flds)

38+ -- Following the GHC convention that parent == n if parent is exported

39+ | n == parent

40+ = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) True

41+ | n <- nn ++ map flSelector flds

42+ ] ++

43+ [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing False]

44+ where

45+ parentP = pack $ prettyPrint parent

46+

47+mkIdentInfos (AvailTC _ nn flds)

48+ = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing True

49+ | n <- nn ++ map flSelector flds

50+ ]

51+

52+-- Rule type for caching Package Exports

53+type instance RuleResult PackageExports = PackageExportsMap

54+type PackageExportsMap = HashMap Identifier [(IdentInfo,ModuleName)]

55+

56+newtype PackageExports = PackageExports HscEnvEq

57+ deriving (Eq, Show, Typeable, Generic)

58+

59+instance Hashable PackageExports

60+instance NFData PackageExports

61+instance Binary PackageExports

src/Development/IDE/Plugin/CodeAction/Rules.hsnew file+61

@@ -0,0 +1,61 @@

1+module Development.IDE.Plugin.CodeAction.Rules

2+ ( rulePackageExports

3+ )

4+where

6+import Data.HashMap.Strict ( fromListWith )

7+import Data.Text ( Text

8+ , pack

9+ )

10+import Data.Traversable ( forM )

11+import Development.IDE.Core.Rules

12+import Development.IDE.GHC.Util

13+import Development.IDE.Plugin.CodeAction.RuleTypes

14+import Development.Shake

15+import GHC ( DynFlags(pkgState) )

16+import HscTypes ( IfaceExport

17+ , hsc_dflags

18+ , mi_exports

19+ )

20+import LoadIface

21+import Maybes

22+import Module ( Module(..)

23+ , ModuleName

24+ , moduleNameString

25+ )

26+import Packages ( explicitPackages

27+ , exposedModules

28+ , packageConfigId

29+ )

30+import TcRnMonad ( WhereFrom(ImportByUser)

31+ , initIfaceLoad

32+ )

33+

34+rulePackageExports :: Rules ()

35+rulePackageExports = defineNoFile $ \(PackageExports session) -> do

36+ let env = hscEnv session

37+ pkgst = pkgState (hsc_dflags env)

38+ depends = explicitPackages pkgst

39+ targets =

40+ [ (pkg, mn)

41+ | d <- depends

42+ , Just pkg <- [lookupPackageConfig d env]

43+ , (mn, _) <- exposedModules pkg

44+ ]

45+

46+ results <- forM targets $ \(pkg, mn) -> do

47+ modIface <- liftIO $ initIfaceLoad env $ loadInterface

48+ ""

49+ (Module (packageConfigId pkg) mn)

50+ (ImportByUser False)

51+ case modIface of

52+ Failed _err -> return mempty

53+ Succeeded mi -> do

54+ let avails = mi_exports mi

55+ return $ concatMap (unpackAvail mn) avails

56+ return $ fromListWith (++) $ concat results

57+

58+unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])]

59+unpackAvail mod =

60+ map (\id@IdentInfo {..} -> (name, [(id, pack $ moduleNameString mod)]))

61+ . mkIdentInfos

src/Development/IDE/Plugin/Completions.hs+32−17

@@ -1,7 +1,10 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE TypeFamilies #-}

3+#include "ghc-api-version.h"

35module Development.IDE.Plugin.Completions(plugin) where

7+import Control.Applicative

58import Language.Haskell.LSP.Messages

69import Language.Haskell.LSP.Types

710import qualified Language.Haskell.LSP.Core as LSP

@@ -10,8 +13,6 @@ import Language.Haskell.LSP.Types.Capabilities

1013import Development.Shake.Classes

1114import Development.Shake

1215import GHC.Generics

13−import Data.Maybe

14−import HscTypes

1516

1617import Development.IDE.Plugin

1718import Development.IDE.Core.Service

@@ -22,29 +23,39 @@ import Development.IDE.Core.RuleTypes

2223import Development.IDE.Core.Shake

2324import Development.IDE.GHC.Util

2425import Development.IDE.LSP.Server

25−import Development.IDE.Import.DependencyInformation

2626

27+#if !MIN_GHC_API_VERSION(8,6,0) || defined(GHC_LIB)

28+import Data.Maybe

29+import Development.IDE.Import.DependencyInformation

30+#endif

2731

28−plugin :: Plugin

32+plugin :: Plugin c

2933plugin = Plugin produceCompletions setHandlersCompletion

3034

3135produceCompletions :: Rules ()

3236produceCompletions =

3337 define $ \ProduceCompletions file -> do

34− deps <- maybe (TransitiveDependencies [] []) fst <$> useWithStale GetDependencies file

35− tms <- mapMaybe (fmap fst) <$> usesWithStale TypeCheck (transitiveModuleDeps deps)

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

3647 tm <- fmap fst <$> useWithStale TypeCheck file

3748 packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file

3849 case (tm, packageState) of

3950 (Just tm', Just packageState') -> do

40− cdata <- liftIO $ cacheDataProducer packageState' (hsc_dflags packageState')

41− (tmrModule tm') (map tmrModule tms)

42− return ([], Just (cdata, tm'))

51+ cdata <- liftIO $ cacheDataProducer packageState'

52+ (tmrModule tm') parsedDeps

53+ return ([], Just cdata)

4354 _ -> return ([], Nothing)

4455

4556

4657-- | Produce completions info for a file

47−type instance RuleResult ProduceCompletions = (CachedCompletions, TcModuleResult)

58+type instance RuleResult ProduceCompletions = CachedCompletions

4859

4960data ProduceCompletions = ProduceCompletions

5061 deriving (Eq, Show, Typeable, Generic)

@@ -55,7 +66,7 @@ instance Binary ProduceCompletions

5566

5667-- | Generate code actions.

5768getCompletionsLSP

58− :: LSP.LspFuncs ()

69+ :: LSP.LspFuncs c

5970 -> IdeState

6071 -> CompletionParams

6172 -> IO (Either ResponseError CompletionResponseResult)

@@ -66,23 +77,27 @@ getCompletionsLSP lsp ide

6677 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri

6778 fmap Right $ case (contents, uriToFilePath' uri) of

6879 (Just cnts, Just path) -> do

69− let npath = toNormalizedFilePath path

70− (ideOpts, compls) <- runAction ide ((,) <$> getIdeOptions <*> useWithStale ProduceCompletions npath)

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)

7186 case compls of

72− Just ((cci', tm'), mapping) -> do

73− let position' = fromCurrentPosition mapping position

87+ Just ((cci', _), (pm, mapping)) -> do

88+ let !position' = fromCurrentPosition mapping position

7489 pfix <- maybe (return Nothing) (flip VFS.getCompletionPrefix cnts) position'

7590 case (pfix, completionContext) of

7691 (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})

7792 -> return (Completions $ List [])

7893 (Just pfix', _) -> do

7994 let fakeClientCapabilities = ClientCapabilities Nothing Nothing Nothing Nothing

80− Completions . List <$> getCompletions ideOpts cci' (tmrModule tm') pfix' fakeClientCapabilities (WithSnippets True)

95+ Completions . List <$> getCompletions ideOpts cci' pm pfix' fakeClientCapabilities (WithSnippets True)

8196 _ -> return (Completions $ List [])

8297 _ -> return (Completions $ List [])

8398 _ -> return (Completions $ List [])

8499

85−setHandlersCompletion :: PartialHandlers

100+setHandlersCompletion :: PartialHandlers c

86101setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{

87102 LSP.completionHandler = withResponse RspCompletion getCompletionsLSP

88103 }

src/Development/IDE/Plugin/Completions/Logic.hs+43−47

@@ -1,4 +1,5 @@

11{-# LANGUAGE CPP #-}

2+#include "ghc-api-version.h"

23-- Mostly taken from "haskell-ide-engine"

34module Development.IDE.Plugin.Completions.Logic (

45 CachedCompletions

@@ -10,7 +11,7 @@ module Development.IDE.Plugin.Completions.Logic (

1011import Control.Applicative

1112import Data.Char (isSpace, isUpper)

1213import Data.Generics

13−import Data.List as List hiding (stripPrefix)

14+import Data.List.Extra as List hiding (stripPrefix)

1415import qualified Data.Map as Map

1516import Data.Maybe (fromMaybe, mapMaybe)

1617import qualified Data.Text as T

@@ -25,6 +26,12 @@ import Type

2526import Var

2627import Packages

2728import 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

2835

2936import Language.Haskell.LSP.Types

3037import Language.Haskell.LSP.Types.Capabilities

@@ -125,7 +132,7 @@ occNameToComKind ty oc

125132

126133mkCompl :: IdeOptions -> CompItem -> CompletionItem

127134mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} =

128− CompletionItem label kind ((colon <>) <$> typeText)

135+ CompletionItem label kind (List []) ((colon <>) <$> typeText)

129136 (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')

130137 Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)

131138 Nothing Nothing Nothing Nothing Nothing

@@ -155,7 +162,7 @@ getArgText typ = argText

155162 where

156163 argTypes = getArgs typ

157164 argText :: T.Text

158− argText = mconcat $ List.intersperse " " $ zipWith snippet [1..] argTypes

165+ argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes

159166 snippet :: Int -> Type -> T.Text

160167 snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"

161168 getArgs :: Type -> [Type]

@@ -169,38 +176,44 @@ getArgText typ = argText

169176 then getArgs ret

170177 else Prelude.filter (not . isDictTy) args

171178 | 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

172183 | isCoercionTy t = maybe [] (getArgs . snd) (splitCoercionType_maybe t)

184+#endif

173185 | otherwise = []

174186

175187mkModCompl :: T.Text -> CompletionItem

176188mkModCompl label =

177− CompletionItem label (Just CiModule) Nothing

189+ CompletionItem label (Just CiModule) (List []) Nothing

178190 Nothing Nothing Nothing Nothing Nothing Nothing Nothing

179191 Nothing Nothing Nothing Nothing Nothing

180192

181193mkImportCompl :: T.Text -> T.Text -> CompletionItem

182194mkImportCompl enteredQual label =

183− CompletionItem m (Just CiModule) (Just label)

195+ CompletionItem m (Just CiModule) (List []) (Just label)

184196 Nothing Nothing Nothing Nothing Nothing Nothing Nothing

185197 Nothing Nothing Nothing Nothing Nothing

186− where

198+ where

187199 m = fromMaybe "" (T.stripPrefix enteredQual label)

188200

189201mkExtCompl :: T.Text -> CompletionItem

190202mkExtCompl label =

191− CompletionItem label (Just CiKeyword) Nothing

203+ CompletionItem label (Just CiKeyword) (List []) Nothing

192204 Nothing Nothing Nothing Nothing Nothing Nothing Nothing

193205 Nothing Nothing Nothing Nothing Nothing

194206

195207mkPragmaCompl :: T.Text -> T.Text -> CompletionItem

196208mkPragmaCompl label insertText =

197− CompletionItem label (Just CiKeyword) Nothing

209+ CompletionItem label (Just CiKeyword) (List []) Nothing

198210 Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)

199211 Nothing Nothing Nothing Nothing Nothing

200212

201−cacheDataProducer :: HscEnv -> DynFlags -> TypecheckedModule -> [TypecheckedModule] -> IO CachedCompletions

202−cacheDataProducer packageState dflags tm tcs = do

213+cacheDataProducer :: HscEnv -> TypecheckedModule -> [ParsedModule] -> IO CachedCompletions

214+cacheDataProducer packageState tm deps = do

203215 let parsedMod = tm_parsed_module tm

216+ dflags = hsc_dflags packageState

204217 curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod

205218 Just (_,limports,_,_) = tm_renamed_source tm

206219

@@ -257,18 +270,18 @@ cacheDataProducer packageState dflags tm tcs = do

257270 let typ = Just $ varType var

258271 name = Var.varName var

259272 label = T.pack $ showGhc name

260− docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm:tcs) name

273+ docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) name

261274 return $ CI name (showModName curMod) typ label Nothing docs

262275

263276 toCompItem :: ModuleName -> Name -> IO CompItem

264277 toCompItem mn n = do

265− docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm:tcs) n

278+ docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) n

266279-- lookupName uses runInteractiveHsc, i.e., GHCi stuff which does not work with GHCi

267280-- and leads to fun errors like "Cannot continue after interface file error".

268281#ifdef GHC_LIB

269282 let ty = Right Nothing

270283#else

271− ty <- runGhcEnv packageState $ catchSrcErrors "completion" $ do

284+ ty <- evalGhcEnv packageState $ catchSrcErrors "completion" $ do

272285 name' <- lookupName n

273286 return $ name' >>= safeTyThingType

274287#endif

@@ -291,19 +304,16 @@ toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x

291304 | otherwise = x { _insertTextFormat = Just PlainText

292305 , _insertText = Nothing

293306 }

294− where supported = fromMaybe False (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)

307+ where supported = Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)

295308

296309-- | Returns the cached completions for the given module and position.

297−getCompletions :: IdeOptions -> CachedCompletions -> TypecheckedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]

310+getCompletions :: IdeOptions -> CachedCompletions -> ParsedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]

298311getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }

299− tm prefixInfo caps withSnippets = do

312+ pm prefixInfo caps withSnippets = do

300313 let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo

301314 enteredQual = if T.null prefixModule then "" else prefixModule <> "."

302315 fullPrefix = enteredQual <> prefixText

303316

304− -- default to value context if no explicit context

305− context = fromMaybe ValueContext $ getCContext pos (tm_parsed_module tm)

306−

307317 {- correct the position by moving 'foo :: Int -> String -> '

308318 ^

309319 to 'foo :: Int -> String -> '

@@ -332,10 +342,11 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl

332342 where

333343 isTypeCompl = isTcOcc . occName . origName

334344 -- completions specific to the current context

335− ctxCompls' = case context of

336− TypeContext -> filter isTypeCompl compls

337− ValueContext -> filter (not . isTypeCompl) compls

338− _ -> filter (not . isTypeCompl) compls

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

339350 -- Add whether the text to insert has backticks

340351 ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'

341352

@@ -361,7 +372,9 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl

361372 filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules

362373 filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas

363374 filtOptsCompls = filtListWith mkExtCompl

364− filtKeywordCompls = if T.null prefixModule then filtListWith mkExtCompl keywords else []

375+ filtKeywordCompls

376+ | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)

377+ | otherwise = []

365378

366379 stripLeading :: Char -> String -> String

367380 stripLeading _ [] = []

@@ -382,13 +395,17 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl

382395 = filtModNameCompls ++ map (toggleSnippets caps withSnippets

383396 . mkCompl ideOpts . stripAutoGenerated) filtCompls

384397 ++ filtKeywordCompls

385−

398+

386399 return result

387400

388401-- The supported languages and extensions

389402languagesAndExts :: [T.Text]

403+#if MIN_GHC_API_VERSION(8,10,0)

404+languagesAndExts = map T.pack $ DynFlags.supportedLanguagesAndExtensions ( PlatformMini ArchUnknown OSUnknown )

405+#else

390406languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions

391−

407+#endif

408+

392409-- ---------------------------------------------------------------------

393410-- helper functions for pragmas

394411-- ---------------------------------------------------------------------

@@ -511,24 +528,3 @@ prefixes =

511528 , "$c"

512529 , "$m"

513530 ]

514−

515−keywords :: [T.Text]

516−keywords =

517− [

518− -- From https://wiki.haskell.org/Keywords

519− "as"

520− , "case", "of"

521− , "class", "instance", "type"

522− , "data", "family", "newtype"

523− , "default"

524− , "deriving"

525− , "do", "mdo", "proc", "rec"

526− , "forall"

527− , "foreign"

528− , "hiding"

529− , "if", "then", "else"

530− , "import", "qualified", "hiding"

531− , "infix", "infixl", "infixr"

532− , "let", "in", "where"

533− , "module"

534− ]

src/Development/IDE/Spans/AtPoint.hs+17−18

@@ -13,15 +13,12 @@ import Development.IDE.GHC.Orphans()

1313import Development.IDE.Types.Location

1414

1515-- DAML compiler and infrastructure

16−import Development.Shake

17−import Development.IDE.GHC.Util

1816import Development.IDE.GHC.Compat

1917import Development.IDE.Types.Options

2018import Development.IDE.Spans.Type as SpanInfo

2119import Development.IDE.Spans.Common (spanDocToMarkdown)

2220

2321-- GHC API imports

24−import Avail

2522import DynFlags

2623import FastString

2724import Name

@@ -40,14 +37,13 @@ import qualified Data.Text as T

4037-- | Locate the definition of the name at a given position.

4138gotoDefinition

4239 :: MonadIO m

43− => (FilePath -> m (Maybe HieFile))

40+ => (Module -> m (Maybe (HieFile, FilePath)))

4441 -> IdeOptions

45− -> HscEnv

4642 -> [SpanInfo]

4743 -> Position

4844 -> m (Maybe Location)

49−gotoDefinition getHieFile ideOpts pkgState srcSpans pos =

50− listToMaybe <$> locationsAtPoint getHieFile ideOpts pkgState pos srcSpans

45+gotoDefinition getHieFile ideOpts srcSpans pos =

46+ listToMaybe <$> locationsAtPoint getHieFile ideOpts pos srcSpans

5147

5248-- | Synopsis for the name at a given position.

5349atPoint

@@ -87,7 +83,7 @@ atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do

8783 constraintsOverFVs = filter (\cnt -> not (tyCoVarsOfType cnt `disjointVarSet` thisFVs)) cnts

8884 constraintsT = T.intercalate ", " (map showName constraintsOverFVs)

8985

90− typeAnnotation = case constraintsOverFVs of

86+ typeAnnotation = case constraintsOverFVs of

9187 [] -> colon <> showName typ

9288 [_] -> colon <> constraintsT <> "\n=> " <> showName typ

9389 _ -> colon <> "(" <> constraintsT <> ")\n=> " <> showName typ

@@ -119,8 +115,15 @@ atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do

119115 Just name -> any (`isInfixOf` getOccString name) ["==", "showsPrec"]

120116 Nothing -> False

121117

122−locationsAtPoint :: forall m . MonadIO m => (FilePath -> m (Maybe HieFile)) -> IdeOptions -> HscEnv -> Position -> [SpanInfo] -> m [Location]

123−locationsAtPoint getHieFile IdeOptions{..} pkgState pos =

118+locationsAtPoint

119+ :: forall m

120+ . MonadIO m

121+ => (Module -> m (Maybe (HieFile, FilePath)))

122+ -> IdeOptions

123+ -> Position

124+ -> [SpanInfo]

125+ -> m [Location]

126+locationsAtPoint getHieFile _ideOptions pos =

124127 fmap (map srcSpanToLocation) . mapMaybeM (getSpan . spaninfoSource) . spansAtPoint pos

125128 where getSpan :: SpanSource -> m (Maybe SrcSpan)

126129 getSpan NoSource = pure Nothing

@@ -130,20 +133,16 @@ locationsAtPoint getHieFile IdeOptions{..} pkgState pos =

130133 sp@(RealSrcSpan _) -> pure $ Just sp

131134 sp@(UnhelpfulSpan _) -> runMaybeT $ do

132135 guard (sp /= wiredInSrcSpan)

133− -- This case usually arises when the definition is in an external package.

136+ -- This case usually arises when the definition is in an external package (DAML only).

134137 -- In this case the interface files contain garbage source spans

135138 -- so we instead read the .hie files to get useful source spans.

136139 mod <- MaybeT $ return $ nameModule_maybe name

137− let unitId = moduleUnitId mod

138− pkgConfig <- MaybeT $ pure $ lookupPackageConfig unitId pkgState

139− hiePath <- MaybeT $ liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod

140− hieFile <- MaybeT $ getHieFile hiePath

141− avail <- MaybeT $ pure $ listToMaybe (filterAvails (eqName name) $ hie_exports hieFile)

142− srcPath <- MaybeT $ liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod

140+ (hieFile, srcPath) <- MaybeT $ getHieFile mod

141+ avail <- MaybeT $ pure $ find (eqName name . snd) $ hieExportNames hieFile

143142 -- The location will point to the source file used during compilation.

144143 -- This file might no longer exists and even if it does the path will be relative

145144 -- to the compilation directory which we don’t know.

146− let span = setFileName srcPath $ nameSrcSpan $ availName avail

145+ let span = setFileName srcPath $ fst avail

147146 pure span

148147 -- We ignore uniques and source spans and only compare the name and the module.

149148 eqName :: Name -> Name -> Bool

src/Development/IDE/Spans/Calculate.hs+34−25

@@ -20,6 +20,7 @@ import DataCon

2020import Desugar

2121import GHC

2222import GhcMonad

23+import HscTypes

2324import FastString (mkFastString)

2425import OccName

2526import Development.IDE.Types.Location

@@ -49,28 +50,36 @@ import Development.IDE.Spans.Documentation

4950-- | Get source span info, used for e.g. AtPoint and Goto Definition.

5051getSrcSpanInfos

5152 :: HscEnv

52− -> [(Located ModuleName, Maybe NormalizedFilePath)]

53+ -> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order

5354 -> TcModuleResult

54− -> [TcModuleResult]

55+ -> [ParsedModule] -- ^ Dependencies parsed, optional

56+ -> [ModIface] -- ^ Dependencies module interfaces, required

5557 -> IO SpansInfo

56−getSrcSpanInfos env imports tc tms =

57− runGhcEnv env $

58− getSpanInfo imports (tmrModule tc) (map tmrModule tms)

58+getSrcSpanInfos env imports tc parsedDeps deps =

59+ evalGhcEnv env $

60+ getSpanInfo imports (tmrModule tc) parsedDeps deps

5961

6062-- | Get ALL source spans in the module.

6163getSpanInfo :: GhcMonad m

6264 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports

6365 -> TypecheckedModule

64− -> [TypecheckedModule]

66+ -> [ParsedModule]

67+ -> [ModIface]

6568 -> m SpansInfo

66−getSpanInfo mods tcm tcms =

67− do let tcs = tm_typechecked_source tcm

69+getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps deps =

70+ do let tcs = tm_typechecked_source

6871 bs = listifyAllSpans tcs :: [LHsBind GhcTc]

6972 es = listifyAllSpans tcs :: [LHsExpr GhcTc]

7073 ps = listifyAllSpans' tcs :: [Pat GhcTc]

71− ts = listifyAllSpans $ tm_renamed_source tcm :: [LHsType GhcRn]

72− allModules = tcm:tcms

73− funBinds = funBindMap $ tm_parsed_module tcm

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+

7483 bts <- mapM (getTypeLHsBind allModules funBinds) bs -- binds

7584 ets <- mapM (getTypeLHsExpr allModules) es -- expressions

7685 pts <- mapM (getTypeLPat allModules) ps -- patterns

@@ -117,19 +126,19 @@ ieLNames _ = []

117126

118127-- | Get the name and type of a binding.

119128getTypeLHsBind :: (GhcMonad m)

120− => [TypecheckedModule]

129+ => [ParsedModule]

121130 -> OccEnv (HsBind GhcPs)

122131 -> LHsBind GhcTc

123132 -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]

124−getTypeLHsBind tms funBinds (L _spn FunBind{fun_id = pid})

133+getTypeLHsBind deps funBinds (L _spn FunBind{fun_id = pid})

125134 | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) = do

126135 let name = getName (unLoc pid)

127− docs <- getDocumentationTryGhc tms name

136+ docs <- getDocumentationTryGhc deps name

128137 return [(Named name, getLoc mc_fun, Just (varType (unLoc pid)), docs) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]

129138-- In theory this shouldn’t ever fail but if it does, we can at least show the first clause.

130−getTypeLHsBind tms _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do

139+getTypeLHsBind deps _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = do

131140 let name = getName (unLoc pid)

132− docs <- getDocumentationTryGhc tms name

141+ docs <- getDocumentationTryGhc deps name

133142 return [(Named name, getLoc pid, Just (varType (unLoc pid)), docs)]

134143getTypeLHsBind _ _ _ = return []

135144

@@ -142,17 +151,17 @@ getConstraintsLHsBind _ = []

142151

143152-- | Get the name and type of an expression.

144153getTypeLHsExpr :: (GhcMonad m)

145− => [TypecheckedModule]

154+ => [ParsedModule]

146155 -> LHsExpr GhcTc

147156 -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))

148−getTypeLHsExpr tms e = do

157+getTypeLHsExpr deps e = do

149158 hs_env <- getSession

150159 (_, mbe) <- liftIO (deSugarExpr hs_env e)

151160 case mbe of

152161 Just expr -> do

153162 let ss = getSpanSource (unLoc e)

154163 docs <- case ss of

155− Named n -> getDocumentationTryGhc tms n

164+ Named n -> getDocumentationTryGhc deps n

156165 _ -> return emptySpanDoc

157166 return $ Just (ss, getLoc e, Just (CoreUtils.exprType expr), docs)

158167 Nothing -> return Nothing

@@ -198,13 +207,13 @@ getTypeLHsExpr tms e = do

198207

199208-- | Get the name and type of a pattern.

200209getTypeLPat :: (GhcMonad m)

201− => [TypecheckedModule]

210+ => [ParsedModule]

202211 -> Pat GhcTc

203212 -> m (Maybe (SpanSource, SrcSpan, Maybe Type, SpanDoc))

204−getTypeLPat tms pat = do

213+getTypeLPat deps pat = do

205214 let (src, spn) = getSpanSource pat

206215 docs <- case src of

207− Named n -> getDocumentationTryGhc tms n

216+ Named n -> getDocumentationTryGhc deps n

208217 _ -> return emptySpanDoc

209218 return $ Just (src, spn, Just (hsPatType pat), docs)

210219 where

@@ -216,12 +225,12 @@ getTypeLPat tms pat = do

216225

217226getLHsType

218227 :: GhcMonad m

219− => [TypecheckedModule]

228+ => [ParsedModule]

220229 -> LHsType GhcRn

221230 -> m [(SpanSource, SrcSpan, Maybe Type, SpanDoc)]

222−getLHsType tms (L spn (HsTyVar U _ v)) = do

231+getLHsType deps (L spn (HsTyVar U _ v)) = do

223232 let n = unLoc v

224− docs <- getDocumentationTryGhc tms n

233+ docs <- getDocumentationTryGhc deps n

225234#ifdef GHC_LIB

226235 let ty = Right Nothing

227236#else

src/Development/IDE/Spans/Common.hs+4−4

@@ -18,6 +18,7 @@ module Development.IDE.Spans.Common (

1818import Data.Data

1919import qualified Data.Generics

2020import qualified Data.Text as T

21+import Data.List.Extra

2122

2223import GHC

2324import Outputable

@@ -28,7 +29,6 @@ import DataCon

2829import Var

2930#endif

3031

31−import Data.Char (isSpace)

3232import qualified Documentation.Haddock.Parser as H

3333import qualified Documentation.Haddock.Types as H

3434

@@ -135,9 +135,9 @@ haddockToMarkdown (H.DocHeader (H.Header level title))

135135 = replicate level '#' ++ " " ++ haddockToMarkdown title

136136

137137haddockToMarkdown (H.DocUnorderedList things)

138− = '\n' : (unlines $ map (("+ " ++) . dropWhile isSpace . splitForList . haddockToMarkdown) things)

138+ = '\n' : (unlines $ map (("+ " ++) . trimStart . splitForList . haddockToMarkdown) things)

139139haddockToMarkdown (H.DocOrderedList things)

140− = '\n' : (unlines $ map (("1. " ++) . dropWhile isSpace . splitForList . haddockToMarkdown) things)

140+ = '\n' : (unlines $ map (("1. " ++) . trimStart . splitForList . haddockToMarkdown) things)

141141haddockToMarkdown (H.DocDefList things)

142142 = '\n' : (unlines $ map (\(term, defn) -> "+ **" ++ haddockToMarkdown term ++ "**: " ++ haddockToMarkdown defn) things)

143143

@@ -159,4 +159,4 @@ splitForList :: String -> String

159159splitForList s

160160 = case lines s of

161161 [] -> ""

162− (first:rest) -> unlines $ first : map ((" " ++) . dropWhile isSpace) rest

162+ (first:rest) -> unlines $ first : map ((" " ++) . trimStart) rest

src/Development/IDE/Spans/Documentation.hs+21−19

@@ -14,33 +14,33 @@ import Data.List.Extra

1414import qualified Data.Map as M

1515import Data.Maybe

1616import qualified Data.Text as T

17+import Development.IDE.GHC.Compat

1718import Development.IDE.GHC.Error

1819import Development.IDE.Spans.Common

1920import FastString

20−import GHC

2121import SrcLoc

2222

2323

2424getDocumentationTryGhc

2525 :: GhcMonad m

26− => [TypecheckedModule]

26+ => [ParsedModule]

2727 -> Name

2828 -> m SpanDoc

2929-- getDocs goes through the GHCi codepaths which cause problems on ghc-lib.

3030-- See https://github.com/digital-asset/daml/issues/4152 for more details.

3131#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)

32−getDocumentationTryGhc tcs name = do

32+getDocumentationTryGhc sources name = do

3333 res <- catchSrcErrors "docs" $ getDocs name

3434 case res of

3535 Right (Right (Just docs, _)) -> return $ SpanDocString docs

36− _ -> return $ SpanDocText $ getDocumentation tcs name

36+ _ -> return $ SpanDocText $ getDocumentation sources name

3737#else

38−getDocumentationTryGhc tcs name = do

39− return $ SpanDocText $ getDocumentation tcs name

38+getDocumentationTryGhc sources name = do

39+ return $ SpanDocText $ getDocumentation sources name

4040#endif

4141

4242getDocumentation

43− :: [TypecheckedModule] -- ^ All of the possible modules it could be defined in.

43+ :: [ParsedModule] -- ^ All of the possible modules it could be defined in.

4444 -> Name -- ^ The name you want documentation for.

4545 -> [T.Text]

4646-- This finds any documentation between the name you want

@@ -50,16 +50,18 @@ getDocumentation

5050-- may be edge cases where it is very wrong).

5151-- TODO : Build a version of GHC exactprint to extract this information

5252-- more accurately.

53−getDocumentation tcs targetName = fromMaybe [] $ do

53+getDocumentation sources targetName = fromMaybe [] $ do

5454 -- Find the module the target is defined in.

5555 targetNameSpan <- realSpan $ nameSrcSpan targetName

5656 tc <-

5757 find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)

58− $ reverse tcs -- TODO : Is reversing the list here really neccessary?

59− -- Names bound by the module (we want to exclude non-"top-level"

60− -- bindings but unfortunately we get all here).

61− let bs = mapMaybe name_of_bind

62− (listifyAllSpans (tm_typechecked_source tc) :: [LHsBind GhcTc])

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+ ]

6365 -- Sort the names' source spans.

6466 let sortedSpans = sortedNameSpans bs

6567 -- Now go ahead and extract the docs.

@@ -81,16 +83,16 @@ getDocumentation tcs targetName = fromMaybe [] $ do

8183 where

8284 -- Get the name bound by a binding. We only concern ourselves with

8385 -- @FunBind@ (which covers functions and variables).

84− name_of_bind :: LHsBind GhcTc -> Maybe Name

85− name_of_bind (L _ FunBind {fun_id}) = Just (getName (unLoc fun_id))

86+ name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)

87+ name_of_bind FunBind {fun_id} = Just fun_id

8688 name_of_bind _ = Nothing

8789 -- Get source spans from names, discard unhelpful spans, remove

8890 -- duplicates and sort.

89− sortedNameSpans :: [Name] -> [RealSrcSpan]

90− sortedNameSpans ls = nubSort (mapMaybe (realSpan . nameSrcSpan) ls)

91+ sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]

92+ sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)

9193 isBetween target before after = before <= target && target <= after

92− ann = snd . pm_annotations . tm_parsed_module

93− annotationFileName :: TypecheckedModule -> Maybe FastString

94+ ann = snd . pm_annotations

95+ annotationFileName :: ParsedModule -> Maybe FastString

9496 annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann

9597 realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]

9698 realSpans =

src/Development/IDE/Types/Diagnostics.hs+19−5

@@ -6,10 +6,12 @@ module Development.IDE.Types.Diagnostics (

66 LSP.Diagnostic(..),

77 ShowDiagnostic(..),

88 FileDiagnostic,

9+ IdeResult,

910 LSP.DiagnosticSeverity(..),

1011 DiagnosticStore,

1112 List(..),

1213 ideErrorText,

14+ ideErrorWithSource,

1315 showDiagnostics,

1416 showDiagnosticsColored,

1517 ) where

@@ -18,7 +20,7 @@ import Control.DeepSeq

1820import Data.Maybe as Maybe

1921import qualified Data.Text as T

2022import Data.Text.Prettyprint.Doc

21−import Language.Haskell.LSP.Types as LSP (

23+import Language.Haskell.LSP.Types as LSP (DiagnosticSource,

2224 DiagnosticSeverity(..)

2325 , Diagnostic(..)

2426 , List(..)

@@ -30,15 +32,27 @@ import Data.Text.Prettyprint.Doc.Render.Terminal (Color(..), color)

3032

3133import Development.IDE.Types.Location

3234

35+-- A rule on a file should only return diagnostics for that given file. It should

36+-- not propagate diagnostic errors through multiple phases.

37+type IdeResult v = ([FileDiagnostic], Maybe v)

3338

3439ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic

35−ideErrorText fp msg = (fp, ShowDiag, LSP.Diagnostic {

40+ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError)

41+

42+ideErrorWithSource

43+ :: Maybe DiagnosticSource

44+ -> Maybe DiagnosticSeverity

45+ -> a

46+ -> T.Text

47+ -> (a, ShowDiagnostic, Diagnostic)

48+ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic {

3649 _range = noRange,

37− _severity = Just LSP.DsError,

50+ _severity = sev,

3851 _code = Nothing,

39− _source = Just "compiler",

52+ _source = source,

4053 _message = msg,

41− _relatedInformation = Nothing

54+ _relatedInformation = Nothing,

55+ _tags = Nothing

4256 })

4357

4458-- | Defines whether a particular diagnostic should be reported

src/Development/IDE/Types/Location.hs+24−115

@@ -10,15 +10,16 @@ module Development.IDE.Types.Location

1010 , Position(..)

1111 , showPosition

1212 , Range(..)

13− , Uri(..)

14− , NormalizedUri

13+ , LSP.Uri(..)

14+ , LSP.NormalizedUri

1515 , LSP.toNormalizedUri

1616 , LSP.fromNormalizedUri

17− , NormalizedFilePath

17+ , LSP.NormalizedFilePath

1818 , fromUri

19− , toNormalizedFilePath

20− , fromNormalizedFilePath

21− , filePathToUri

19+ , emptyFilePath

20+ , emptyPathUri

21+ , toNormalizedFilePath'

22+ , LSP.fromNormalizedFilePath

2223 , filePathToUri'

2324 , uriToFilePath'

2425 , readSrcSpan

@@ -26,134 +27,42 @@ module Development.IDE.Types.Location

2627

2728import Control.Applicative

2829import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..))

29−import Control.DeepSeq

3030import Control.Monad

31−import Data.Binary

32−import Data.Maybe as Maybe

33−import Data.Hashable

31+import Data.Hashable (Hashable(hash))

3432import Data.String

35−import qualified Data.Text as T

3633import FastString

37−import Network.URI

38−import System.FilePath

39−import qualified System.FilePath.Posix as FPP

40−import qualified System.FilePath.Windows as FPW

41−import System.Info.Extra

4234import qualified Language.Haskell.LSP.Types as LSP

43−import Language.Haskell.LSP.Types as LSP (

44− filePathToUri

45− , NormalizedUri(..)

46− , Uri(..)

47− , toNormalizedUri

48− , fromNormalizedUri

49− )

5035import SrcLoc as GHC

5136import Text.ParserCombinators.ReadP as ReadP

52−import GHC.Generics

37+import Data.Maybe (fromMaybe)

5338

54−

55−-- | Newtype wrapper around FilePath that always has normalized slashes.

56−-- The NormalizedUri and hash of the FilePath are cached to avoided

57−-- repeated normalisation when we need to compute them (which is a lot).

58−--

59−-- This is one of the most performance critical parts of ghcide, do not

60−-- modify it without profiling.

61−data NormalizedFilePath = NormalizedFilePath NormalizedUriWrapper !Int !FilePath

62− deriving (Generic, Eq, Ord)

63−

64−instance NFData NormalizedFilePath where

65−instance Binary NormalizedFilePath where

66− put (NormalizedFilePath _ _ fp) = put fp

67− get = do

68− v <- Data.Binary.get :: Get FilePath

69− return (toNormalizedFilePath v)

70−

71−

72−instance Show NormalizedFilePath where

73− show (NormalizedFilePath _ _ fp) = "NormalizedFilePath " ++ show fp

74−

75−instance Hashable NormalizedFilePath where

76− hash (NormalizedFilePath _ h _) = h

77−

78−-- Just to define NFData and Binary

79−newtype NormalizedUriWrapper =

80− NormalizedUriWrapper { unwrapNormalizedFilePath :: NormalizedUri }

81− deriving (Show, Generic, Eq, Ord)

82−

83−instance NFData NormalizedUriWrapper where

84− rnf = rwhnf

85−

86−

87−instance Hashable NormalizedUriWrapper where

88−

89−instance IsString NormalizedFilePath where

90− fromString = toNormalizedFilePath

91−

92−toNormalizedFilePath :: FilePath -> NormalizedFilePath

39+toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath

9340-- We want to keep empty paths instead of normalising them to "."

94−toNormalizedFilePath "" = NormalizedFilePath (NormalizedUriWrapper emptyPathUri) (hash ("" :: String)) ""

95−toNormalizedFilePath fp =

96− let nfp = normalise fp

97− in NormalizedFilePath (NormalizedUriWrapper $ filePathToUriInternal' nfp) (hash nfp) nfp

41+toNormalizedFilePath' "" = emptyFilePath

42+toNormalizedFilePath' fp = LSP.toNormalizedFilePath fp

9843

99−fromNormalizedFilePath :: NormalizedFilePath -> FilePath

100−fromNormalizedFilePath (NormalizedFilePath _ _ fp) = fp

44+emptyFilePath :: LSP.NormalizedFilePath

45+emptyFilePath = LSP.NormalizedFilePath emptyPathUri ""

10146

10247-- | We use an empty string as a filepath when we don’t have a file.

10348-- However, haskell-lsp doesn’t support that in uriToFilePath and given

10449-- that it is not a valid filepath it does not make sense to upstream a fix.

10550-- So we have our own wrapper here that supports empty filepaths.

106−uriToFilePath' :: Uri -> Maybe FilePath

51+uriToFilePath' :: LSP.Uri -> Maybe FilePath

10752uriToFilePath' uri

108− | uri == fromNormalizedUri emptyPathUri = Just ""

53+ | uri == LSP.fromNormalizedUri emptyPathUri = Just ""

10954 | otherwise = LSP.uriToFilePath uri

11055

111−emptyPathUri :: NormalizedUri

112−emptyPathUri = filePathToUriInternal' ""

113−

114−filePathToUri' :: NormalizedFilePath -> NormalizedUri

115−filePathToUri' (NormalizedFilePath (NormalizedUriWrapper u) _ _) = u

56+emptyPathUri :: LSP.NormalizedUri

57+emptyPathUri =

58+ let s = "file://"

59+ in LSP.NormalizedUri (hash s) s

11660

117−filePathToUriInternal' :: FilePath -> NormalizedUri

118−filePathToUriInternal' fp = toNormalizedUri $ Uri $ T.pack $ LSP.fileScheme <> "//" <> platformAdjustToUriPath fp

119− where

120− -- The definitions below are variants of the corresponding functions in Language.Haskell.LSP.Types.Uri that assume that

121− -- the filepath has already been normalised. This is necessary since normalising the filepath has a nontrivial cost.

122−

123− toNormalizedUri :: Uri -> NormalizedUri

124− toNormalizedUri (Uri t) =

125− NormalizedUri $ T.pack $ escapeURIString isUnescapedInURI $ unEscapeString $ T.unpack t

126−

127− platformAdjustToUriPath :: FilePath -> String

128− platformAdjustToUriPath srcPath

129− | isWindows = '/' : escapedPath

130− | otherwise = escapedPath

131− where

132− (splitDirectories, splitDrive)

133− | isWindows =

134− (FPW.splitDirectories, FPW.splitDrive)

135− | otherwise =

136− (FPP.splitDirectories, FPP.splitDrive)

137− escapedPath =

138− case splitDrive srcPath of

139− (drv, rest) ->

140− convertDrive drv `FPP.joinDrive`

141− FPP.joinPath (map (escapeURIString unescaped) $ splitDirectories rest)

142− -- splitDirectories does not remove the path separator after the drive so

143− -- we do a final replacement of \ to /

144− convertDrive drv

145− | isWindows && FPW.hasTrailingPathSeparator drv =

146− FPP.addTrailingPathSeparator (init drv)

147− | otherwise = drv

148− unescaped c

149− | isWindows = isUnreserved c || c `elem` [':', '\\', '/']

150− | otherwise = isUnreserved c || c == '/'

151−

152−

153−

154−fromUri :: LSP.NormalizedUri -> NormalizedFilePath

155−fromUri = toNormalizedFilePath . fromMaybe noFilePath . uriToFilePath' . fromNormalizedUri

61+filePathToUri' :: LSP.NormalizedFilePath -> LSP.NormalizedUri

62+filePathToUri' = LSP.normalizedFilePathToUri

15663

64+fromUri :: LSP.NormalizedUri -> LSP.NormalizedFilePath

65+fromUri = fromMaybe (toNormalizedFilePath' noFilePath) . LSP.uriToNormalizedFilePath

15766

15867noFilePath :: FilePath

15968noFilePath = "<unknown>"

src/Development/IDE/Types/Options.hs+35−8

@@ -12,25 +12,25 @@ module Development.IDE.Types.Options

1212 , clientSupportsProgress

1313 , IdePkgLocationOptions(..)

1414 , defaultIdeOptions

15+ , IdeResult

1516 ) where

1617

17−import Data.Maybe

1818import Development.Shake

1919import Development.IDE.GHC.Util

2020import GHC hiding (parseModule, typecheckModule)

2121import GhcPlugins as GHC hiding (fst3, (<>))

2222import qualified Language.Haskell.LSP.Types.Capabilities as LSP

23+import qualified Data.Text as T

24+import Development.IDE.Types.Diagnostics

2325

2426data IdeOptions = IdeOptions

2527 { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource

2628 -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings

2729 -- and a list of errors, along with a new parse tree.

28− , optGhcSession :: IO (FilePath -> Action HscEnvEq)

30+ , optGhcSession :: Action (FilePath -> Action (IdeResult HscEnvEq))

2931 -- ^ Setup a GHC session for a given file, e.g. @Foo.hs@.

30− -- The 'IO' will be called once, then the resulting function will be applied once per file.

32+ -- For the same 'ComponentOptions' from hie-bios, the resulting function will be applied once per file.

3133 -- It is desirable that many files get the same 'HscEnvEq', so that more IDE features work.

32− -- You should not use 'newCacheIO' to get that caching, because of

33− -- https://github.com/ndmitchell/shake/issues/725.

3434 , optPkgLocationOpts :: IdePkgLocationOptions

3535 -- ^ How to locate source and @.hie@ files given a module name.

3636 , optExtensions :: [String]

@@ -43,12 +43,17 @@ data IdeOptions = IdeOptions

4343 -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds.

4444 , optShakeProfiling :: Maybe FilePath

4545 -- ^ Set to 'Just' to create a directory of profiling reports.

46+ , optTesting :: Bool

47+ -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants

4648 , optReportProgress :: IdeReportProgress

4749 -- ^ Whether to report progress during long operations.

4850 , optLanguageSyntax :: String

4951 -- ^ the ```language to use

5052 , optNewColonConvention :: Bool

5153 -- ^ whether to use new colon convention

54+ , optKeywords :: [T.Text]

55+ -- ^ keywords used for completions. These are customizable

56+ -- since DAML has a different set of keywords than Haskell.

5257 , optDefer :: IdeDefer

5358 -- ^ Whether to defer type errors, typed holes and out of scope

5459 -- variables. Deferral allows the IDE to continue to provide

@@ -70,10 +75,10 @@ newtype IdeReportProgress = IdeReportProgress Bool

7075newtype IdeDefer = IdeDefer Bool

7176

7277clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress

73−clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $

74− LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)

78+clientSupportsProgress caps = IdeReportProgress $ Just True ==

79+ (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities))

7580

76−defaultIdeOptions :: IO (FilePath -> Action HscEnvEq) -> IdeOptions

81+defaultIdeOptions :: Action (FilePath -> Action (IdeResult HscEnvEq)) -> IdeOptions

7782defaultIdeOptions session = IdeOptions

7883 {optPreprocessor = IdePreprocessedSource [] []

7984 ,optGhcSession = session

@@ -85,7 +90,9 @@ defaultIdeOptions session = IdeOptions

8590 ,optReportProgress = IdeReportProgress False

8691 ,optLanguageSyntax = "haskell"

8792 ,optNewColonConvention = False

93+ ,optKeywords = haskellKeywords

8894 ,optDefer = IdeDefer True

95+ ,optTesting = False

8996 }

9097

9198

@@ -103,3 +110,23 @@ data IdePkgLocationOptions = IdePkgLocationOptions

103110defaultIdePkgLocationOptions :: IdePkgLocationOptions

104111defaultIdePkgLocationOptions = IdePkgLocationOptions f f

105112 where f _ _ = return Nothing

113+

114+-- | From https://wiki.haskell.org/Keywords

115+haskellKeywords :: [T.Text]

116+haskellKeywords =

117+ [ "as"

118+ , "case", "of"

119+ , "class", "instance", "type"

120+ , "data", "family", "newtype"

121+ , "default"

122+ , "deriving"

123+ , "do", "mdo", "proc", "rec"

124+ , "forall"

125+ , "foreign"

126+ , "hiding"

127+ , "if", "then", "else"

128+ , "import", "qualified", "hiding"

129+ , "infix", "infixl", "infixr"

130+ , "let", "in", "where"

131+ , "module"

132+ ]

stack-ghc-lib.yaml+5−4

@@ -2,10 +2,10 @@ resolver: nightly-2019-09-16

22packages:

33- .

44extra-deps:

5−- haskell-lsp-0.19.0.0

6−- haskell-lsp-types-0.19.0.0

7−- lsp-test-0.10.0.0

8−- hie-bios-0.4.0

5+- haskell-lsp-0.22.0.0

6+- haskell-lsp-types-0.22.0.0

7+- lsp-test-0.10.3.0

8+- hie-bios-0.5.0

99- ghc-lib-parser-8.8.1

1010- ghc-lib-8.8.1

1111- fuzzy-0.1.0.0

@@ -13,6 +13,7 @@ extra-deps:

1313- regex-base-0.94.0.0

1414- regex-tdfa-1.3.1.0

1515- haddock-library-1.8.0

16+- ghc-check-0.3.0.1

1617nix:

1718 packages: [zlib]

1819flags:

stack.yaml+6−4

@@ -2,10 +2,10 @@ resolver: nightly-2019-09-21

22packages:

33- .

44extra-deps:

5−- haskell-lsp-0.19.0.0

6−- haskell-lsp-types-0.19.0.0

7−- lsp-test-0.10.0.0

8−- hie-bios-0.4.0

5+- haskell-lsp-0.22.0.0

6+- haskell-lsp-types-0.22.0.0

7+- lsp-test-0.11.0.1

8+- hie-bios-0.5.0

99- fuzzy-0.1.0.0

1010- regex-pcre-builtin-0.95.1.1.8.43

1111- regex-base-0.94.0.0

@@ -13,5 +13,7 @@ extra-deps:

1313- shake-0.18.5

1414- parser-combinators-1.2.1

1515- haddock-library-1.8.0

16+- tasty-rerun-1.1.17

17+- ghc-check-0.3.0.1

1618nix:

1719 packages: [zlib]

stack810.yamlnew file+18

@@ -0,0 +1,18 @@

1+resolver: nightly-2020-02-13

2+compiler: ghc-8.10.1

3+allow-newer: true

4+packages:

5+- .

6+extra-deps:

7+- haskell-lsp-0.22.0.0

8+- haskell-lsp-types-0.22.0.0

9+- lsp-test-0.11.0.1

10+- ghc-check-0.3.0.1

11+- hie-bios-0.5.0

12+

13+# for ghc-8.10

14+- Cabal-3.2.0.0

15+- lens-4.19.1

16+

17+nix:

18+ packages: [zlib]

stack84.yaml+14−5

@@ -5,13 +5,13 @@ packages:

55extra-deps:

66- aeson-1.4.6.0

77- base-orphans-0.8.2

8−- haskell-lsp-0.19.0.0

9−- haskell-lsp-types-0.19.0.0

10−- lsp-test-0.10.0.0

8+- haskell-lsp-0.22.0.0

9+- haskell-lsp-types-0.22.0.0

10+- lsp-test-0.11.0.1

1111- rope-utf16-splay-0.3.1.0

1212- filepattern-0.1.1

1313- js-dgtable-0.5.2

14−- hie-bios-0.4.0

14+- hie-bios-0.5.0

1515- fuzzy-0.1.0.0

1616- shake-0.18.5

1717- time-compat-1.9.2.2

@@ -19,6 +19,15 @@ extra-deps:

1919- regex-tdfa-1.3.1.0

2020- parser-combinators-1.2.1

2121- 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+

2232nix:

2333 packages: [zlib]

24−allow-newer: true

stack88.yaml+6−2

@@ -1,7 +1,11 @@

1−resolver: nightly-2020-02-03

1+resolver: nightly-2020-02-13

22packages:

33- .

44extra-deps:

5−- fuzzy-0.1.0.0

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

610nix:

711 packages: [zlib]

test/data/hover/Bar.hsnew file+3

@@ -0,0 +1,3 @@

1+module Bar (Bar(..)) where

3+data Bar = Bar

test/data/hover/Foo.hsnew file+5

@@ -0,0 +1,5 @@

1+module Foo (Bar, foo) where

3+import Bar

5+foo = Bar

test/data/GotoHover.hs → test/data/hover/GotoHover.hsrenamed+7

@@ -1,6 +1,10 @@

1+{-# LANGUAGE OverloadedStrings #-}

12{- HLINT ignore -}

23module Testing ( module Testing ) where

34import Data.Text (Text, pack)

5+import Foo (Bar, foo)

48data TypeConstructor = DataConstructor

59 { fff :: Text

610 , ggg :: Int }

@@ -48,3 +52,6 @@ outer = undefined where

4852

4953 inner :: Char

5054 inner = undefined

55+

56+imported :: Bar

57+imported = foo

test/data/multi/a/A.hsnew file+3

@@ -0,0 +1,3 @@

1+module A(foo) where

3+foo = ()

test/data/multi/a/a.cabalnew file+9

@@ -0,0 +1,9 @@

1+name: a

2+version: 1.0.0

3+build-type: Simple

4+cabal-version: >= 1.2

6+library

7+ build-depends: base

8+ exposed-modules: A

9+ hs-source-dirs: .

test/data/multi/b/B.hsnew file+3

@@ -0,0 +1,3 @@

1+module B(module B) where

2+import A

3+qux = foo

test/data/multi/b/b.cabalnew file+9

@@ -0,0 +1,9 @@

1+name: b

2+version: 1.0.0

3+build-type: Simple

4+cabal-version: >= 1.2

6+library

7+ build-depends: base, a

8+ exposed-modules: B

9+ hs-source-dirs: .

test/data/multi/cabal.projectnew file+1

@@ -0,0 +1 @@

1+packages: a b

test/data/multi/hie.yamlnew file+6

@@ -0,0 +1,6 @@

1+cradle:

2+ cabal:

3+ - path: "./a"

4+ component: "lib:a"

5+ - path: "./b"

6+ component: "lib:b"

test/exe/Main.hs+796−264

@@ -1,6 +1,7 @@

22-- SPDX-License-Identifier: Apache-2.0

4+{-# LANGUAGE AllowAmbiguousTypes #-}

45{-# LANGUAGE DuplicateRecordFields #-}

56{-# LANGUAGE PatternSynonyms #-}

67{-# LANGUAGE CPP #-}

@@ -9,27 +10,32 @@

910module Main (main) where

1011

1112import Control.Applicative.Combinators

12−import Control.Exception (catch)

13+import Control.Exception (bracket, catch)

14+import qualified Control.Lens as Lens

1315import Control.Monad

1416import Control.Monad.IO.Class (liftIO)

15−import Data.Char (toLower)

17+import Data.Aeson (FromJSON, Value)

1618import Data.Foldable

17−import Data.List

19+import Data.List.Extra

1820import Data.Rope.UTF16 (Rope)

1921import qualified Data.Rope.UTF16 as Rope

2022import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)

2123import Development.IDE.GHC.Util

2224import qualified Data.Text as T

25+import Data.Typeable

2326import Development.IDE.Spans.Common

2427import Development.IDE.Test

2528import Development.IDE.Test.Runfiles

2629import Development.IDE.Types.Location

27−import qualified Language.Haskell.LSP.Test as LSPTest

28−import Language.Haskell.LSP.Test hiding (openDoc')

30+import Development.Shake (getDirectoryFilesIO)

31+import Language.Haskell.LSP.Test

32+import Language.Haskell.LSP.Messages

2933import Language.Haskell.LSP.Types

3034import Language.Haskell.LSP.Types.Capabilities

35+import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)

3136import Language.Haskell.LSP.VFS (applyChange)

32−import System.Environment.Blank (setEnv)

37+import Network.URI

38+import System.Environment.Blank (getEnv, setEnv, unsetEnv)

3339import System.FilePath

3440import System.IO.Extra

3541import System.Directory

@@ -37,33 +43,41 @@ import Test.QuickCheck

3743import Test.QuickCheck.Instances ()

3844import Test.Tasty

3945import Test.Tasty.ExpectedFailure

46+import Test.Tasty.Ingredients.Rerun

4047import Test.Tasty.HUnit

4148import Test.Tasty.QuickCheck

4249import Data.Maybe

4350

4451main :: IO ()

45−main = defaultMain $ testGroup "HIE"

46− [ testSession "open close" $ do

47− doc <- openDoc' "Testing.hs" "haskell" ""

48− void (message :: Session WorkDoneProgressCreateRequest)

49− void (message :: Session WorkDoneProgressBeginNotification)

50− closeDoc doc

51− void (message :: Session WorkDoneProgressEndNotification)

52− , initializeResponseTests

53− , completionTests

54− , cppTests

55− , diagnosticTests

56− , codeActionTests

57− , codeLensesTests

58− , outlineTests

59− , findDefinitionAndHoverTests

60− , pluginTests

61− , preprocessorTests

62− , thTests

63− , unitTests

64− , haddockTests

65− , positionMappingTests

66− ]

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+ ]

6781

6882initializeResponseTests :: TestTree

6983initializeResponseTests = withResource acquire release tests where

@@ -98,8 +112,8 @@ initializeResponseTests = withResource acquire release tests where

98112 , chk "NO doc link" _documentLinkProvider Nothing

99113 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)

100114 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)

101− , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

102− , chk "NO workspace" _workspace nothingWorkspace

115+ , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

116+ , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))

103117 , chk "NO experimental" _experimental Nothing

104118 ] where

105119

@@ -110,14 +124,21 @@ initializeResponseTests = withResource acquire release tests where

110124 , _willSaveWaitUntil = Nothing

111125 , _save = Just (SaveOptions {_includeText = Nothing})}))

112126

113− nothingWorkspace = Just (WorkspaceOptions {_workspaceFolders = Nothing})

114−

115127 chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree

116128 chk title getActual expected =

117129 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir

118130

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+

119140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner

120− innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c

141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c

121142 innerCaps _ = error "this test only expects inner capabilities"

122143

123144 acquire :: IO InitializeResponse

@@ -131,7 +152,7 @@ diagnosticTests :: TestTree

131152diagnosticTests = testGroup "diagnostics"

132153 [ testSessionWait "fix syntax error" $ do

133154 let content = T.unlines [ "module Testing wher" ]

134− doc <- openDoc' "Testing.hs" "haskell" content

155+ doc <- createDoc "Testing.hs" "haskell" content

135156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]

136157 let change = TextDocumentContentChangeEvent

137158 { _range = Just (Range (Position 0 15) (Position 0 19))

@@ -142,9 +163,9 @@ diagnosticTests = testGroup "diagnostics"

142163 expectDiagnostics [("Testing.hs", [])]

143164 , testSessionWait "introduce syntax error" $ do

144165 let content = T.unlines [ "module Testing where" ]

145− doc <- openDoc' "Testing.hs" "haskell" content

146− void (message :: Session WorkDoneProgressCreateRequest)

147− void (message :: Session WorkDoneProgressBeginNotification)

166+ doc <- createDoc "Testing.hs" "haskell" content

167+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)

168+ void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)

148169 let change = TextDocumentContentChangeEvent

149170 { _range = Just (Range (Position 0 15) (Position 0 18))

150171 , _rangeLength = Nothing

@@ -160,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"

160181 , "bar :: Int -> Int -> Int"

161182 , "bar a b = cd + b"

162183 ]

163− _ <- openDoc' "Testing.hs" "haskell" content

184+ _ <- createDoc "Testing.hs" "haskell" content

164185 expectDiagnostics

165186 [ ( "Testing.hs"

166187 , [ (DsError, (2, 14), "Variable not in scope: ab")

@@ -174,7 +195,7 @@ diagnosticTests = testGroup "diagnostics"

174195 , "foo :: Int -> String -> Int"

175196 , "foo a b = a + b"

176197 ]

177− _ <- openDoc' "Testing.hs" "haskell" content

198+ _ <- createDoc "Testing.hs" "haskell" content

178199 expectDiagnostics

179200 [ ( "Testing.hs"

180201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]

@@ -186,7 +207,7 @@ diagnosticTests = testGroup "diagnostics"

186207 , "foo :: Int -> String"

187208 , "foo a = _ a"

188209 ]

189− _ <- openDoc' "Testing.hs" "haskell" content

210+ _ <- createDoc "Testing.hs" "haskell" content

190211 expectDiagnostics

191212 [ ( "Testing.hs"

192213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]

@@ -208,24 +229,23 @@ diagnosticTests = testGroup "diagnostics"

208229 [ ("A.hs", [(DsError, (2,4), aMessage)])

209230 , ("B.hs", [(DsError, (3,4), bMessage)])]

210231 deferralTest title binding msg = testSessionWait title $ do

211− _ <- openDoc' "A.hs" "haskell" $ sourceA binding

212− _ <- openDoc' "B.hs" "haskell" sourceB

232+ _ <- createDoc "A.hs" "haskell" $ sourceA binding

233+ _ <- createDoc "B.hs" "haskell" sourceB

213234 expectDiagnostics $ expectedDs msg

214235 in

215236 [ deferralTest "type error" "True" "Couldn't match expected type"

216237 , deferralTest "typed hole" "_" "Found hole"

217238 , deferralTest "out of scope var" "unbound" "Variable not in scope"

218− , deferralTest "message shows error" "True" "A.hs:3:5: error:"

219239 ]

220240

221241 , testSessionWait "remove required module" $ do

222242 let contentA = T.unlines [ "module ModuleA where" ]

223− docA <- openDoc' "ModuleA.hs" "haskell" contentA

243+ docA <- createDoc "ModuleA.hs" "haskell" contentA

224244 let contentB = T.unlines

225245 [ "module ModuleB where"

226246 , "import ModuleA"

227247 ]

228− _ <- openDoc' "ModuleB.hs" "haskell" contentB

248+ _ <- createDoc "ModuleB.hs" "haskell" contentB

229249 let change = TextDocumentContentChangeEvent

230250 { _range = Just (Range (Position 0 0) (Position 0 20))

231251 , _rangeLength = Nothing

@@ -238,11 +258,21 @@ diagnosticTests = testGroup "diagnostics"

238258 [ "module ModuleB where"

239259 , "import ModuleA"

240260 ]

241− _ <- openDoc' "ModuleB.hs" "haskell" contentB

261+ _ <- createDoc "ModuleB.hs" "haskell" contentB

242262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

243263 let contentA = T.unlines [ "module ModuleA where" ]

244− _ <- openDoc' "ModuleA.hs" "haskell" contentA

264+ _ <- createDoc "ModuleA.hs" "haskell" contentA

245265 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", [])]

246276 , testSessionWait "cyclic module dependency" $ do

247277 let contentA = T.unlines

248278 [ "module ModuleA where"

@@ -252,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"

252282 [ "module ModuleB where"

253283 , "import ModuleA"

254284 ]

255− _ <- openDoc' "ModuleA.hs" "haskell" contentA

256− _ <- openDoc' "ModuleB.hs" "haskell" contentB

285+ _ <- createDoc "ModuleA.hs" "haskell" contentA

286+ _ <- createDoc "ModuleB.hs" "haskell" contentB

257287 expectDiagnostics

258288 [ ( "ModuleA.hs"

259289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]

@@ -274,9 +304,9 @@ diagnosticTests = testGroup "diagnostics"

274304 let contentBboot = T.unlines

275305 [ "module ModuleB where"

276306 ]

277− _ <- openDoc' "ModuleA.hs" "haskell" contentA

278− _ <- openDoc' "ModuleB.hs" "haskell" contentB

279− _ <- openDoc' "ModuleB.hs-boot" "haskell" contentBboot

307+ _ <- createDoc "ModuleA.hs" "haskell" contentA

308+ _ <- createDoc "ModuleB.hs" "haskell" contentB

309+ _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot

280310 expectDiagnostics []

281311 , testSessionWait "correct reference used with hs-boot" $ do

282312 let contentB = T.unlines

@@ -298,10 +328,10 @@ diagnosticTests = testGroup "diagnostics"

298328 -- resolved to the hs-boot file

299329 , "y = x"

300330 ]

301− _ <- openDoc' "ModuleB.hs" "haskell" contentB

302− _ <- openDoc' "ModuleA.hs" "haskell" contentA

303− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot

304− _ <- openDoc' "ModuleC.hs" "haskell" contentC

331+ _ <- createDoc "ModuleB.hs" "haskell" contentB

332+ _ <- createDoc "ModuleA.hs" "haskell" contentA

333+ _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot

334+ _ <- createDoc "ModuleC.hs" "haskell" contentC

305335 expectDiagnostics []

306336 , testSessionWait "redundant import" $ do

307337 let contentA = T.unlines ["module ModuleA where"]

@@ -310,8 +340,8 @@ diagnosticTests = testGroup "diagnostics"

310340 , "module ModuleB where"

311341 , "import ModuleA"

312342 ]

313− _ <- openDoc' "ModuleA.hs" "haskell" contentA

314− _ <- openDoc' "ModuleB.hs" "haskell" contentB

343+ _ <- createDoc "ModuleA.hs" "haskell" contentA

344+ _ <- createDoc "ModuleB.hs" "haskell" contentB

315345 expectDiagnostics

316346 [ ( "ModuleB.hs"

317347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]

@@ -333,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"

333363 , "wrong1 = ThisList.map"

334364 , "wrong2 = BaseList.x"

335365 ]

336− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent

337− _ <- openDoc' "Main.hs" "haskell" mainContent

366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent

367+ _ <- createDoc "Main.hs" "haskell" mainContent

338368 expectDiagnostics

339369 [ ( "Main.hs"

340370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")

@@ -349,7 +379,7 @@ diagnosticTests = testGroup "diagnostics"

349379 , "foo :: Ord a => a -> Int"

350380 , "foo a = 1"

351381 ]

352− _ <- openDoc' "Foo.hs" "haskell" fooContent

382+ _ <- createDoc "Foo.hs" "haskell" fooContent

353383 expectDiagnostics

354384 [ ( "Foo.hs"

355385 -- The test is to make sure that warnings contain unqualified names

@@ -374,18 +404,18 @@ diagnosticTests = testGroup "diagnostics"

374404 Just pathB <- pure $ uriToFilePath uriB

375405 uriB <- pure $

376406 let (drive, suffix) = splitDrive pathB

377− in filePathToUri (joinDrive (map toLower drive ) suffix)

407+ in filePathToUri (joinDrive (lower drive) suffix)

378408 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)

379409 liftIO $ writeFileUTF8 pathB $ T.unpack bContent

380410 uriA <- getDocUri "A/A.hs"

381411 Just pathA <- pure $ uriToFilePath uriA

382412 uriA <- pure $

383413 let (drive, suffix) = splitDrive pathA

384− in filePathToUri (joinDrive (map toLower drive ) suffix)

414+ in filePathToUri (joinDrive (lower drive) suffix)

385415 let itemA = TextDocumentItem uriA "haskell" 0 aContent

386416 let a = TextDocumentIdentifier uriA

387417 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)

388− diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification

418+ diagsNot <- skipManyTill anyMessage diagnostic

389419 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)

390420 -- Check that if we put a lower-case drive in for A.A

391421 -- the diagnostics for A.B will also be lower-case.

@@ -394,6 +424,38 @@ diagnosticTests = testGroup "diagnostics"

394424 liftIO $ unless ("redundant" `T.isInfixOf` msg) $

395425 assertFailure ("Expected redundant import but got " <> T.unpack msg)

396426 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

397459 ]

398460

399461codeActionTests :: TestTree

@@ -402,6 +464,7 @@ codeActionTests = testGroup "code actions"

402464 , typeWildCardActionTests

403465 , removeImportTests

404466 , extendImportTests

467+ , suggestImportTests

405468 , addExtensionTests

406469 , fixConstructorImportTests

407470 , importRenameActionTests

@@ -415,6 +478,33 @@ codeLensesTests = testGroup "code lenses"

415478 [ addSigLensesTests

416479 ]

417480

481+watchedFilesTests :: TestTree

482+watchedFilesTests = testGroup "watched files"

483+ [ testSession' "workspace files" $ \sessionDir -> do

484+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\"]}}"

485+ _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"

486+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

487+

488+ -- Expect 4 subscriptions (A does not get any because it's VFS):

489+ -- - /path-to-workspace/WatchedFilesMissingModule.hs

490+ -- - /path-to-workspace/WatchedFilesMissingModule.lhs

491+ -- - /path-to-workspace/src/WatchedFilesMissingModule.hs

492+ -- - /path-to-workspace/src/WatchedFilesMissingModule.lhs

493+ liftIO $ length watchedFileRegs @?= 4

494+

495+ , testSession' "non workspace file" $ \sessionDir -> do

496+ liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-i/tmp\"]}}"

497+ _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"

498+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

499+

500+ -- Expect 2 subscriptions (/tmp does not get any as it is out of the workspace):

501+ -- - /path-to-workspace/WatchedFilesMissingModule.hs

502+ -- - /path-to-workspace/WatchedFilesMissingModule.lhs

503+ liftIO $ length watchedFileRegs @?= 2

504+

505+ -- TODO add a test for didChangeWorkspaceFolder

506+ ]

507+

418508renameActionTests :: TestTree

419509renameActionTests = testGroup "rename actions"

420510 [ testSession "change to local variable name" $ do

@@ -423,7 +513,7 @@ renameActionTests = testGroup "rename actions"

423513 , "foo :: Int -> Int"

424514 , "foo argName = argNme"

425515 ]

426− doc <- openDoc' "Testing.hs" "haskell" content

516+ doc <- createDoc "Testing.hs" "haskell" content

427517 _ <- waitForDiagnostics

428518 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"

429519 executeCodeAction action

@@ -441,7 +531,7 @@ renameActionTests = testGroup "rename actions"

441531 , "foo :: Maybe a -> [a]"

442532 , "foo = maybToList"

443533 ]

444− doc <- openDoc' "Testing.hs" "haskell" content

534+ doc <- createDoc "Testing.hs" "haskell" content

445535 _ <- waitForDiagnostics

446536 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"

447537 executeCodeAction action

@@ -459,7 +549,7 @@ renameActionTests = testGroup "rename actions"

459549 , "foo :: Char -> Char -> Char -> Char"

460550 , "foo argument1 argument2 argument3 = argumentX"

461551 ]

462− doc <- openDoc' "Testing.hs" "haskell" content

552+ doc <- createDoc "Testing.hs" "haskell" content

463553 _ <- waitForDiagnostics

464554 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))

465555 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]

@@ -471,7 +561,7 @@ renameActionTests = testGroup "rename actions"

471561 , "monus x y = max 0 (x - y)"

472562 , "foo x y = x `monnus` y"

473563 ]

474− doc <- openDoc' "Testing.hs" "haskell" content

564+ doc <- createDoc "Testing.hs" "haskell" content

475565 _ <- waitForDiagnostics

476566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))

477567 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]

@@ -494,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

494584 , "func :: _"

495585 , "func x = x"

496586 ]

497− doc <- openDoc' "Testing.hs" "haskell" content

587+ doc <- createDoc "Testing.hs" "haskell" content

498588 _ <- waitForDiagnostics

499589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

500590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -514,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

514604 , "func :: _"

515605 , "func x y = x + y"

516606 ]

517− doc <- openDoc' "Testing.hs" "haskell" content

607+ doc <- createDoc "Testing.hs" "haskell" content

518608 _ <- waitForDiagnostics

519609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

520610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -537,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

537627 , " y = x * 2"

538628 , " in y"

539629 ]

540− doc <- openDoc' "Testing.hs" "haskell" content

630+ doc <- createDoc "Testing.hs" "haskell" content

541631 _ <- waitForDiagnostics

542632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))

543633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -562,7 +652,7 @@ removeImportTests = testGroup "remove import actions"

562652 let contentA = T.unlines

563653 [ "module ModuleA where"

564654 ]

565− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

566656 let contentB = T.unlines

567657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

568658 , "module ModuleB where"

@@ -570,7 +660,7 @@ removeImportTests = testGroup "remove import actions"

570660 , "stuffB :: Integer"

571661 , "stuffB = 123"

572662 ]

573− docB <- openDoc' "ModuleB.hs" "haskell" contentB

663+ docB <- createDoc "ModuleB.hs" "haskell" contentB

574664 _ <- waitForDiagnostics

575665 [CACodeAction action@CodeAction { _title = actionTitle }]

576666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -588,7 +678,7 @@ removeImportTests = testGroup "remove import actions"

588678 let contentA = T.unlines

589679 [ "module ModuleA where"

590680 ]

591− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

592682 let contentB = T.unlines

593683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

594684 , "module ModuleB where"

@@ -596,7 +686,7 @@ removeImportTests = testGroup "remove import actions"

596686 , "stuffB :: Integer"

597687 , "stuffB = 123"

598688 ]

599− docB <- openDoc' "ModuleB.hs" "haskell" contentB

689+ docB <- createDoc "ModuleB.hs" "haskell" contentB

600690 _ <- waitForDiagnostics

601691 [CACodeAction action@CodeAction { _title = actionTitle }]

602692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -618,14 +708,14 @@ removeImportTests = testGroup "remove import actions"

618708 , "stuffB = 123"

619709 , "stuffC = ()"

620710 ]

621− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

622712 let contentB = T.unlines

623713 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

624714 , "module ModuleB where"

625715 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"

626716 , "main = print stuffB"

627717 ]

628− docB <- openDoc' "ModuleB.hs" "haskell" contentB

718+ docB <- createDoc "ModuleB.hs" "haskell" contentB

629719 _ <- waitForDiagnostics

630720 [CACodeAction action@CodeAction { _title = actionTitle }]

631721 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -639,29 +729,26 @@ removeImportTests = testGroup "remove import actions"

639729 , "main = print stuffB"

640730 ]

641731 liftIO $ expectedContentAfterAction @=? contentAfterAction

642− , testSession "redundant symbol binding" $ do

732+ , testSession "redundant operator" $ do

643733 let contentA = T.unlines

644734 [ "module ModuleA where"

645735 , "a !! b = a"

736+ , "a <?> b = a"

646737 , "stuffB :: Integer"

647738 , "stuffB = 123"

648739 ]

649− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

650741 let contentB = T.unlines

651742 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

652743 , "module ModuleB where"

653− , "import qualified ModuleA as A ((!!), stuffB, (!!))"

744+ , "import qualified ModuleA as A ((<?>), stuffB, (!!))"

654745 , "main = print A.stuffB"

655746 ]

656− docB <- openDoc' "ModuleB.hs" "haskell" contentB

747+ docB <- createDoc "ModuleB.hs" "haskell" contentB

657748 _ <- waitForDiagnostics

658749 [CACodeAction action@CodeAction { _title = actionTitle }]

659750 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

660−#if MIN_GHC_API_VERSION(8,6,0)

661− liftIO $ "Remove !! from import" @=? actionTitle

662−#else

663− liftIO $ "Remove A.!! from import" @=? actionTitle

664−#endif

751+ liftIO $ "Remove !!, <?> from import" @=? actionTitle

665752 executeCodeAction action

666753 contentAfterAction <- documentContents docB

667754 let expectedContentAfterAction = T.unlines

@@ -671,21 +758,21 @@ removeImportTests = testGroup "remove import actions"

671758 , "main = print A.stuffB"

672759 ]

673760 liftIO $ expectedContentAfterAction @=? contentAfterAction

674− , (`xfail` "known broken (#299)") $ testSession "redundant hierarchical import" $ do

761+ , testSession "redundant all import" $ do

675762 let contentA = T.unlines

676763 [ "module ModuleA where"

677764 , "data A = A"

678765 , "stuffB :: Integer"

679766 , "stuffB = 123"

680767 ]

681− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

682769 let contentB = T.unlines

683770 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

684771 , "module ModuleB where"

685772 , "import ModuleA (A(..), stuffB)"

686773 , "main = print stuffB"

687774 ]

688− docB <- openDoc' "ModuleB.hs" "haskell" contentB

775+ docB <- createDoc "ModuleB.hs" "haskell" contentB

689776 _ <- waitForDiagnostics

690777 [CACodeAction action@CodeAction { _title = actionTitle }]

691778 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -699,6 +786,33 @@ removeImportTests = testGroup "remove import actions"

699786 , "main = print stuffB"

700787 ]

701788 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

702816 ]

703817

704818extendImportTests :: TestTree

@@ -723,6 +837,26 @@ extendImportTests = testGroup "extend import actions"

723837 , "import ModuleA as A (stuffA, stuffB)"

724838 , "main = print (stuffA, stuffB)"

725839 ])

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+ ])

726860 , testSession "extend single line import with type" $ template

727861 (T.unlines

728862 [ "module ModuleA where"

@@ -806,8 +940,8 @@ extendImportTests = testGroup "extend import actions"

806940 ]

807941 where

808942 template contentA contentB range expectedAction expectedContentB = do

809− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

810− docB <- openDoc' "ModuleB.hs" "haskell" contentB

943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

944+ docB <- createDoc "ModuleB.hs" "haskell" contentB

811945 _ <- waitForDiagnostics

812946 CACodeAction action@CodeAction { _title = actionTitle } : _

813947 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -817,6 +951,61 @@ extendImportTests = testGroup "extend import actions"

817951 contentAfterAction <- documentContents docB

818952 liftIO $ expectedContentB @=? contentAfterAction

819953

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+

8201009addExtensionTests :: TestTree

8211010addExtensionTests = testGroup "add language extension actions"

8221011 [ testSession "add NamedFieldPuns language extension" $ template

@@ -862,7 +1051,7 @@ addExtensionTests = testGroup "add language extension actions"

8621051 ]

8631052 where

8641053 template initialContent range expectedAction expectedContents = do

865− doc <- openDoc' "Module.hs" "haskell" initialContent

1054+ doc <- createDoc "Module.hs" "haskell" initialContent

8661055 _ <- waitForDiagnostics

8671056 CACodeAction action@CodeAction { _title = actionTitle } : _

8681057 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -885,7 +1074,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"

8851074 [""

8861075 ,"someOtherCode = ()"

8871076 ]

888− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

8891078 _ <- waitForDiagnostics

8901079 CACodeAction action@CodeAction { _title = actionTitle } : _

8911080 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -909,7 +1098,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"

9091098 [""

9101099 ,"someOtherCode = ()"

9111100 ]

912− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

9131102 _ <- waitForDiagnostics

9141103 CACodeAction action@CodeAction { _title = actionTitle } : _

9151104 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -948,8 +1137,8 @@ fixConstructorImportTests = testGroup "fix import actions"

9481137 ]

9491138 where

9501139 template contentA contentB range expectedAction expectedContentB = do

951− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

952− docB <- openDoc' "ModuleB.hs" "haskell" contentB

1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB

9531142 _diags <- waitForDiagnostics

9541143 CACodeAction action@CodeAction { _title = actionTitle } : _

9551144 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -968,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"

9681157 [ "module Testing where"

9691158 , "import Data.Mape"

9701159 ]

971− doc <- openDoc' "Testing.hs" "haskell" content

1160+ doc <- createDoc "Testing.hs" "haskell" content

9721161 _ <- waitForDiagnostics

9731162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))

9741163 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]

@@ -1005,10 +1194,10 @@ fillTypedHoleTests = let

10051194 newA newB newC = testSession (T.unpack actionTitle) $ do

10061195 let originalCode = sourceCode oldA oldB oldC

10071196 let expectedCode = sourceCode newA newB newC

1008− doc <- openDoc' "Testing.hs" "haskell" originalCode

1197+ doc <- createDoc "Testing.hs" "haskell" originalCode

10091198 _ <- waitForDiagnostics

10101199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))

1011− let chosenAction = pickActionWithTitle actionTitle actionsOrCommands

1200+ chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands

10121201 executeCodeAction chosenAction

10131202 modifiedCode <- documentContents doc

10141203 liftIO $ expectedCode @=? modifiedCode

@@ -1045,36 +1234,37 @@ fillTypedHoleTests = let

10451234

10461235addSigActionTests :: TestTree

10471236addSigActionTests = let

1048− header = "{-# OPTIONS_GHC -Wmissing-signatures #-}"

1049− moduleH = "module Sigs where"

1237+ header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"

1238+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"

10501239 before def = T.unlines [header, moduleH, def]

10511240 after' def sig = T.unlines [header, moduleH, sig, def]

10521241

10531242 def >:: sig = testSession (T.unpack def) $ do

10541243 let originalCode = before def

10551244 let expectedCode = after' def sig

1056− doc <- openDoc' "Sigs.hs" "haskell" originalCode

1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode

10571246 _ <- waitForDiagnostics

10581247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))

1059− let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

1248+ chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

10601249 executeCodeAction chosenAction

10611250 modifiedCode <- documentContents doc

10621251 liftIO $ expectedCode @=? modifiedCode

10631252 in

10641253 testGroup "add signature"

1065− [ "abc = True" >:: "abc :: Bool"

1066− , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"

1067− , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"

1068− , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"

1069− , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"

1070− , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"

1254+ [ "abc = True" >:: "abc :: Bool"

1255+ , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"

1256+ , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"

1257+ , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"

1258+ , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"

1259+ , "a `haha` b = a b" >:: "haha :: (t1 -> t2) -> t1 -> t2"

1260+ , "pattern Some a = Just a" >:: "pattern Some :: a -> Maybe a"

10711261 ]

10721262

10731263addSigLensesTests :: TestTree

10741264addSigLensesTests = let

1075− missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wunused-matches #-}"

1265+ missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"

10761266 notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"

1077− moduleH = "module Sigs where"

1267+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"

10781268 other = T.unlines ["f :: Integer -> Integer", "f x = 3"]

10791269 before withMissing def

10801270 = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]

@@ -1084,49 +1274,41 @@ addSigLensesTests = let

10841274 sigSession withMissing def sig = testSession (T.unpack def) $ do

10851275 let originalCode = before withMissing def

10861276 let expectedCode = after' withMissing def sig

1087− doc <- openDoc' "Sigs.hs" "haskell" originalCode

1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode

10881278 [CodeLens {_command = Just c}] <- getCodeLenses doc

10891279 executeCommand c

10901280 modifiedCode <- getDocumentEdit doc

10911281 liftIO $ expectedCode @=? modifiedCode

10921282 in

10931283 testGroup "add signature"

1094− [ testGroup "with warnings enabled"

1095− [ sigSession True "abc = True" "abc :: Bool"

1096− , sigSession True "foo a b = a + b" "foo :: Num a => a -> a -> a"

1097− , sigSession True "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"

1098− , sigSession True "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"

1099− , sigSession True "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"

1100− , sigSession True "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"

1101− ]

1102− , testGroup "with warnings disabled"

1103− [ sigSession False "abc = True" "abc :: Bool"

1104− , sigSession False "foo a b = a + b" "foo :: Num a => a -> a -> a"

1105− , sigSession False "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"

1106− , sigSession False "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"

1107− , sigSession False "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"

1108− , sigSession False "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"

1284+ [ testGroup title

1285+ [ sigSession enableWarnings "abc = True" "abc :: Bool"

1286+ , sigSession enableWarnings "foo a b = a + b" "foo :: Num a => a -> a -> a"

1287+ , sigSession enableWarnings "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"

1288+ , sigSession enableWarnings "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"

1289+ , sigSession enableWarnings "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"

1290+ , sigSession enableWarnings "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"

1291+ , sigSession enableWarnings "pattern Some a = Just a" "pattern Some :: a -> Maybe a"

11091292 ]

1293+ | (title, enableWarnings) <-

1294+ [("with warnings enabled", True)

1295+ ,("with warnings disabled", False)

1296+ ]

11101297 ]

11111298

1112−findDefinitionAndHoverTests :: TestTree

1113−findDefinitionAndHoverTests = let

1114−

1115− tst (get, check) pos targetRange title = testSession title $ do

1116− doc <- openTestDataDoc sourceFilePath

1117− found <- get doc pos

1118− check found targetRange

1119−

1120− checkDefs :: [Location] -> [Expect] -> Session ()

1121− checkDefs defs expectations = traverse_ check expectations where

1299+checkDefs :: [Location] -> Session [Expect] -> Session ()

1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where

11221301

1123− check (ExpectRange expectedRange) = do

1124− assertNDefinitionsFound 1 defs

1125− assertRangeCorrect (head defs) expectedRange

1126− check ExpectNoDefinitions = do

1127− assertNDefinitionsFound 0 defs

1128− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"

1129− check _ = pure () -- all other expectations not relevant to getDefinition

1302+ check (ExpectRange expectedRange) = do

1303+ assertNDefinitionsFound 1 defs

1304+ assertRangeCorrect (head defs) expectedRange

1305+ check (ExpectLocation expectedLocation) = do

1306+ assertNDefinitionsFound 1 defs

1307+ liftIO $ head defs @?= expectedLocation

1308+ check ExpectNoDefinitions = do

1309+ assertNDefinitionsFound 0 defs

1310+ check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"

1311+ check _ = pure () -- all other expectations not relevant to getDefinition

11301312

11311313 assertNDefinitionsFound :: Int -> [a] -> Session ()

11321314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)

@@ -1134,8 +1316,19 @@ findDefinitionAndHoverTests = let

11341316 assertRangeCorrect Location{_range = foundRange} expectedRange =

11351317 liftIO $ expectedRange @=? foundRange

11361318

1137− checkHover :: Maybe Hover -> [Expect] -> Session ()

1138− checkHover hover expectations = traverse_ check expectations where

1319+

1320+findDefinitionAndHoverTests :: TestTree

1321+findDefinitionAndHoverTests = let

1322+

1323+ tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do

1324+ doc <- openTestDataDoc (dir </> sourceFilePath)

1325+ found <- get doc pos

1326+ check found targetRange

1327+

1328+

1329+

1330+ checkHover :: Maybe Hover -> Session [Expect] -> Session ()

1331+ checkHover hover expectations = traverse_ check =<< expectations where

11391332

11401333 check expected =

11411334 case hover of

@@ -1178,9 +1371,12 @@ findDefinitionAndHoverTests = let

11781371

11791372 mkFindTests tests = testGroup "get"

11801373 [ testGroup "definition" $ mapMaybe fst tests

1181− , testGroup "hover" $ mapMaybe snd tests ]

1374+ , testGroup "hover" $ mapMaybe snd tests

1375+ , checkFileCompiles sourceFilePath ]

1376+

1377+ test runDef runHover look expect = testM runDef runHover look (return expect)

11821378

1183− test runDef runHover look expect title =

1379+ testM runDef runHover look expect title =

11841380 ( runDef $ tst def look expect title

11851381 , runHover $ tst hover look expect title ) where

11861382 def = (getDefinitions, checkDefs)

@@ -1188,87 +1384,100 @@ findDefinitionAndHoverTests = let

11881384 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out

11891385

11901386 -- search locations expectations on results

1191− fffL4 = _start fffR ; fffR = mkRange 4 4 4 7 ; fff = [ExpectRange fffR]

1192− fffL8 = Position 8 4 ;

1193− fffL14 = Position 14 7 ;

1194− aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]

1195− dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]

1196− dcL12 = Position 12 11 ;

1197− xtcL5 = Position 5 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]

1198− tcL6 = Position 6 11 ; tcData = [mkR 3 0 5 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:4:1"]]

1199− vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]

1200− opL16 = Position 16 15 ; op = [mkR 17 2 17 4]

1201− opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]

1202− aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]

1203− b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]

1204− xvL20 = Position 20 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]

1205− clL23 = Position 23 11 ; cls = [mkR 21 0 22 20, ExpectHoverText ["MyClass", "GotoHover.hs:22:1"]]

1206− clL25 = Position 25 9

1207− eclL15 = Position 15 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]

1208− dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]

1209− dnbL30 = Position 30 23

1210− lcbL33 = Position 33 26 ; lcb = [ExpectHoverText [":: Char"], mkR 33 26 33 27]

1211− lclL33 = Position 33 22

1212− mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14]

1213− mclL37 = Position 37 1

1214− spaceL37 = Position 37 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]

1215− docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]

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"]]

12161412 ; constr = [ExpectHoverText ["Monad m"]]

1217− eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]

1218− intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]]

1219− tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]

1220− intL41 = Position 41 20 ; litI = [ExpectHoverText ["7518"]]

1221− chrL36 = Position 37 24 ; litC = [ExpectHoverText ["'f'"]]

1222− txtL8 = Position 8 14 ; litT = [ExpectHoverText ["\"dfgy\""]]

1223− lstL43 = Position 43 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]

1224− outL45 = Position 45 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]

1225− innL48 = Position 48 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]

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]

12261424 in

12271425 mkFindTests

1228− -- def hover look expect

1229− [ test yes yes fffL4 fff "field in record definition"

1230− , test broken broken fffL8 fff "field in record construction #71"

1231− , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs

1232− , test yes yes aaaL14 aaa "top-level name" -- 120

1233− , test yes yes dcL7 tcDC "data constructor record #247"

1234− , test yes yes dcL12 tcDC "data constructor plain" -- 121

1235− , test yes yes tcL6 tcData "type constructor #248" -- 147

1236− , test broken yes xtcL5 xtc "type constructor external #248,249"

1237− , test broken yes xvL20 xvMsg "value external package #249" -- 120

1238− , test yes yes vvL16 vv "plain parameter" -- 120

1239− , test yes yes aL18 apmp "pattern match name" -- 120

1240− , test yes yes opL16 op "top-level operator" -- 120, 123

1241− , test yes yes opL18 opp "parameter operator" -- 120

1242− , test yes yes b'L19 bp "name in backticks" -- 120

1243− , test yes yes clL23 cls "class in instance declaration #250"

1244− , test yes yes clL25 cls "class in signature #250" -- 147

1245− , test broken yes eclL15 ecls "external class in signature #249,250"

1246− , test yes yes dnbL29 dnb "do-notation bind" -- 137

1247− , test yes yes dnbL30 dnb "do-notation lookup"

1248− , test yes yes lcbL33 lcb "listcomp bind" -- 137

1249− , test yes yes lclL33 lcb "listcomp lookup"

1250− , test yes yes mclL36 mcl "top-level fn 1st clause"

1251− , test yes yes mclL37 mcl "top-level fn 2nd clause #246"

1252− , test yes yes spaceL37 space "top-level fn on space #315"

1253− , test no broken docL41 doc "documentation #7"

1254− , test no yes eitL40 kindE "kind of Either #273"

1255− , test no yes intL40 kindI "kind of Int #273"

1256− , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"

1257− , test no yes intL41 litI "literal Int in hover info #274"

1258− , test no yes chrL36 litC "literal Char in hover info #274"

1259− , test no yes txtL8 litT "literal Text in hover info #274"

1260− , test no yes lstL43 litL "literal List in hover info #274"

1261− , test no yes docL41 constr "type constraint in hover info #283"

1262− , test broken broken outL45 outSig "top-level signature #310"

1263− , test broken broken innL48 innSig "inner signature #310"

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)"

12641464 ]

12651465 where yes, broken :: (TestTree -> Maybe TestTree)

12661466 yes = Just -- test should run and pass

12671467 broken = Just . (`xfail` "known broken")

12681468 no = const Nothing -- don't run this test at all

12691469

1470+checkFileCompiles :: FilePath -> TestTree

1471+checkFileCompiles fp =

1472+ testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do

1473+ void (openTestDataDoc (dir </> fp))

1474+ expectNoMoreDiagnostics 0.5

1475+

1476+

1477+

12701478pluginTests :: TestTree

1271−pluginTests = testSessionWait "plugins" $ do

1479+pluginTests = (`xfail8101` "known broken (#556)")

1480+ $ testSessionWait "plugins" $ do

12721481 let content =

12731482 T.unlines

12741483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"

@@ -1282,7 +1491,7 @@ pluginTests = testSessionWait "plugins" $ do

12821491 , "foo :: Int -> Int -> Int"

12831492 , "foo a b = a + c"

12841493 ]

1285− _ <- openDoc' "Testing.hs" "haskell" content

1494+ _ <- createDoc "Testing.hs" "haskell" content

12861495 expectDiagnostics

12871496 [ ( "Testing.hs",

12881497 [(DsError, (8, 14), "Variable not in scope: c")]

@@ -1309,7 +1518,7 @@ cppTests =

13091518 run $ expectError content (2, 1)

13101519 )

13111520 , testSessionWait "cpp-ghcide" $ do

1312− _ <- openDoc' "A.hs" "haskell" $ T.unlines

1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines

13131522 ["{-# LANGUAGE CPP #-}"

13141523 ,"main ="

13151524 ,"#ifdef __GHCIDE__"

@@ -1323,7 +1532,7 @@ cppTests =

13231532 where

13241533 expectError :: T.Text -> Cursor -> Session ()

13251534 expectError content cursor = do

1326− _ <- openDoc' "Testing.hs" "haskell" content

1535+ _ <- createDoc "Testing.hs" "haskell" content

13271536 expectDiagnostics

13281537 [ ( "Testing.hs",

13291538 [(DsError, cursor, "error: unterminated")]

@@ -1339,13 +1548,43 @@ preprocessorTests = testSessionWait "preprocessor" $ do

13391548 , "module Testing where"

13401549 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic

13411550 ]

1342− _ <- openDoc' "Testing.hs" "haskell" content

1551+ _ <- createDoc "Testing.hs" "haskell" content

13431552 expectDiagnostics

13441553 [ ( "Testing.hs",

13451554 [(DsError, (2, 8), "Variable not in scope: z")]

13461555 )

13471556 ]

13481557

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+

13491588thTests :: TestTree

13501589thTests =

13511590 testGroup

@@ -1371,9 +1610,30 @@ thTests =

13711610 "b :: Integer",

13721611 "b = $(litE $ IntegerL $ a) + n"

13731612 ]

1374− _ <- openDoc' "A.hs" "haskell" sourceA

1375− _ <- openDoc' "B.hs" "haskell" sourceB

1613+ _ <- createDoc "A.hs" "haskell" sourceA

1614+ _ <- createDoc "B.hs" "haskell" sourceB

13761615 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 ()

13771637 ]

13781638

13791639completionTests :: TestTree

@@ -1381,7 +1641,7 @@ completionTests

13811641 = testGroup "completion"

13821642 [ testSessionWait "variable" $ do

13831643 let source = T.unlines ["module A where", "f = hea"]

1384− docId <- openDoc' "A.hs" "haskell" source

1644+ docId <- createDoc "A.hs" "haskell" source

13851645 compls <- getCompletions docId (Position 1 7)

13861646 liftIO $ map dropDocs compls @?=

13871647 [complItem "head" (Just CiFunction) (Just "[a] -> a")]

@@ -1393,7 +1653,7 @@ completionTests

13931653 ]

13941654 , testSessionWait "constructor" $ do

13951655 let source = T.unlines ["module A where", "f = Tru"]

1396− docId <- openDoc' "A.hs" "haskell" source

1656+ docId <- createDoc "A.hs" "haskell" source

13971657 compls <- getCompletions docId (Position 1 7)

13981658 liftIO $ map dropDocs compls @?=

13991659 [ complItem "True" (Just CiConstructor) (Just "Bool")

@@ -1405,7 +1665,7 @@ completionTests

14051665 ]

14061666 , testSessionWait "type" $ do

14071667 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]

1408− docId <- openDoc' "A.hs" "haskell" source

1668+ docId <- createDoc "A.hs" "haskell" source

14091669 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]

14101670 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]

14111671 compls <- getCompletions docId (Position 2 7)

@@ -1422,7 +1682,7 @@ completionTests

14221682 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]

14231683 , testSessionWait "qualified" $ do

14241684 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]

1425− docId <- openDoc' "A.hs" "haskell" source

1685+ docId <- createDoc "A.hs" "haskell" source

14261686 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]

14271687 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]

14281688 compls <- getCompletions docId (Position 2 15)

@@ -1436,9 +1696,30 @@ completionTests

14361696 ]

14371697 , testSessionWait "keyword" $ do

14381698 let source = T.unlines ["module A where", "f = newty"]

1439− docId <- openDoc' "A.hs" "haskell" source

1699+ docId <- createDoc "A.hs" "haskell" source

14401700 compls <- getCompletions docId (Position 1 9)

14411701 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 "*")]

14421723 ]

14431724 where

14441725 dropDocs :: CompletionItem -> CompletionItem

@@ -1446,6 +1727,7 @@ completionTests

14461727 complItem label kind ty = CompletionItem

14471728 { _label = label

14481729 , _kind = kind

1730+ , _tags = List []

14491731 , _detail = (":: " <>) <$> ty

14501732 , _documentation = Nothing

14511733 , _deprecated = Nothing

@@ -1463,6 +1745,7 @@ completionTests

14631745 keywordItem label = CompletionItem

14641746 { _label = label

14651747 , _kind = Just CiKeyword

1748+ , _tags = List []

14661749 , _detail = Nothing

14671750 , _documentation = Nothing

14681751 , _deprecated = Nothing

@@ -1490,7 +1773,7 @@ outlineTests = testGroup

14901773 "outline"

14911774 [ testSessionWait "type class" $ do

14921775 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]

1493− docId <- openDoc' "A.hs" "haskell" source

1776+ docId <- createDoc "A.hs" "haskell" source

14941777 symbols <- getDocumentSymbols docId

14951778 liftIO $ symbols @?= Left

14961779 [ moduleSymbol

@@ -1503,7 +1786,7 @@ outlineTests = testGroup

15031786 ]

15041787 , testSessionWait "type class instance " $ do

15051788 let source = T.unlines ["class A a where", "instance A () where"]

1506− docId <- openDoc' "A.hs" "haskell" source

1789+ docId <- createDoc "A.hs" "haskell" source

15071790 symbols <- getDocumentSymbols docId

15081791 liftIO $ symbols @?= Left

15091792 [ classSymbol "A a" (R 0 0 0 15) []

@@ -1511,7 +1794,7 @@ outlineTests = testGroup

15111794 ]

15121795 , testSessionWait "type family" $ do

15131796 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]

1514− docId <- openDoc' "A.hs" "haskell" source

1797+ docId <- createDoc "A.hs" "haskell" source

15151798 symbols <- getDocumentSymbols docId

15161799 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]

15171800 , testSessionWait "type family instance " $ do

@@ -1520,7 +1803,7 @@ outlineTests = testGroup

15201803 , "type family A a"

15211804 , "type instance A () = ()"

15221805 ]

1523− docId <- openDoc' "A.hs" "haskell" source

1806+ docId <- createDoc "A.hs" "haskell" source

15241807 symbols <- getDocumentSymbols docId

15251808 liftIO $ symbols @?= Left

15261809 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)

@@ -1528,7 +1811,7 @@ outlineTests = testGroup

15281811 ]

15291812 , testSessionWait "data family" $ do

15301813 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]

1531− docId <- openDoc' "A.hs" "haskell" source

1814+ docId <- createDoc "A.hs" "haskell" source

15321815 symbols <- getDocumentSymbols docId

15331816 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]

15341817 , testSessionWait "data family instance " $ do

@@ -1537,7 +1820,7 @@ outlineTests = testGroup

15371820 , "data family A a"

15381821 , "data instance A () = A ()"

15391822 ]

1540− docId <- openDoc' "A.hs" "haskell" source

1823+ docId <- createDoc "A.hs" "haskell" source

15411824 symbols <- getDocumentSymbols docId

15421825 liftIO $ symbols @?= Left

15431826 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)

@@ -1545,36 +1828,36 @@ outlineTests = testGroup

15451828 ]

15461829 , testSessionWait "constant" $ do

15471830 let source = T.unlines ["a = ()"]

1548− docId <- openDoc' "A.hs" "haskell" source

1831+ docId <- createDoc "A.hs" "haskell" source

15491832 symbols <- getDocumentSymbols docId

15501833 liftIO $ symbols @?= Left

15511834 [docSymbol "a" SkFunction (R 0 0 0 6)]

15521835 , testSessionWait "pattern" $ do

15531836 let source = T.unlines ["Just foo = Just 21"]

1554− docId <- openDoc' "A.hs" "haskell" source

1837+ docId <- createDoc "A.hs" "haskell" source

15551838 symbols <- getDocumentSymbols docId

15561839 liftIO $ symbols @?= Left

15571840 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]

15581841 , testSessionWait "pattern with type signature" $ do

15591842 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]

1560− docId <- openDoc' "A.hs" "haskell" source

1843+ docId <- createDoc "A.hs" "haskell" source

15611844 symbols <- getDocumentSymbols docId

15621845 liftIO $ symbols @?= Left

15631846 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]

15641847 , testSessionWait "function" $ do

15651848 let source = T.unlines ["a x = ()"]

1566− docId <- openDoc' "A.hs" "haskell" source

1849+ docId <- createDoc "A.hs" "haskell" source

15671850 symbols <- getDocumentSymbols docId

15681851 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]

15691852 , testSessionWait "type synonym" $ do

15701853 let source = T.unlines ["type A = Bool"]

1571− docId <- openDoc' "A.hs" "haskell" source

1854+ docId <- createDoc "A.hs" "haskell" source

15721855 symbols <- getDocumentSymbols docId

15731856 liftIO $ symbols @?= Left

15741857 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]

15751858 , testSessionWait "datatype" $ do

15761859 let source = T.unlines ["data A = C"]

1577− docId <- openDoc' "A.hs" "haskell" source

1860+ docId <- createDoc "A.hs" "haskell" source

15781861 symbols <- getDocumentSymbols docId

15791862 liftIO $ symbols @?= Left

15801863 [ docSymbolWithChildren "A"

@@ -1582,18 +1865,47 @@ outlineTests = testGroup

15821865 (R 0 0 0 10)

15831866 [docSymbol "C" SkConstructor (R 0 9 0 10)]

15841867 ]

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+ ]

15851880 , testSessionWait "import" $ do

15861881 let source = T.unlines ["import Data.Maybe"]

1587− docId <- openDoc' "A.hs" "haskell" source

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

15881894 symbols <- getDocumentSymbols docId

15891895 liftIO $ symbols @?= Left

1590− [docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)]

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+ ]

15911903 , testSessionWait "foreign import" $ do

15921904 let source = T.unlines

15931905 [ "{-# language ForeignFunctionInterface #-}"

15941906 , "foreign import ccall \"a\" a :: Int"

15951907 ]

1596− docId <- openDoc' "A.hs" "haskell" source

1908+ docId <- createDoc "A.hs" "haskell" source

15971909 symbols <- getDocumentSymbols docId

15981910 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]

15991911 , testSessionWait "foreign export" $ do

@@ -1601,7 +1913,7 @@ outlineTests = testGroup

16011913 [ "{-# language ForeignFunctionInterface #-}"

16021914 , "foreign export ccall odd :: Int -> Bool"

16031915 ]

1604− docId <- openDoc' "A.hs" "haskell" source

1916+ docId <- createDoc "A.hs" "haskell" source

16051917 symbols <- getDocumentSymbols docId

16061918 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]

16071919 ]

@@ -1614,6 +1926,8 @@ outlineTests = testGroup

16141926 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing

16151927 docSymbolWithChildren name kind loc cc =

16161928 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)

16171931 moduleSymbol name loc cc = DocumentSymbol name

16181932 Nothing

16191933 SkFile

@@ -1635,8 +1949,16 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')

16351949xfail :: TestTree -> String -> TestTree

16361950xfail = flip expectFailBecause

16371951

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+

16381959data Expect

16391960 = ExpectRange Range -- Both gotoDef and hover should report this range

1961+ | ExpectLocation Location

16401962-- | ExpectDefRange Range -- Only gotoDef should report this range

16411963 | ExpectHoverRange Range -- Only hover should report this range

16421964 | ExpectHoverText [T.Text] -- the hover message must contain these snippets

@@ -1649,6 +1971,9 @@ data Expect

16491971mkR :: Int -> Int -> Int -> Int -> Expect

16501972mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn

16511973

1974+mkL :: Uri -> Int -> Int -> Int -> Int -> Expect

1975+mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn

1976+

16521977haddockTests :: TestTree

16531978haddockTests

16541979 = testGroup "haddock"

@@ -1704,6 +2029,167 @@ haddockTests

17042029 where

17052030 checkHaddock s txt = spanDocToMarkdownForTest s @?= txt

17062031

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+

17072193----------------------------------------------------------------------

17082194-- Utils

17092195

@@ -1711,6 +2197,12 @@ haddockTests

17112197testSession :: String -> Session () -> TestTree

17122198testSession name = testCase name . run

17132199

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+

17142206testSessionWait :: String -> Session () -> TestTree

17152207testSessionWait name = testSession name .

17162208 -- Check that any diagnostics produced were already consumed by the test case.

@@ -1721,24 +2213,53 @@ testSessionWait name = testSession name .

17212213 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.

17222214 ( >> expectNoMoreDiagnostics 0.5)

17232215

1724−pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction

1725−pickActionWithTitle title actions = head

1726− [ action

1727− | CACodeAction action@CodeAction{ _title = actionTitle } <- actions

1728− , title == actionTitle ]

2216+pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction

2217+pickActionWithTitle title actions = do

2218+ assertBool ("Found no matching actions: " <> show titles) (not $ null matches)

2219+ return $ head matches

2220+ where

2221+ titles =

2222+ [ actionTitle

2223+ | CACodeAction CodeAction { _title = actionTitle } <- actions

2224+ ]

2225+ matches =

2226+ [ action

2227+ | CACodeAction action@CodeAction { _title = actionTitle } <- actions

2228+ , title == actionTitle

2229+ ]

17292230

17302231mkRange :: Int -> Int -> Int -> Int -> Range

17312232mkRange a b c d = Range (Position a b) (Position c d)

17322233

17332234run :: Session a -> IO a

1734−run s = withTempDir $ \dir -> do

2235+run s = withTempDir $ \dir -> runInDir dir s

2236+

2237+runWithExtraFiles :: FilePath -> (FilePath -> Session a) -> IO a

2238+runWithExtraFiles prefix s = withTempDir $ \dir -> do

2239+ copyTestDataFiles dir prefix

2240+ runInDir dir (s dir)

2241+

2242+copyTestDataFiles :: FilePath -> FilePath -> IO ()

2243+copyTestDataFiles dir prefix = do

2244+ -- Copy all the test data files to the temporary workspace

2245+ testDataFiles <- getDirectoryFilesIO ("test/data" </> prefix) ["//*"]

2246+ for_ testDataFiles $ \f -> do

2247+ createDirectoryIfMissing True $ dir </> takeDirectory f

2248+ copyFile ("test/data" </> prefix </> f) (dir </> f)

2249+

2250+run' :: (FilePath -> Session a) -> IO a

2251+run' s = withTempDir $ \dir -> runInDir dir (s dir)

2252+

2253+runInDir :: FilePath -> Session a -> IO a

2254+runInDir dir s = do

17352255 ghcideExe <- locateGhcideExecutable

17362256

17372257 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56

17382258 -- since the package import test creates "Data/List.hs", which otherwise has no physical home

17392259 createDirectoryIfMissing True $ dir ++ "/Data"

17402260

1741− let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]

2261+

2262+ let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]

17422263 -- HIE calls getXgdDirectory which assumes that HOME is set.

17432264 -- Only sets HOME if it wasn't already set.

17442265 setEnv "HOME" "/homeless-shelter" False

@@ -1755,7 +2276,7 @@ run s = withTempDir $ \dir -> do

17552276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier

17562277openTestDataDoc path = do

17572278 source <- liftIO $ readFileUtf8 $ "test/data" </> path

1758− openDoc' path "haskell" source

2279+ createDoc path "haskell" source

17592280

17602281findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]

17612282findCodeActions doc range expectedTitles = do

@@ -1770,7 +2291,7 @@ findCodeActions doc range expectedTitles = do

17702291 [ actionTitle

17712292 | CACodeAction CodeAction { _title = actionTitle } <- actions

17722293 ]

1773− ++ "is not a superset of "

2294+ ++ " is not a superset of "

17742295 ++ show expectedTitles

17752296 liftIO $ case matches of

17762297 Nothing -> assertFailure msg

@@ -1783,17 +2304,19 @@ findCodeAction doc range t = head <$> findCodeActions doc range [t]

17832304unitTests :: TestTree

17842305unitTests = do

17852306 testGroup "Unit"

1786− [ testCase "empty file path" $

1787− uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just ""

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 ""

17882318 ]

17892319

1790−-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events

1791−openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier

1792−openDoc' fp name contents = do

1793− res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents

1794− sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])

1795− return res

1796−

17972320positionMappingTests :: TestTree

17982321positionMappingTests =

17992322 testGroup "position mapping"

@@ -1962,3 +2485,12 @@ nthLine i r

19622485 | i == 0 && Rope.rows r == 0 = r

19632486 | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)

19642487 | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r

2488+

2489+getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]

2490+getWatchedFilesSubscriptionsUntil = do

2491+ msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)

2492+ return

2493+ [ args

2494+ | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs

2495+ , Registration _id WorkspaceDidChangeWatchedFiles args <- regs

2496+ ]

test/src/Development/IDE/Test.hs+8−2

@@ -1,10 +1,13 @@

22-- SPDX-License-Identifier: Apache-2.0

4+{-# LANGUAGE DuplicateRecordFields #-}

46module Development.IDE.Test

57 ( Cursor

68 , cursorPosition

79 , requireDiagnostic

10+ , diagnostic

811 , expectDiagnostics

912 , expectNoMoreDiagnostics

1013 ) where

@@ -15,7 +18,7 @@ import Control.Monad

1518import Control.Monad.IO.Class

1619import qualified Data.Map.Strict as Map

1720import qualified Data.Text as T

18−import Language.Haskell.LSP.Test hiding (message, openDoc')

21+import Language.Haskell.LSP.Test hiding (message)

1922import qualified Language.Haskell.LSP.Test as LspTest

2023import Language.Haskell.LSP.Types

2124import Language.Haskell.LSP.Types.Lens as Lsp

@@ -77,7 +80,7 @@ expectDiagnostics expected = do

7780 go m

7881 | Map.null m = pure ()

7982 | otherwise = do

80− diagsNot <- skipManyTill anyMessage LspTest.message :: Session PublishDiagnosticsNotification

83+ diagsNot <- skipManyTill anyMessage diagnostic

8184 let fileUri = diagsNot ^. params . uri

8285 case Map.lookup (diagsNot ^. params . uri . to toNormalizedUri) m of

8386 Nothing -> do

@@ -96,6 +99,9 @@ expectDiagnostics expected = do

9699 " but got " <> show actual

97100 go $ Map.delete (diagsNot ^. params . uri . to toNormalizedUri) m

98101

102+diagnostic :: Session PublishDiagnosticsNotification

103+diagnostic = LspTest.message

104+

99105standardizeQuotes :: T.Text -> T.Text

100106standardizeQuotes msg = let

101107 repl '‘' = '\''