2ae46ae...master · ghcide

git.iko.soy/ghcide

69 files changed+7741−1344

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

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+530−80

@@ -3,19 +3,30 @@

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

1930import Development.IDE.Core.Debouncer

2031import Development.IDE.Core.FileStore

2132import Development.IDE.Core.OfInterest

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

3243import Development.IDE.Plugin

3344import Development.IDE.Plugin.Completions as Completions

3445import Development.IDE.Plugin.CodeAction as CodeAction

35−import qualified Data.Text as T

36−import qualified Data.Text.IO as T

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

3747import Language.Haskell.LSP.Messages

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

39−import Linker

40−import Data.Version

48+import Language.Haskell.LSP.Types

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

4150import Development.IDE.LSP.LanguageServer

42−import System.Directory.Extra as IO

51+import qualified System.Directory.Extra as IO

4352import System.Environment

4453import System.IO

4554import System.Exit

55+import System.FilePath

56+import System.Directory

57+import System.Time.Extra

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

4659import Paths_ghcide

4760import Development.GitRev

4861import Development.Shake (Action, action)

4962import qualified Data.HashSet as HashSet

63+import qualified Data.HashMap.Strict as HM

5064import qualified Data.Map.Strict as Map

51−

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)

5271import GHC hiding (def)

53−import qualified GHC.Paths

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

73+import Data.Either.Extra

5474

55−import HIE.Bios

75+import HIE.Bios.Cradle

5676import HIE.Bios.Types

5777

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

59−getLibdir :: IO FilePath

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

78+import Utils

6179

6280ghcideVersion :: IO String

6381ghcideVersion = do

@@ -84,77 +102,68 @@ main = do

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

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

86104

87− whenJust argsCwd setCurrentDirectory

105+ whenJust argsCwd IO.setCurrentDirectory

88106

89− dir <- getCurrentDirectory

107+ dir <- IO.getCurrentDirectory

108+ command <- makeLspCommandId "typesignature.add"

90109

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

92111 onInitialConfiguration = const $ Right ()

93112 onConfigurationChange = const $ Right ()

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

114+ , LSP.completionTriggerCharacters = Just "."

115+ }

94116

95117 if argLSP then do

96118 t <- offsetTime

97119 hPutStrLn stderr "Starting LSP server..."

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

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

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

100122 t <- t

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

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

103− session <- loadSession dir

104− let options = (defaultIdeOptions $ return session)

124+ let options = (defaultIdeOptions $ loadSessionShake dir)

105125 { optReportProgress = clientSupportsProgress caps

106126 , optShakeProfiling = argsShakeProfiling

127+ , optTesting = argsTesting

128+ , optThreads = argsThreads

107129 }

108130 debouncer <- newAsyncDebouncer

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

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

132+ getLspId event (logger minBound) debouncer options vfs

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

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

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

113140

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

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

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

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

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

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

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

119146

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

121148 cradles <- mapM findCradle files

122149 let ucradles = nubOrd cradles

123150 let n = length ucradles

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

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

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

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

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

129− when (isNothing x) $ print cradle

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

131− cradleToSession cradle

132−

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

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

134153 vfs <- makeVFSHandle

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

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

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

138− cradle <- Map.lookup file filesToCradles

139− Map.lookup cradle cradlesToSessions

140−

141− let options =

142− (defaultIdeOptions $ return $ return . grab)

143− { optShakeProfiling = argsShakeProfiling }

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

145−

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

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

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

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

150161 when (failed /= []) $

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

152163

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

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

155−

156− unless (null failed) exitFailure

157−

166+ return ()

158167

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

160169expandFiles = concatMapM $ \x -> do

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

163172 let recurse "." = True

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

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

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

167176 when (null files) $

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

169178 return files

@@ -177,44 +186,409 @@ kick = do

177186-- | Print an LSP event.

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

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

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

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

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

182191showEvent lock e = withLock lock $ print e

183192

184193

185−cradleToSession :: Cradle a -> IO HscEnvEq

186−cradleToSession cradle = do

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

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

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

189− opts <- case cradleRes of

190− CradleSuccess r -> pure r

191− CradleFail err -> throwIO err

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

193− -- That will require some more changes.

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

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

195208 libdir <- getLibdir

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

197− _targets <- initSession opts

198− getSession

209+ env <- runGhc (Just libdir) getSession

199210 initDynLinker env

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

201386

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)

202403

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

204−loadSession dir = do

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

206− res <- findCradle v

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

208− -- try and normalise that

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

210− res' <- traverse makeAbsolute res

211− return $ normalise <$> res'

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

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

214− cradleToSession c

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

216404

217405

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+

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

219593--

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

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

231605 res <- onceFork $ op k

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

233607 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+98−10

@@ -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.20.*,

47− haskell-lsp == 0.20.*,

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

54+ haskell-lsp == 0.22.*,

4855 mtl,

4956 network-uri,

5057 prettyprinter-ansi-terminal,

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

99109 include-dirs:

100110 include

101111 exposed-modules:

112+ Development.IDE.Compat

102113 Development.IDE.Core.Debouncer

103114 Development.IDE.Core.FileStore

104115 Development.IDE.Core.IdeConfiguration

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

111122 Development.IDE.GHC.Error

112123 Development.IDE.GHC.Util

113124 Development.IDE.Import.DependencyInformation

125+ Development.IDE.LSP.HoverDefinition

114126 Development.IDE.LSP.LanguageServer

127+ Development.IDE.LSP.Outline

115128 Development.IDE.LSP.Protocol

116129 Development.IDE.LSP.Server

117130 Development.IDE.Spans.Common

@@ -130,16 +143,26 @@ library

130143 Development.IDE.GHC.CPP

131144 Development.IDE.GHC.Orphans

132145 Development.IDE.GHC.Warnings

146+ Development.IDE.GHC.WithDynFlags

133147 Development.IDE.Import.FindImports

134− Development.IDE.LSP.HoverDefinition

135148 Development.IDE.LSP.Notifications

136− Development.IDE.LSP.Outline

137149 Development.IDE.Spans.AtPoint

138150 Development.IDE.Spans.Calculate

139151 Development.IDE.Spans.Documentation

140152 Development.IDE.Spans.Type

153+ Development.IDE.Plugin.CodeAction.PositionIndexed

154+ Development.IDE.Plugin.CodeAction.Rules

155+ Development.IDE.Plugin.CodeAction.RuleTypes

141156 Development.IDE.Plugin.Completions.Logic

142157 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

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

144167

145168executable ghcide-test-preprocessor

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

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

168191 main-is: Main.hs

169192 build-depends:

193+ time,

194+ async,

170195 hslogger,

196+ aeson,

171197 base == 4.*,

198+ binary,

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

200+ bytestring,

172201 containers,

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

173203 data-default,

204+ deepseq,

174205 directory,

175206 extra,

176207 filepath,

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

177209 ghc-paths,

178210 ghc,

179211 gitrev,

212+ hashable,

180213 haskell-lsp,

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

214+ haskell-lsp-types,

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

182216 ghcide,

183217 optparse-applicative,

184218 shake,

185219 text,

186220 unordered-containers

187221 other-modules:

222+ Utils

188223 Arguments

189224 Paths_ghcide

190225

191226 default-extensions:

227+ BangPatterns

228+ DeriveFunctor

229+ DeriveGeneric

230+ GeneralizedNewtypeDeriving

231+ LambdaCase

232+ NamedFieldPuns

233+ OverloadedStrings

192234 RecordWildCards

235+ ScopedTypeVariables

236+ StandaloneDeriving

193237 TupleSections

238+ TypeApplications

194239 ViewPatterns

195240

196241test-suite ghcide-tests

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

222267 haddock-library,

223268 haskell-lsp,

224269 haskell-lsp-types,

270+ network-uri,

225271 lens,

226− lsp-test >= 0.8,

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

227273 parser-combinators,

228274 QuickCheck,

229275 quickcheck-instances,

230276 rope-utf16-splay,

277+ shake,

231278 tasty,

232279 tasty-expected-failure,

233280 tasty-hunit,

234281 tasty-quickcheck,

282+ tasty-rerun,

235283 text

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

237285 include-dirs: include

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

254302 TupleSections

255303 TypeApplications

256304 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+272−81

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

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

4352#endif

4453

4554import Finder

46−import qualified GHC

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

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

4757import GhcMonad

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

4959import qualified HeaderInfo as Hdr

5060import HscMain (hscInteractive, hscSimplify)

61+import LoadIface (readIface)

62+import qualified Maybes

5163import MkIface

64+import NameCache

5265import StringBuffer as SB

53−import TcRnMonad (tcg_th_coreplugins)

66+import TcRnMonad (initIfaceLoad, tcg_th_coreplugins)

67+import TcIface (typecheckIface)

5468import TidyPgm

5569

70+import Control.Exception.Safe

5671import Control.Monad.Extra

5772import Control.Monad.Except

5873import Control.Monad.Trans.Except

59−import Data.Function

60−import Data.Ord

74+import Data.Bifunctor (first, second)

6175import qualified Data.Text as T

6276import Data.IORef

6377import Data.List.Extra

6478import Data.Maybe

65−import Data.Tuple.Extra

6679import qualified Data.Map.Strict as Map

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

6887

6988

7089-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.

7190parseModule

7291 :: IdeOptions

7392 -> HscEnv

93+ -> [PackageName]

7494 -> FilePath

7595 -> Maybe SB.StringBuffer

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

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

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

7898 fmap (either (, Nothing) id) $

79− runGhcEnv env $ runExceptT $ do

99+ evalGhcEnv env $ runExceptT $ do

80100 (contents, dflags) <- preprocessor filename mbContents

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

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

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

83103

84104

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

90110computePackageDeps env pkg = do

91111 let dflags = hsc_dflags env

92112 case lookupInstalledPackage dflags pkg of

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

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

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

95115 Just pkgInfo -> return $ Right $ depends pkgInfo

96116

97−

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

99−typecheckModule

100− :: IdeDefer

101− -> HscEnv

102− -> [TcModuleResult]

103− -> ParsedModule

104− -> IO (IdeResult TcModuleResult)

105−typecheckModule (IdeDefer defer) packageState deps pm =

106− let demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id

107− in

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

109− runGhcEnv packageState $

110− catchSrcErrors "typecheck" $ do

111− setupEnv deps

112− let modSummary = pm_mod_summary pm

113− dflags = ms_hspp_opts modSummary

114− modSummary' <- initPlugins modSummary

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

116− GHC.typecheckModule $ enableTopLevelWarnings

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

118− tcm2 <- mkTcModuleResult tcm

119− let errorPipeline = unDefer . hideDiag dflags

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

121146

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

123148initPlugins modSummary = do

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

129154 return modSummary

130155#endif

131156

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+

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

133164-- provide errors.

134165compileModule

135− :: HscEnv

136− -> [TcModuleResult]

166+ :: RunSimplifier

167+ -> HscEnv

168+ -> [(ModSummary, HomeModInfo)]

137169 -> TcModuleResult

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

139−compileModule packageState deps tmr =

171+compileModule (RunSimplifier simplify) packageState deps tmr =

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

141− runGhcEnv packageState $

173+ evalGhcEnv packageState $

142174 catchSrcErrors "compile" $ do

143− setupEnv (deps ++ [tmr])

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

144176

145177 let tm = tmrModule tmr

146178 session <- getSession

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

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

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

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

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

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

155− -- errors like #256

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

157− desugared_guts <- liftIO $ hscSimplify session plugins desugar

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

158191 -- give variables unique OccNames

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

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

161194

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

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

163196generateByteCode hscEnv deps tmr guts =

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

165− runGhcEnv hscEnv $

198+ evalGhcEnv hscEnv $

166199 catchSrcErrors "bytecode" $ do

167− setupEnv (deps ++ [tmr])

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

168201 session <- getSession

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

170203#if MIN_GHC_API_VERSION(8,10,0)

@@ -193,9 +226,10 @@ demoteTypeErrorsToWarnings =

193226enableTopLevelWarnings :: ParsedModule -> ParsedModule

194227enableTopLevelWarnings =

195228 (update_pm_mod_summary . update_hspp_opts)

196− (`wopt_set` Opt_WarnMissingSignatures)

229+ ((`wopt_set` Opt_WarnMissingPatternSynonymSignatures) .

230+ (`wopt_set` Opt_WarnMissingSignatures))

197231 -- the line below would show also warnings for let bindings without signature

198− -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures))

232+ -- ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures)))

199233

200234update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary

201235update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}

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

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

222256hideDiag _originalFlags t = t

223257

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

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

225259addRelativeImport fp modu dflags = dflags

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

227261

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

231265 -> m TcModuleResult

232266mkTcModuleResult tcm = do

233267 session <- getSession

268+ let sf = modInfoSafe (tm_checked_module_info tcm)

234269#if MIN_GHC_API_VERSION(8,10,0)

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

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

236271#else

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

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

238273#endif

239274 let mod_info = HomeModInfo iface details Nothing

240275 return $ TcModuleResult tcm mod_info

241276 where

242277 (tcGblEnv, details) = tm_internals_ tcm

243278

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+

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

245326-- best understanding (!)

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

247−setupEnv tmsIn = do

248− -- if both a .hs-boot file and a .hs file appear here, we want to make sure that the .hs file

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

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

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

252336

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

338+-- sorted.

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

340+setupFinderCache mss = do

253341 session <- getSession

254342

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

256−

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

258344 let graph = mkModuleGraph mss

259345 setSession session { hsc_mod_graph = graph }

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

272358 newFinderCacheVar <- liftIO $ newIORef $! newFinderCache

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

274360

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

276− mapM_ loadModuleHome tms

277−

278361

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

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

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

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

283370loadModuleHome

284− :: (GhcMonad m)

285− => TcModuleResult

286− -> m ()

287−loadModuleHome tmr = modifySession $ \e ->

288− e { hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }

289− where

290− ms = pm_mod_summary . tm_parsed_module . tmrModule $ tmr

291− mod_info = tmrModInfo tmr

292− mod = ms_mod_name ms

293−

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

294389

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'

295395

296396-- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's

297397-- name and its imports.

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

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

313413 ])

314414

315−

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

317416getModSummaryFromBuffer

318417 :: GhcMonad m

319418 => FilePath

320− -> SB.StringBuffer

321419 -> DynFlags

322420 -> GHC.ParsedSource

323421 -> ExceptT [FileDiagnostic] m ModSummary

324−getModSummaryFromBuffer fp contents dflags parsed = do

422+getModSummaryFromBuffer fp dflags parsed = do

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

326424

327425 modLoc <- liftIO $ mkHomeModLocation dflags modName fp

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

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

338436 , ms_hspp_file = fp

339437 , ms_hspp_opts = dflags

340− , ms_hspp_buf = Just contents

438+ , ms_hspp_buf = Nothing

341439

342440 -- defaults:

343441 , ms_hsc_src = sourceType

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

352450 where

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

354452

355−

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

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

357498-- parsed module (or errors) and any parse warnings. Does not run any preprocessors

358499parseFileContents

359500 :: GhcMonad m

360501 => (GHC.ParsedSource -> IdePreprocessedSource)

361502 -> DynFlags -- ^ flags to use

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

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

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

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

365−parseFileContents customPreprocessor dflags filename contents = do

507+parseFileContents customPreprocessor dflags comp_pkgs filename contents = do

366508 let loc = mkRealSrcLoc (mkFastString filename) 1 1

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

368510#if MIN_GHC_API_VERSION(8,10,0)

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

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

395537 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

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

539+ let parsed' = removePackageImports comp_pkgs parsed

397540 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

398− ms <- getModSummaryFromBuffer filename contents dflags parsed

541+ ms <- getModSummaryFromBuffer filename dflags parsed'

399542 let pm =

400543 ParsedModule {

401544 pm_mod_summary = ms

402− , pm_parsed_source = parsed

545+ , pm_parsed_source = parsed'

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

404547 , pm_annotations = hpm_annotations

405548 }

406549 warnings = diagFromErrMsgs "parser" dflags warns

407550 pure (warnings ++ preproc_warnings, pm)

551+

552+

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

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

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

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

557+ where

558+ imports' = map do_one_import hsmodImports

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

560+ case PackageName . sl_fs <$> ideclPkgQual of

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

562+ _ -> L l i

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

564+ do_one_import l = l

565+#endif

566+

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

568+loadHieFile f = do

569+ u <- mkSplitUniqSupply 'a'

570+ let nameCache = initNameCache u []

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

572+

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

574+-- Assumes file exists.

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

576+loadInterface

577+ :: HscEnv

578+ -> ModSummary

579+ -> [HiFileResult]

580+ -> IO (Either String ModIface)

581+loadInterface session ms deps = do

582+ let hiFile = case ms_hsc_src ms of

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

584+ _ -> ml_hi_file $ ms_location ms

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

586+ case r of

587+ Maybes.Succeeded iface -> do

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

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

590+ return $ maybeToEither (showReason reason) iface'

591+ Maybes.Failed err -> do

592+ let errMsg = showSDoc (hsc_dflags session) err

593+ return $ Left errMsg

594+

595+showReason :: RecompileRequired -> String

596+showReason MustCompile = "Stale"

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

598+showReason UpToDate = "Up to date"

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

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

2222import Development.IDE.Core.IdeConfiguration

2323import Development.IDE.Core.Shake

2424import Development.IDE.Types.Location

25+import Development.IDE.Types.Logger

2526import Development.Shake

2627import Development.Shake.Classes

2728import GHC.Generics

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

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

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

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

93−fileExistsRules getLspId ClientCapabilities{_workspace}

94− | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace

95− , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles

96− , Just True <- _dynamicRegistration

97− = fileExistsRulesFast getLspId

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

99108

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

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

102−fileExistsRulesFast getLspId vfs = do

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

111+fileExistsRulesFast getLspId vfs =

104112 defineEarlyCutoff $ \GetFileExists file -> do

105113 isWf <- isWorkspaceFile file

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

114+ if isWf

115+ then fileExistsFast getLspId vfs file

116+ else fileExistsSlow vfs file

107117

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

109119fileExistsFast getLspId vfs file = do

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

140150 WorkspaceDidChangeWatchedFiles

141151 (Just (A.toJSON regOptions))

142152 regOptions =

143− DidChangeWatchedFilesRegistrationOptions { watchers = List [watcher] }

144− watcher = FileSystemWatcher { globPattern = fromNormalizedFilePath fp

145− , 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

146157 }

147158

148159 eventer $ ReqRegisterCapability req

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

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

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

170181 Dir.doesFileExist (fromNormalizedFilePath file)

171−

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

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

174−

175−data DidChangeWatchedFilesRegistrationOptions = DidChangeWatchedFilesRegistrationOptions

176− { watchers :: List FileSystemWatcher

177− }

178−

179−instance A.ToJSON DidChangeWatchedFilesRegistrationOptions where

180− toJSON DidChangeWatchedFilesRegistrationOptions {..} =

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

182−

183−data FileSystemWatcher = FileSystemWatcher

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

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

186− globPattern :: String

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

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

189− , kind :: Maybe Int

190− }

191−

192−instance A.ToJSON FileSystemWatcher where

193− toJSON FileSystemWatcher {..} =

194− A.object

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

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

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

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

1717import Development.IDE.Types.Location

1818import Development.Shake

1919import Language.Haskell.LSP.Types

20+import System.FilePath (isRelative)

2021

2122-- | Lsp client relevant configuration details

2223data IdeConfiguration = IdeConfiguration

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

5859 writeVar var (IdeConfiguration (f ws))

5960

6061isWorkspaceFile :: NormalizedFilePath -> Action Bool

61−isWorkspaceFile file = do

62− IdeConfiguration {..} <- getIdeConfiguration

63− let toText = getUri . fromNormalizedUri

64− return $ any

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

66− workspaceFolders

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/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+48−9

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

2424import GHC

2525import Module (InstalledUnitId)

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

27−import Development.IDE.GHC.Compat

2827

2928import Development.IDE.Spans.Type

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

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

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

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+417−116

@@ -1,17 +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 #-}

7−{-# LANGUAGE PatternSynonyms #-}

8+#include "ghc-api-version.h"

910-- | A Shake implementation of the compiler service, built

1011-- using the "Shaker" abstraction layer for in-memory use.

1112--

1213module Development.IDE.Core.Rules(

1314 IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),

14− Priority(..),

15+ Priority(..), GhcSessionIO(..), GhcSessionFun(..),

1516 priorityTypeCheck,

1617 priorityGenerateCore,

1718 priorityFilesOfInterest,

@@ -27,12 +28,13 @@ module Development.IDE.Core.Rules(

2728

2829import Fingerprint

2930

30−import Data.Binary

31−import Data.Bifunctor (second)

32−import Control.Monad

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

32+import Data.Bifunctor (first, second)

33+import Control.Monad.Extra

3334import Control.Monad.Trans.Class

3435import Control.Monad.Trans.Maybe

3536import Development.IDE.Core.Compile

37+import Development.IDE.Core.OfInterest

3638import Development.IDE.Types.Options

3739import Development.IDE.Spans.Calculate

3840import Development.IDE.Import.DependencyInformation

@@ -43,31 +45,37 @@ import Development.IDE.Types.Diagnostics

4345import Development.IDE.Types.Location

4446import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)

4547import Development.IDE.GHC.Util

46−import Data.Coerce

48+import Development.IDE.GHC.WithDynFlags

4749import Data.Either.Extra

4850import Data.Maybe

4951import Data.Foldable

5052import qualified Data.IntMap.Strict as IntMap

51−import qualified Data.IntSet as IntSet

53+import Data.IntMap.Strict (IntMap)

5254import Data.List

55+import Data.Ord

5356import qualified Data.Set as Set

5457import qualified Data.Text as T

5558import Development.IDE.GHC.Error

5659import Development.Shake hiding (Diagnostic)

5760import Development.IDE.Core.RuleTypes

5861import Development.IDE.Spans.Type

62+import qualified Data.ByteString.Char8 as BS

5963

6064import qualified GHC.LanguageExtensions as LangExt

61−import UniqSupply

62−import NameCache

6365import HscTypes

64−import DynFlags (xopt)

66+import PackageConfig

67+import DynFlags (gopt_set, xopt)

6568import GHC.Generics(Generic)

6669

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

6871import Development.IDE.Core.Service

6972import Development.IDE.Core.Shake

70−import Development.Shake.Classes

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

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

75+import Data.ByteString (ByteString)

76+import Control.Concurrent.Async (concurrently)

77+

78+import Control.Monad.State

7179

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

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

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

8189useE k = MaybeT . use k

8290

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

84−useNoFileE k = useE k ""

92+useNoFileE k = useE k emptyFilePath

8593

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

8795usesE k = MaybeT . fmap sequence . uses k

8896

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

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

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

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

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

93101

94102

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

112120getDefinition file pos = fmap join $ runMaybeT $ do

113121 opts <- lift getIdeOptions

114122 spans <- useE GetSpanInfo file

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

116− let getHieFile x = useNoFile (GetHieFile x)

117− lift $ AtPoint.gotoDefinition getHieFile opts pkgState (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

118175

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

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

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

134191priorityFilesOfInterest = Priority (-2)

135192

136193getParsedModuleRule :: Rules ()

137−getParsedModuleRule =

138− defineEarlyCutoff $ \GetParsedModule file -> do

139− (_, contents) <- getFileContents file

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

141− opt <- getIdeOptions

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

143− case res of

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

145− Just (contents, modu) -> do

146− mbFingerprint <- if isNothing $ optShakeFiles opt

147− then pure Nothing

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

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

150235

151236getLocatedImportsRule :: Rules ()

152237getLocatedImportsRule =

153238 define $ \GetLocatedImports file -> do

154− pm <- use_ GetParsedModule file

155− let ms = pm_mod_summary pm

239+ ms <- use_ GetModSummary file

156240 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]

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

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

159245 opt <- getIdeOptions

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

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

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

162248 case diagOrImp of

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

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

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

172258 Nothing -> pure (concat diags, Nothing)

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

174260

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

175269

176270-- | Given a target file path, construct the raw dependency results by following

177271-- imports recursively.

178−rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation

179−rawDependencyInformation f = do

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

181− go (IntSet.singleton $ getFilePathId initialId)

182− (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 })

183277 where

184− go fs rawDepInfo =

185− case IntSet.minView fs of

186− -- Queue is empty

187− Nothing -> pure rawDepInfo

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

189− Just (f, fs) -> do

190− let fId = FilePathId f

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

192− case importsOrErr of

193− Nothing ->

194− -- File doesn’t parse

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

196− in go fs rawDepInfo'

197− Just (modImports, pkgImports) -> do

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

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

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

201− Just path ->

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

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

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

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

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

207− let newFiles =

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

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

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

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

212359

213360getDependencyInformationRule :: Rules ()

214361getDependencyInformationRule =

215362 define $ \GetDependencyInformation file -> do

216− rawDepInfo <- rawDependencyInformation file

363+ rawDepInfo <- rawDependencyInformation [file]

217364 pure ([], Just $ processDependencyInformation rawDepInfo)

218365

219366reportImportCyclesRule :: Rules ()

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

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

242389 , _code = Nothing

243390 , _relatedInformation = Nothing

391+ , _tags = Nothing

244392 }

245393 where loc = srcSpanToLocation (getLoc imp)

246− fp = toNormalizedFilePath $ srcSpanToFilename (getLoc imp)

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

247395 getModuleName file = do

248− pm <- use_ GetParsedModule file

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

396+ ms <- use_ GetModSummary file

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

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

251399

252400-- returns all transitive dependencies in topological order.

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

266414getSpanInfoRule =

267415 define $ \GetSpanInfo file -> do

268416 tc <- use_ TypeCheck file

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

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

270− parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)

419+ let tdeps = transitiveModuleDeps deps

420+

421+-- When possible, rely on the haddocks embedded in our interface files

422+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'

423+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)

424+ let parsedDeps = []

425+#else

426+ parsedDeps <- uses_ GetParsedModule tdeps

427+#endif

428+

429+ ifaces <- uses_ GetModIface tdeps

271430 (fileImports, _) <- use_ GetLocatedImports file

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

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

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

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

274433 return ([], Just x)

275434

276435-- Typechecks a module.

277436typeCheckRule :: Rules ()

278−typeCheckRule =

279− define $ \TypeCheck file -> do

280− pm <- use_ GetParsedModule file

281− deps <- use_ GetDependencies file

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

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

284− let graph_needs_th_qq = needsTemplateHaskellOrQQ $ hsc_mod_graph packageState

285− file_uses_th_qq = uses_th_qq $ ms_hspp_opts (pm_mod_summary pm)

286− any_uses_th_qq = graph_needs_th_qq || file_uses_th_qq

287− tms <- if any_uses_th_qq

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

289− then do

290− bytecodes <- uses_ GenerateByteCode (transitiveModuleDeps deps)

291− tmrs <- uses_ TypeCheck (transitiveModuleDeps deps)

292− pure (zipWith addByteCode bytecodes tmrs)

293− else uses_ TypeCheck (transitiveModuleDeps deps)

294− setPriority priorityTypeCheck

295− IdeOptions{ optDefer = defer} <- getIdeOptions

296− liftIO $ typecheckModule defer packageState tms pm

297− where

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

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

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

301−

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

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

304503 deps <- use_ GetDependencies file

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

306505 setPriority priorityGenerateCore

307506 packageState <- hscEnv <$> use_ GhcSession file

308− liftIO $ compileModule packageState tms tm

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

309508

310509generateCoreRule :: Rules ()

311510generateCoreRule =

312− define $ \GenerateCore -> generateCore

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

313512

314513generateByteCodeRule :: Rules ()

315514generateByteCodeRule =

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

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

319518 session <- hscEnv <$> use_ GhcSession file

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

321− liftIO $ generateByteCode session tms tm guts

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

322521

323522-- A local rule type to get caching. We want to use newCache, but it has

324523-- thread killed exception issues, so we lift it to a full rule.

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

330529instance NFData GhcSessionIO

331530instance Binary GhcSessionIO

332531

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

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

334533instance Show GhcSessionFun where show _ = "GhcSessionFun"

335534instance NFData GhcSessionFun where rnf !_ = ()

336535

@@ -339,20 +538,119 @@ loadGhcSession :: Rules ()

339538loadGhcSession = do

340539 defineNoFile $ \GhcSessionIO -> do

341540 opts <- getIdeOptions

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

343546 defineEarlyCutoff $ \GhcSession file -> do

344547 GhcSessionFun fun <- useNoFile_ GhcSessionIO

548+ alwaysRerun

345549 val <- fun $ fromNormalizedFilePath file

346− opts <- getIdeOptions

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

348550

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)

349648

350−getHieFileRule :: Rules ()

351−getHieFileRule =

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

353− u <- liftIO $ mkSplitUniqSupply 'a'

354− let nameCache = initNameCache u []

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

356654

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

358656mainRule :: Rules ()

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

367665 generateCoreRule

368666 generateByteCodeRule

369667 loadGhcSession

370− getHieFileRule

668+ getHiFileRule

669+ getModIfaceRule

670+ isFileOfInterestRule

671+ getModSummaryRule

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

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

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

2121module Development.IDE.Core.Shake(

2222 IdeState, shakeExtras,

23− ShakeExtras(..), getShakeExtras,

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

2424 IdeRule, IdeResult, GetModificationTime(..),

2525 shakeOpen, shakeShut,

2626 shakeRun,

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

5353import Data.Dynamic

5454import Data.Maybe

5555import Data.Map.Strict (Map)

56−import Data.List.Extra (foldl', partition, takeEnd)

56+import Data.List.Extra (partition, takeEnd)

5757import qualified Data.Set as Set

5858import qualified Data.Text as T

5959import Data.Traversable (for)

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

6969import Development.IDE.Types.Options

7070import Control.Concurrent.Async

7171import Control.Concurrent.Extra

72−import Control.Exception

72+import Control.Exception.Extra

7373import Control.DeepSeq

7474import System.Time.Extra

7575import Data.Typeable

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

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

9898 -- ^ This represents the set of diagnostics that we have published.

9999 -- Due to debouncing not every change might get published.

100− ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion PositionMapping))

100+ ,positionMapping :: Var (HMap.HashMap NormalizedUri (Map TextDocumentVersion (PositionDelta, PositionMapping)))

101101 -- ^ Map from a text document version to a PositionMapping that describes how to map

102102 -- positions in a version of that document to positions in the latest version

103+ -- First mapping is delta from previous version and second one is an

104+ -- accumlation of all previous mappings.

103105 ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int)

104106 -- ^ How many rules are running for each file

105107 }

@@ -124,14 +126,19 @@ addIdeGlobal x = do

124126addIdeGlobalExtras :: IsIdeGlobal a => ShakeExtras -> a -> IO ()

125127addIdeGlobalExtras ShakeExtras{globals} x@(typeOf -> ty) =

126128 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of

127− Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty

129+ Just _ -> errorIO $ "Internal error, addIdeGlobalExtras, got the same type twice for " ++ show ty

128130 Nothing -> return $! HMap.insert ty (toDyn x) mp

129131

130132

131133getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a

132134getIdeGlobalExtras ShakeExtras{globals} = do

133− Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals

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

135142

136143getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a

137144getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras

@@ -154,7 +161,7 @@ instance Eq Key where

154161 | otherwise = False

155162

156163instance Hashable Key where

157− hashWithSalt salt (Key key) = hashWithSalt salt key

164+ hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)

158165

159166-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,

160167-- and a value is in the Maybe. For operations that throw an error you

@@ -164,9 +171,6 @@ instance Hashable Key where

164171-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh

165172-- errors but still failed.

166173--

167−-- A rule on a file should only return diagnostics for that given file. It should

168−-- not propagate diagnostic errors through multiple phases.

169−type IdeResult v = ([FileDiagnostic], Maybe v)

170174

171175data Value v

172176 = Succeeded TextDocumentVersion v

@@ -201,12 +205,12 @@ valueVersion = \case

201205 Failed -> Nothing

202206

203207mappingForVersion

204− :: HMap.HashMap NormalizedUri (Map TextDocumentVersion PositionMapping)

208+ :: HMap.HashMap NormalizedUri (Map TextDocumentVersion (a, PositionMapping))

205209 -> NormalizedFilePath

206210 -> TextDocumentVersion

207211 -> PositionMapping

208212mappingForVersion allMappings file ver =

209− fromMaybe idMapping $

213+ maybe zeroMapping snd $

210214 Map.lookup ver =<<

211215 HMap.lookup (filePathToUri' file) allMappings

212216

@@ -239,7 +243,6 @@ shakeRunDatabaseProfile mbProfileDir shakeDb acts = do

239243 shakeProfileDatabase shakeDb $ dir </> file

240244 return (dir </> file)

241245 return (res, proFile)

242− where

243246

244247{-# NOINLINE profileStartTime #-}

245248profileStartTime :: String

@@ -414,7 +417,7 @@ shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =

414417 Right _ -> "completed"

415418 profile = case res of

416419 Right (_, Just fp) ->

417− let link = case filePathToUri' $ toNormalizedFilePath fp of

420+ let link = case filePathToUri' $ toNormalizedFilePath' fp of

418421 NormalizedUri _ x -> x

419422 in ", profile saved at " <> T.unpack link

420423 _ -> ""

@@ -473,25 +476,25 @@ useWithStale :: IdeRule k v

473476useWithStale key file = head <$> usesWithStale key [file]

474477

475478useNoFile :: IdeRule k v => k -> Action (Maybe v)

476−useNoFile key = use key ""

479+useNoFile key = use key emptyFilePath

477480

478481use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v

479482use_ key file = head <$> uses_ key [file]

480483

481484useNoFile_ :: IdeRule k v => k -> Action v

482−useNoFile_ key = use_ key ""

485+useNoFile_ key = use_ key emptyFilePath

483486

484487uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]

485488uses_ key files = do

486489 res <- uses key files

487490 case sequence res of

488− Nothing -> liftIO $ throwIO BadDependency

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

489492 Just v -> return v

490493

491494

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

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

494−data BadDependency = BadDependency deriving Show

497+data BadDependency = BadDependency String deriving Show

495498instance Exception BadDependency

496499

497500isBadDependency :: SomeException -> Bool

@@ -510,12 +513,10 @@ instance Show k => Show (Q k) where

510513

511514-- | Invariant: the 'v' must be in normal form (fully evaluated).

512515-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database

513−-- Note (MK) I am not sure why we need the ShakeValue here, maybe we

514−-- can just remove it?

515−data A v = A (Value v) ShakeValue

516+newtype A v = A (Value v)

516517 deriving Show

517518

518−instance NFData (A v) where rnf (A v x) = v `seq` rnf x

519+instance NFData (A v) where rnf (A v) = v `seq` ()

519520

520521-- In the Shake database we only store one type of key/result pairs,

521522-- namely Q (question) / A (answer).

@@ -525,19 +526,22 @@ type instance RuleResult (Q k) = A (RuleResult k)

525526-- | Return up2date results. Stale results will be ignored.

526527uses :: IdeRule k v

527528 => k -> [NormalizedFilePath] -> Action [Maybe v]

528−uses key files = map (\(A value _) -> currentValue value) <$> apply (map (Q . (key,)) files)

529+uses key files = map (\(A value) -> currentValue value) <$> apply (map (Q . (key,)) files)

529530

530531-- | Return the last computed result which might be stale.

531532usesWithStale :: IdeRule k v

532533 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]

533534usesWithStale key files = do

534− values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)

535− mapM (uncurry lastValue) (zip files values)

535+ values <- map (\(A value) -> value) <$> apply (map (Q . (key,)) files)

536+ zipWithM lastValue files values

536537

537538

538539withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b

539540withProgress var file = actionBracket (f succ) (const $ f pred) . const

540− where f shift = modifyVar_ var $ return . HMap.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

541545

542546

543547defineEarlyCutoff

@@ -554,16 +558,16 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old

554558 case v of

555559 -- No changes in the dependencies and we have

556560 -- an existing result.

557− Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)

561+ Just v -> return $ Just $ RunResult ChangedNothing old $ A v

558562 _ -> return Nothing

559563 _ -> return Nothing

560564 case val of

561565 Just res -> return res

562566 Nothing -> do

563567 (bs, (diags, res)) <- actionCatch

564− (do v <- op key file; liftIO $ evaluate $ force $ v) $

568+ (do v <- op key file; liftIO $ evaluate $ force v) $

565569 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))

566− modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file

570+ modTime <- liftIO $ (currentValue =<<) <$> getValues state GetModificationTime file

567571 (bs, res) <- case res of

568572 Nothing -> do

569573 staleV <- liftIO $ getValues state key file

@@ -573,7 +577,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old

573577 Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)

574578 Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)

575579 Failed -> (toShakeValue ShakeResult bs, Failed)

576− Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)

580+ Just v -> pure (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)

577581 liftIO $ setValues state key file res

578582 updateFileDiagnostics file (Key key) extras $ map (\(_,y,z) -> (y,z)) diags

579583 let eq = case (bs, fmap decodeShakeValue old) of

@@ -585,7 +589,7 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old

585589 return $ RunResult

586590 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)

587591 (encodeShakeValue bs) $

588− A res bs

592+ A res

589593

590594

591595-- | Rule type, input file

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

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

657661needOnDisk k file = do

658662 successfull <- apply1 (QDisk k file)

659− liftIO $ unless successfull $ throwIO BadDependency

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

660664

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

662666needOnDisks k files = do

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

664− liftIO $ unless (and successfulls) $ throwIO BadDependency

668+ liftIO $ unless (and successfulls) $ throwIO $ BadDependency (show k)

665669

666670toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue

667671toShakeValue = maybe ShakeNoCutoff

@@ -700,7 +704,7 @@ updateFileDiagnostics ::

700704 -> [(ShowDiagnostic,Diagnostic)] -- ^ current results

701705 -> Action ()

702706updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do

703− modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp

707+ modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp

704708 let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current

705709 mask_ $ do

706710 -- Mask async exceptions to ensure that updated diagnostics are always

@@ -713,7 +717,7 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, published

713717 let newDiags = getFileDiagnostics fp newDiagsStore

714718 _ <- evaluate newDiagsStore

715719 _ <- evaluate newDiags

716− pure $! (newDiagsStore, newDiags)

720+ pure (newDiagsStore, newDiags)

717721 modifyVar_ hiddenDiagnostics $ \old -> do

718722 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)

719723 (T.pack $ show k) (map snd currentHidden) old

@@ -739,7 +743,7 @@ publishDiagnosticsNotification uri diags =

739743newtype Priority = Priority Double

740744

741745setPriority :: Priority -> Action ()

742−setPriority (Priority p) = deprioritize p

746+setPriority (Priority p) = reschedule p

743747

744748sendEvent :: LSP.FromServerMessage -> Action ()

745749sendEvent e = do

@@ -765,7 +769,7 @@ instance Binary GetModificationTime

765769type instance RuleResult GetModificationTime = FileVersion

766770

767771data FileVersion

768− = VFSVersion Int

772+ = VFSVersion !Int

769773 | ModificationTime

770774 !Int -- ^ Large unit (platform dependent, do not make assumptions)

771775 !Int -- ^ Small unit (platform dependent, do not make assumptions)

@@ -819,7 +823,7 @@ filterDiagnostics ::

819823 DiagnosticStore ->

820824 DiagnosticStore

821825filterDiagnostics keep =

822− HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)

826+ HMap.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath') $ uriToFilePath' $ fromNormalizedUri uri)

823827

824828filterVersionMap

825829 :: HMap.HashMap NormalizedUri (Set.Set TextDocumentVersion)

@@ -829,11 +833,17 @@ filterVersionMap =

829833 HMap.intersectionWith $ \versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep

830834

831835updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()

832−updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do

836+updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = do

833837 modifyVar_ positionMapping $ \allMappings -> do

834838 let uri = toNormalizedUri _uri

835839 let mappingForUri = HMap.lookupDefault Map.empty uri allMappings

836− let updatedMapping =

837− Map.insert _version idMapping $

838− Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri

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)

839847 pure $! HMap.insert uri updatedMapping allMappings

848+ where

849+ shared_change = mkDelta changes

src/Development/IDE/GHC/CPP.hs+22−1

@@ -19,7 +19,8 @@

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

@@ -162,6 +167,22 @@ getBackendDefs dflags | hscTarget dflags == HscLlvm = do

162167getBackendDefs _ =

163168 return []

164169

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+

165186-- ---------------------------------------------------------------------------

166187-- Macros (cribbed from Cabal)

167188

src/Development/IDE/GHC/Compat.hs+177−17

@@ -7,24 +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,

2638 GHC.ModLocation,

39+ Module.addBootSuffix,

2740 pattern ModLocation,

41+ getConArgs,

2842

2943 module GHC

3044 ) where

@@ -32,41 +46,62 @@ module Development.IDE.GHC.Compat(

3246import StringBuffer

3347import DynFlags

3448import FieldLabel

49+import Fingerprint (Fingerprint)

50+import qualified Module

51+import Packages

3552

3653import qualified GHC

37−import GHC hiding (ClassOpSig, DerivD, ForD, IEThingWith, InstD, TyClD, ValD, ModLocation)

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

3868

3969#if MIN_GHC_API_VERSION(8,8,0)

40−import HieAst

70+import Control.Applicative ((<|>))

71+import Development.IDE.GHC.HieAst (mkHieFile)

4172import HieBin

4273import HieTypes

74+

75+supportsHieFiles :: Bool

76+supportsHieFiles = True

77+

78+hieExportNames :: HieFile -> [(SrcSpan, Name)]

79+hieExportNames = nameListFromAvails . hie_exports

80+

4381#else

82+

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

84+import BinIface

85+import Data.IORef

86+import IfaceEnv

87+#endif

88+

89+import Binary

90+import Control.Exception (catch)

91+import Data.ByteString (ByteString)

4492import GhcPlugins hiding (ModLocation)

4593import NameCache

46−import Avail

4794import TcRnTypes

4895import System.IO

4996import Foreign.ForeignPtr

97+import MkIface

5098

5199

52−#if !MIN_GHC_API_VERSION(8,8,0)

53100hPutStringBuffer :: Handle -> StringBuffer -> IO ()

54101hPutStringBuffer hdl (StringBuffer buf len cur)

55102 = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->

56103 hPutBuf hdl ptr len

57−#endif

58−

59−mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile

60−mkHieFile _ _ _ = return (HieFile () [])

61104

62−writeHieFile :: FilePath -> HieFile -> IO ()

63−writeHieFile _ _ = return ()

64−

65−readHieFile :: NameCache -> FilePath -> IO (HieFileResult, ())

66−readHieFile _ _ = return (HieFileResult (HieFile () []), ())

67−

68−data HieFile = HieFile {hie_module :: (), hie_exports :: [AvailInfo]}

69−data HieFileResult = HieFileResult { hie_file_result :: HieFile }

70105#endif

71106

72107#if !MIN_GHC_API_VERSION(8,6,0)

@@ -147,3 +182,128 @@ pattern ModLocation a b c <-

147182#else

148183 GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c

149184#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+91−20

@@ -4,34 +4,41 @@

44-- | General utility functions, mostly focused around GHC operations.

55module Development.IDE.GHC.Util(

66 -- * HcsEnv and environment

7− HscEnvEq, hscEnv, newHscEnvEq,

7+ HscEnvEq(GhcVersionMismatch, compileTime, runTime), hscEnv, newHscEnvEq,

88 modifyDynFlags,

9+ evalGhcEnv,

910 runGhcEnv,

11+ deps,

1012 -- * GHC wrappers

1113 prettyPrint,

14+ printRdrName,

15+ printName,

1216 ParseResult(..), runParser,

1317 lookupPackageConfig,

18+ textToStringBuffer,

19+ stringBufferToByteString,

1420 moduleImportPath,

1521 cgGutsToCoreModule,

1622 fingerprintToBS,

1723 fingerprintFromStringBuffer,

1824 -- * General utilities

19− textToStringBuffer,

2025 readFileUtf8,

2126 hDuplicateTo',

27+ setDefaultHieDir,

28+ dontWriteHieFiles

2229 ) where

2330

2431import Control.Concurrent

2532import Data.List.Extra

33+import Data.ByteString.Internal (ByteString(..))

2634import Data.Maybe

2735import Data.Typeable

2836import qualified Data.ByteString.Internal as BS

2937import Fingerprint

30−import GHC

3138import GhcMonad

32−import GhcPlugins hiding (Unique)

33−import Data.IORef

3439import Control.Exception

40+import Data.IORef

41+import Data.Version (showVersion, Version)

3542import FileCleanup

3643import Foreign.Ptr

3744import Foreign.ForeignPtr

@@ -51,7 +58,18 @@ import qualified Data.ByteString as BS

5158import Lexer

5259import StringBuffer

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

5471

72+import Development.IDE.GHC.Compat as GHC

5573import Development.IDE.Types.Location

5674

5775

@@ -92,62 +110,115 @@ runParser flags str parser = unP parser parseState

92110 buffer = stringToStringBuffer str

93111 parseState = mkPState flags buffer location

94112

113+stringBufferToByteString :: StringBuffer -> ByteString

114+stringBufferToByteString StringBuffer{..} = PS buf cur len

115+

95116-- | Pretty print a GHC value using 'unsafeGlobalDynFlags '.

96117prettyPrint :: Outputable a => a -> String

97118prettyPrint = showSDoc unsafeGlobalDynFlags . ppr

98119

120+-- | Pretty print a 'RdrName' wrapping operators in parens

121+printRdrName :: RdrName -> String

122+printRdrName name = showSDocUnsafe $ parenSymOcc rn (ppr rn)

123+ where

124+ rn = rdrNameOcc name

125+

126+-- | Pretty print a 'Name' wrapping operators in parens

127+printName :: Name -> String

128+printName = printRdrName . nameRdrName

129+

99130-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required

100131-- pieces, but designed to be more efficient than a standard 'runGhc'.

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

102138runGhcEnv env act = do

103139 filesToClean <- newIORef emptyFilesToClean

104140 dirsToClean <- newIORef mempty

105141 let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True}

106142 ref <- newIORef env{hsc_dflags=dflags}

107− unGhc act (Session ref) `finally` do

143+ res <- unGhc act (Session ref) `finally` do

108144 cleanTempFiles dflags

109145 cleanTempDirs dflags

146+ (,res) <$> readIORef ref

110147

111148-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.

112149-- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory

113150-- @\/usr\/Test@ should be on the include path to find sibling modules.

114−moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath

151+moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath

115152-- The call to takeDirectory is required since DAML does not require that

116153-- the file name matches the module name in the last component.

117154-- Once that has changed we can get rid of this.

118−moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm

155+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn

119156 -- This happens for single-component modules since takeDirectory "A" == "."

120157 | modDir == "." = Just pathDir

121158 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir

122159 where

123− ms = GHC.pm_mod_summary pm

124− mod' = GHC.ms_mod ms

125160 -- A for module A.B

126161 modDir =

127162 takeDirectory $

128− fromNormalizedFilePath $ toNormalizedFilePath $

129− moduleNameSlashes $ GHC.moduleName mod'

163+ fromNormalizedFilePath $ toNormalizedFilePath' $

164+ moduleNameSlashes mn

130165

131166-- | An 'HscEnv' with equality. Two values are considered equal

132167-- if they are created with the same call to 'newHscEnvEq'.

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

134176

135177-- | Unwrap an 'HsEnvEq'.

136178hscEnv :: HscEnvEq -> HscEnv

137−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{} = []

138195

139196-- | Wrap an 'HscEnv' into an 'HscEnvEq'.

140−newHscEnvEq :: HscEnv -> IO HscEnvEq

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

142199

143200instance Show HscEnvEq where

144− show (HscEnvEq a _) = "HscEnvEq " ++ show (hashUnique a)

201+ show (HscEnvEq a _ _) = "HscEnvEq " ++ show (hashUnique a)

202+ show GhcVersionMismatch{..} = "GhcVersionMismatch " <> show (compileTime, runTime)

145203

146204instance Eq HscEnvEq where

147− HscEnvEq a _ == HscEnvEq b _ = a == b

205+ HscEnvEq a _ _ == HscEnvEq b _ _ = a == b

206+ GhcVersionMismatch a b == GhcVersionMismatch c d = a == c && b == d

207+ _ == _ = False

148208

149209instance NFData HscEnvEq where

150− rnf (HscEnvEq a b) = rnf (hashUnique a) `seq` b `seq` ()

210+ rnf (HscEnvEq a b c) = rnf (hashUnique a) `seq` b `seq` c `seq` ()

211+ rnf GhcVersionMismatch{} = rnf runTime

212+

213+instance Hashable HscEnvEq where

214+ hashWithSalt s (HscEnvEq a _b _c) = hashWithSalt s a

215+ hashWithSalt salt GhcVersionMismatch{..} = hashWithSalt salt (compileTime, runTime)

216+

217+-- Fake instance needed to persuade Shake to accept this type as a key.

218+-- No harm done as ghcide never persists these keys currently

219+instance Binary HscEnvEq where

220+ put _ = error "not really"

221+ get = error "not really"

151222

152223-- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error.

153224readFileUtf8 :: FilePath -> IO T.Text

src/Development/IDE/GHC/WithDynFlags.hsnew file+30

@@ -0,0 +1,30 @@

1+module Development.IDE.GHC.WithDynFlags

2+( WithDynFlags

3+, evalWithDynFlags

4+) where

6+import Control.Monad.Trans.Reader (ask, ReaderT(..))

7+import GHC (DynFlags)

8+import Control.Monad.IO.Class (MonadIO)

9+import Exception (ExceptionMonad(..))

10+import Control.Monad.Trans.Class (MonadTrans(..))

11+import GhcPlugins (HasDynFlags(..))

12+

13+-- | A monad transformer implementing the 'HasDynFlags' effect

14+newtype WithDynFlags m a = WithDynFlags {withDynFlags :: ReaderT DynFlags m a}

15+ deriving (Applicative, Functor, Monad, MonadIO, MonadTrans)

16+

17+evalWithDynFlags :: DynFlags -> WithDynFlags m a -> m a

18+evalWithDynFlags dflags = flip runReaderT dflags . withDynFlags

19+

20+instance Monad m => HasDynFlags (WithDynFlags m) where

21+ getDynFlags = WithDynFlags ask

22+

23+instance ExceptionMonad m => ExceptionMonad (WithDynFlags m) where

24+ gmask f = WithDynFlags $ ReaderT $ \env ->

25+ gmask $ \restore ->

26+ let restore' = lift . restore . flip runReaderT env . withDynFlags

27+ in runReaderT (withDynFlags $ f restore') env

28+

29+ gcatch (WithDynFlags act) handle = WithDynFlags $ ReaderT $ \env ->

30+ gcatch (runReaderT act env) (flip runReaderT env . withDynFlags . handle)

src/Development/IDE/Import/DependencyInformation.hs+60−31

@@ -14,19 +14,23 @@ module Development.IDE.Import.DependencyInformation

1414 , PathIdMap

1515 , emptyPathIdMap

1616 , getPathId

17+ , lookupPathToId

1718 , insertImport

1819 , pathToId

1920 , idToPath

2021 , reachableModules

21− , modLocationToNormalizedFilePath

2222 , processDependencyInformation

2323 , transitiveDeps

24+

25+ , BootIdMap

26+ , insertBootId

2427 ) where

2528

2629import Control.DeepSeq

2730import Data.Bifunctor

2831import Data.Coerce

2932import Data.List

33+import Data.Tuple.Extra hiding (first, second)

3034import Development.IDE.GHC.Orphans()

3135import Data.Either

3236import Data.Graph

@@ -42,7 +46,6 @@ import qualified Data.IntSet as IntSet

4246import Data.Maybe

4347import Data.Set (Set)

4448import qualified Data.Set as Set

45−import Data.Tuple.Extra (fst3)

4649import GHC.Generics (Generic)

4750

4851import Development.IDE.Types.Diagnostics

@@ -59,36 +62,34 @@ data ModuleImports = ModuleImports

5962 -- that module on disk (if we found it)

6063 , packageImports :: !(Set InstalledUnitId)

6164 -- ^ Transitive package dependencies unioned for all imports.

62− }

65+ } deriving Show

6366

64−-- | For processing dependency information, we need lots of maps and sets

65−-- of filepaths. Comparing Strings is really slow, so we work with IntMap/IntSet

66−-- instead and only convert at the edges

67−-- 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.

6870newtype FilePathId = FilePathId { getFilePathId :: Int }

6971 deriving (Show, NFData, Eq, Ord)

7072

73+-- | Map from 'FilePathId'

74+type FilePathIdMap = IntMap

75+

76+-- | Set of 'FilePathId's

77+type FilePathIdSet = IntSet

78+

7179data PathIdMap = PathIdMap

72− { idToPathMap :: !(IntMap ArtifactsLocation)

80+ { idToPathMap :: !(FilePathIdMap ArtifactsLocation)

7381 , pathToIdMap :: !(HashMap NormalizedFilePath FilePathId)

7482 }

7583 deriving (Show, Generic)

7684

7785instance NFData PathIdMap

7886

79−modLocationToNormalizedFilePath :: ArtifactsLocation -> NormalizedFilePath

80−modLocationToNormalizedFilePath (ArtifactsLocation loc) =

81− case ml_hs_file loc of

82− Just filePath -> toNormalizedFilePath filePath

83− -- Since we craete all 'ModLocation' values via 'mkHomeModLocation'

84− Nothing -> error "Has something changed in mkHomeModLocation?"

85−

8687emptyPathIdMap :: PathIdMap

8788emptyPathIdMap = PathIdMap IntMap.empty HMS.empty

8889

8990getPathId :: ArtifactsLocation -> PathIdMap -> (FilePathId, PathIdMap)

9091getPathId path m@PathIdMap{..} =

91− case HMS.lookup (modLocationToNormalizedFilePath path) pathToIdMap of

92+ case HMS.lookup (artifactFilePath path) pathToIdMap of

9293 Nothing ->

9394 let !newId = FilePathId $ HMS.size pathToIdMap

9495 in (newId, insertPathId path newId m)

@@ -96,7 +97,7 @@ getPathId path m@PathIdMap{..} =

9697

9798insertPathId :: ArtifactsLocation -> FilePathId -> PathIdMap -> PathIdMap

9899insertPathId path id PathIdMap{..} =

99− PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert (modLocationToNormalizedFilePath path) id pathToIdMap)

100+ PathIdMap (IntMap.insert (getFilePathId id) path idToPathMap) (HMS.insert (artifactFilePath path) id pathToIdMap)

100101

101102insertImport :: FilePathId -> Either ModuleParseError ModuleImports -> RawDependencyInformation -> RawDependencyInformation

102103insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.insert k v (rawImports rawDepInfo) }

@@ -104,34 +105,49 @@ insertImport (FilePathId k) v rawDepInfo = rawDepInfo { rawImports = IntMap.inse

104105pathToId :: PathIdMap -> NormalizedFilePath -> FilePathId

105106pathToId PathIdMap{pathToIdMap} path = pathToIdMap HMS.! path

106107

108+lookupPathToId :: PathIdMap -> NormalizedFilePath -> Maybe FilePathId

109+lookupPathToId PathIdMap{pathToIdMap} path = HMS.lookup path pathToIdMap

110+

107111idToPath :: PathIdMap -> FilePathId -> NormalizedFilePath

108−idToPath pathIdMap filePathId = modLocationToNormalizedFilePath $ idToModLocation pathIdMap filePathId

112+idToPath pathIdMap filePathId = artifactFilePath $ idToModLocation pathIdMap filePathId

109113

110114idToModLocation :: PathIdMap -> FilePathId -> ArtifactsLocation

111115idToModLocation PathIdMap{idToPathMap} (FilePathId id) = idToPathMap IntMap.! id

112116

117+type BootIdMap = FilePathIdMap FilePathId

118+

119+insertBootId :: FilePathId -> FilePathId -> BootIdMap -> BootIdMap

120+insertBootId k = IntMap.insert (getFilePathId k)

113121

114122-- | Unprocessed results that we find by following imports recursively.

115123data RawDependencyInformation = RawDependencyInformation

116− { rawImports :: !(IntMap (Either ModuleParseError ModuleImports))

124+ { rawImports :: !(FilePathIdMap (Either ModuleParseError ModuleImports))

117125 , rawPathIdMap :: !PathIdMap

118− }

119−

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

121134pkgDependencies RawDependencyInformation{..} =

122135 IntMap.map (either (const Set.empty) packageImports) rawImports

123136

124137data DependencyInformation =

125138 DependencyInformation

126− { depErrorNodes :: !(IntMap (NonEmpty NodeError))

139+ { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError))

127140 -- ^ Nodes that cannot be processed correctly.

128− , depModuleNames :: !(IntMap ShowableModuleName)

129− , depModuleDeps :: !(IntMap IntSet)

141+ , depModuleNames :: !(FilePathIdMap ShowableModuleName)

142+ , depModuleDeps :: !(FilePathIdMap FilePathIdSet)

130143 -- ^ For a non-error node, this contains the set of module immediate dependencies

131144 -- in the same package.

132− , depPkgDeps :: !(IntMap (Set InstalledUnitId))

145+ , depPkgDeps :: !(FilePathIdMap (Set InstalledUnitId))

133146 -- ^ For a non-error node, this contains the set of immediate pkg deps.

134147 , depPathIdMap :: !PathIdMap

148+ -- ^ Map from FilePath to FilePathId

149+ , depBootMap :: !BootIdMap

150+ -- ^ Map from hs-boot file to the corresponding hs file

135151 } deriving (Show, Generic)

136152

137153newtype ShowableModuleName =

@@ -209,6 +225,7 @@ processDependencyInformation rawDepInfo@RawDependencyInformation{..} =

209225 , depModuleNames = IntMap.fromList $ coerce moduleNames

210226 , depPkgDeps = pkgDependencies rawDepInfo

211227 , depPathIdMap = rawPathIdMap

228+ , depBootMap = rawBootMap

212229 }

213230 where resultGraph = buildResultGraph rawImports

214231 (errorNodes, successNodes) = partitionNodeResults $ IntMap.toList resultGraph

@@ -230,7 +247,7 @@ processDependencyInformation rawDepInfo@RawDependencyInformation{..} =

230247-- 2. Mark each node that has a parse error as an error node.

231248-- 3. Mark each node whose immediate children could not be located as an error.

232249-- 4. Recursively propagate errors to parents if they are not already error nodes.

233−buildResultGraph :: IntMap (Either ModuleParseError ModuleImports) -> IntMap NodeResult

250+buildResultGraph :: FilePathIdMap (Either ModuleParseError ModuleImports) -> FilePathIdMap NodeResult

234251buildResultGraph g = propagatedErrors

235252 where

236253 sccs = stronglyConnComp (graphEdges g)

@@ -277,7 +294,7 @@ buildResultGraph g = propagatedErrors

277294 Right ModuleImports{moduleImports} ->

278295 fmap fst $ find (\(_, resolvedImp) -> resolvedImp == Just importedFile) moduleImports

279296

280−graphEdges :: IntMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]

297+graphEdges :: FilePathIdMap (Either ModuleParseError ModuleImports) -> [(FilePathId, FilePathId, [FilePathId])]

281298graphEdges g =

282299 map (\(k, v) -> (FilePathId k, FilePathId k, deps v)) $ IntMap.toList g

283300 where deps :: Either e ModuleImports -> [FilePathId]

@@ -289,10 +306,12 @@ partitionSCC (CyclicSCC xs:rest) = second (xs:) $ partitionSCC rest

289306partitionSCC (AcyclicSCC x:rest) = first (x:) $ partitionSCC rest

290307partitionSCC [] = ([], [])

291308

309+

292310transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies

293311transitiveDeps DependencyInformation{..} file = do

294312 let !fileId = pathToId depPathIdMap file

295313 reachableVs <-

314+ -- Delete the starting node

296315 IntSet.delete (getFilePathId fileId) .

297316 IntSet.fromList . map (fst3 . fromVertex) .

298317 reachable g <$> toVertex (getFilePathId fileId)

@@ -305,17 +324,27 @@ transitiveDeps DependencyInformation{..} file = do

305324 let transitiveModuleDeps =

306325 map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds

307326 let transitiveNamedModuleDeps =

308− [ NamedModuleDep (idToPath depPathIdMap (FilePathId fid)) mn ml

327+ [ NamedModuleDep (idToPath depPathIdMap (FilePathId fid)) mn artifactModLocation

309328 | (fid, ShowableModuleName mn) <- IntMap.toList depModuleNames

310− , let ArtifactsLocation ml = idToPathMap depPathIdMap IntMap.! fid

329+ , let ArtifactsLocation{artifactModLocation} = idToPathMap depPathIdMap IntMap.! fid

311330 ]

312331 pure TransitiveDependencies {..}

313332 where

314− (g, fromVertex, toVertex) = graphFromEdges (map (\(f, fs) -> (f, f, IntSet.toList fs)) $ IntMap.toList depModuleDeps)

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+

315342 vs = topSort g

316343

317344data TransitiveDependencies = TransitiveDependencies

318345 { transitiveModuleDeps :: [NormalizedFilePath]

346+ -- ^ Transitive module dependencies in topological order.

347+ -- The module itself is not included.

319348 , transitiveNamedModuleDeps :: [NamedModuleDep]

320349 -- ^ Transitive module dependencies in topological order.

321350 -- The module itself is not included.

src/Development/IDE/Import/FindImports.hs+52−18

@@ -8,16 +8,18 @@ module Development.IDE.Import.FindImports

88 ( locateModule

99 , Import(..)

1010 , ArtifactsLocation(..)

11+ , modSummaryToArtifactsLocation

12+ , isBootLocation

13+ , mkImportDirs

1114 ) where

1215

1316import Development.IDE.GHC.Error as ErrUtils

1417import Development.IDE.GHC.Orphans()

1518import Development.IDE.Types.Diagnostics

1619import Development.IDE.Types.Location

20+import Development.IDE.GHC.Compat

1721-- GHC imports

18−import DynFlags

1922import FastString

20−import GHC

2123import qualified Module as M

2224import Packages

2325import Outputable (showSDoc, ppr, pprPanic)

@@ -28,74 +30,106 @@ import Control.DeepSeq

2830import Control.Monad.Extra

2931import Control.Monad.IO.Class

3032import System.FilePath

33+import DriverPhases

34+import Data.Maybe

3135

3236data Import

3337 = FileImport !ArtifactsLocation

3438 | PackageImport !M.InstalledUnitId

3539 deriving (Show)

3640

37−newtype ArtifactsLocation = ArtifactsLocation ModLocation

41+data ArtifactsLocation = ArtifactsLocation

42+ { artifactFilePath :: !NormalizedFilePath

43+ , artifactModLocation :: !ModLocation

44+ , artifactIsSource :: !Bool -- ^ True if a module is a source input

45+ }

3846 deriving (Show)

3947

4048instance NFData ArtifactsLocation where

41− rnf = const ()

49+ rnf ArtifactsLocation{..} = rnf artifactFilePath `seq` rwhnf artifactModLocation `seq` rnf artifactIsSource

50+

51+isBootLocation :: ArtifactsLocation -> Bool

52+isBootLocation = not . artifactIsSource

4253

4354instance NFData Import where

4455 rnf (FileImport x) = rnf x

4556 rnf (PackageImport x) = rnf x

4657

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+

4764

4865-- | locate a module in the file system. Where we go from *daml to Haskell

4966locateModuleFile :: MonadIO m

50− => DynFlags

67+ => [[FilePath]]

5168 -> [String]

5269 -> (NormalizedFilePath -> m Bool)

5370 -> Bool

5471 -> ModuleName

5572 -> m (Maybe NormalizedFilePath)

56−locateModuleFile dflags exts doesExist isSource modName = do

57− let candidates =

58− [ toNormalizedFilePath (prefix </> M.moduleNameSlashes modName <.> maybeBoot ext)

59− | prefix <- importPaths dflags, ext <- exts]

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

6178 where

6279 maybeBoot ext

6380 | isSource = ext ++ "-boot"

6481 | otherwise = ext

6582

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+

6690-- | locate a module in either the file system or the package database. Where we go from *daml to

6791-- Haskell

6892locateModule

6993 :: MonadIO m

7094 => DynFlags

95+ -> [(M.InstalledUnitId, DynFlags)] -- Sets import directories to look in

7196 -> [String]

7297 -> (NormalizedFilePath -> m Bool)

7398 -> Located ModuleName

7499 -> Maybe FastString

75100 -> Bool

76101 -> m (Either [FileDiagnostic] Import)

77−locateModule dflags exts doesExist modName mbPkgName isSource = do

102+locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do

78103 case mbPkgName of

79104 -- "this" means that we should only look in the current package

80105 Just "this" -> do

81− mbFile <- locateModuleFile dflags exts doesExist isSource $ unLoc modName

82− case mbFile of

83− Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound []

84− Just file -> toModLocation file

106+ lookupLocal [importPaths dflags]

85107 -- if a package name is given we only go look for a package

86− Just _pkgName -> lookupInPackageDB dflags

108+ Just pkgName

109+ | Just dirs <- lookup (PackageName pkgName) import_paths

110+ -> lookupLocal [dirs]

111+ | otherwise -> lookupInPackageDB dflags

87112 Nothing -> do

88113 -- first try to find the module as a file. If we can't find it try to find it in the package

89114 -- database.

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

91119 case mbFile of

92120 Nothing -> lookupInPackageDB dflags

93121 Just file -> toModLocation file

94122 where

123+ import_paths = mapMaybe (mkImportDirs dflags) comp_info

95124 toModLocation file = liftIO $ do

96125 loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)

97− return $ Right $ FileImport $ ArtifactsLocation loc

126+ return $ Right $ FileImport $ ArtifactsLocation file loc (not isSource)

98127

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

99133

100134 lookupInPackageDB dfs =

101135 case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of

src/Development/IDE/LSP/HoverDefinition.hs+4−1

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

@@ -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+11−13

@@ -144,15 +144,15 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

144144 Response x@RequestMessage{_id, _params} wrap act ->

145145 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

146146 \case

147− Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing (Just e)

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

149149 ResponseAndRequest x@RequestMessage{_id, _params} wrap wrapNewReq act ->

150150 checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $

151151 \(res, newReq) -> do

152− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing

153− case newReq of

154− Nothing -> return ()

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

156156 reqId <- getNextReqId

157157 sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams

158158 InitialParams x@RequestMessage{_id, _params} act -> do

@@ -175,16 +175,16 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat

175175 Left () -> do

176176 logDebug (ideLogger ide) $ T.pack $

177177 "Cancelled request " <> show _id

178− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $

179− Just $ ResponseError RequestCancelled "" Nothing

178+ sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left

179+ $ ResponseError RequestCancelled "" Nothing

180180 Right res -> k res

181181 ) $ \(e :: SomeException) -> do

182182 logError (ideLogger ide) $ T.pack $

183183 "Unexpected exception on request, please report!\n" ++

184184 "Message: " ++ show msg ++ "\n" ++

185185 "Exception: " ++ show e

186− sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $

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

188188

189189initializeRequestHandler :: PartialHandlers config

190190initializeRequestHandler = PartialHandlers $ \WithMessage{..} x -> return x{

@@ -222,15 +222,13 @@ data Message c

222222 -- | Used for cases in which we need to send not only a response,

223223 -- but also an additional request to the client.

224224 -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.

225− | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams)))

225+ | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))

226226 | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())

227227 -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler.

228228 | InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())

229229

230230modifyOptions :: LSP.Options -> LSP.Options

231231modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS

232− , LSP.executeCommandCommands = Just ["typesignature.add"]

233− , LSP.completionTriggerCharacters = Just "."

234232 }

235233 where

236234 tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}

src/Development/IDE/LSP/Notifications.hs+2−2

@@ -30,7 +30,7 @@ import Development.IDE.Core.OfInterest

3030

3131

3232whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()

33−whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath

33+whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath'

3434

3535setHandlersNotifications :: PartialHandlers c

3636setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x

@@ -62,7 +62,7 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x

6262 let events =

6363 mapMaybe

6464 (\(FileEvent uri ev) ->

65− (, ev /= FcDeleted) . toNormalizedFilePath

65+ (, ev /= FcDeleted) . toNormalizedFilePath'

6666 <$> LSP.uriToFilePath uri

6767 )

6868 ( F.toList fileEvents )

src/Development/IDE/LSP/Outline.hs+41−6

@@ -4,6 +4,8 @@

55module Development.IDE.LSP.Outline

66 ( setHandlersOutline

7+ -- * For haskell-language-server

8+ , moduleOutline

79 )

810where

911

@@ -37,11 +39,11 @@ moduleOutline

3739 :: 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,6 +183,25 @@ 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)

src/Development/IDE/LSP/Server.hs+1−1

@@ -29,7 +29,7 @@ data WithMessage c = WithMessage

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 c -> IdeState -> req -> IO (resp, Maybe (rm, newReqParams))) -> -- actual work

32+ (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work

3333 Maybe (LSP.Handler (RequestMessage m req resp))

3434 , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())

3535 -> Maybe (LSP.Handler InitializeRequest)

src/Development/IDE/Plugin.hs+28−2

@@ -1,11 +1,13 @@

2−module Development.IDE.Plugin(Plugin(..), codeActionPlugin) where

2+module Development.IDE.Plugin(Plugin(..), codeActionPlugin, codeActionPluginWithRules,makeLspCommandId,getPid) where

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

@@ -27,8 +29,32 @@ instance Monoid (Plugin c) where

2729

2830

2931codeActionPlugin :: (LSP.LspFuncs c -> IdeState -> TextDocumentIdentifier -> Range -> CodeActionContext -> IO (Either ResponseError [CAResult])) -> Plugin c

30−codeActionPlugin f = Plugin mempty $ PartialHandlers $ \WithMessage{..} x -> return x{

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+136−82

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

@@ -19,8 +28,12 @@ import Development.IDE.Core.Shake

1928import Development.IDE.GHC.Error

2029import Development.IDE.GHC.Util

2130import 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

2234import Development.IDE.Types.Location

2335import Development.IDE.Types.Options

36+import Development.Shake (Rules)

2437import qualified Data.HashMap.Strict as Map

2538import qualified Language.Haskell.LSP.Core as LSP

2639import Language.Haskell.LSP.VFS

@@ -34,17 +47,18 @@ import Data.List.Extra

3447import qualified Data.Text as T

3548import Data.Tuple.Extra ((&&&))

3649import HscTypes

37−import OccName

3850import Parser

39−import RdrName

4051import Text.Regex.TDFA ((=~), (=~~))

4152import Text.Regex.TDFA.Text()

42−import Outputable (showSDoc, ppr, showSDocUnsafe)

53+import Outputable (ppr, showSDocUnsafe)

4354import DynFlags (xFlags, FlagSpec(..))

4455import GHC.LanguageExtensions.Type (Extension)

4556

4657plugin :: Plugin c

47−plugin = codeActionPlugin codeAction <> Plugin mempty setHandlersCodeLens

58+plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens

59+

60+rules :: Rules ()

61+rules = rulePackageExports

4862

4963-- | Generate code actions.

5064codeAction

@@ -59,15 +73,16 @@ codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diag

5973 -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg

6074 contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri

6175 let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents

62− mbFile = toNormalizedFilePath <$> uriToFilePath uri

63− (ideOptions, parsedModule, env) <- runAction state $

76+ mbFile = toNormalizedFilePath' <$> uriToFilePath uri

77+ (ideOptions, parsedModule, join -> env) <- runAction state $

6478 (,,) <$> getIdeOptions

65− <*> getParsedModule `traverse` mbFile

66− <*> use_ GhcSession `traverse` mbFile

79+ <*> getParsedModule `traverse` mbFile

80+ <*> use GhcSession `traverse` mbFile

81+ pkgExports <- runAction state $ (useNoFile_ . PackageExports) `traverse` env

6782 let dflags = hsc_dflags . hscEnv <$> env

6883 pure $ Right

6984 [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing

70− | x <- xs, (title, tedit) <- suggestAction dflags ideOptions ( join parsedModule ) text x

85+ | x <- xs, (title, tedit) <- suggestAction dflags (fromMaybe mempty pkgExports) ideOptions ( join parsedModule ) text x

7186 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing

7287 ]

7388

@@ -78,13 +93,14 @@ codeLens

7893 -> CodeLensParams

7994 -> IO (Either ResponseError (List CodeLens))

8095codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do

96+ commandId <- makeLspCommandId "typesignature.add"

8197 fmap (Right . List) $ case uriToFilePath' uri of

82− Just (toNormalizedFilePath -> filePath) -> do

98+ Just (toNormalizedFilePath' -> filePath) -> do

8399 _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath

84100 diag <- getDiagnostics ideState

85101 hDiag <- getHiddenDiagnostics ideState

86102 pure

87− [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing

103+ [ CodeLens _range (Just (Command title commandId (Just $ List [toJSON edit]))) Nothing

88104 | (dFile, _, dDiag@Diagnostic{_range=_range}) <- diag ++ hDiag

89105 , dFile == filePath

90106 , (title, tedit) <- suggestSignature False dDiag

@@ -97,17 +113,28 @@ executeAddSignatureCommand

97113 :: LSP.LspFuncs c

98114 -> IdeState

99115 -> ExecuteCommandParams

100− -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

116+ -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))

101117executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..}

102− | _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

103123 , Just (List [edit]) <- _arguments

104124 , Success wedit <- fromJSON edit

105− = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))

125+ = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))

106126 | otherwise

107− = return (Null, Nothing)

108−

109−suggestAction :: Maybe DynFlags -> IdeOptions -> Maybe ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])]

110−suggestAction dflags 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

111138 [ suggestAddExtension diag

112139 , suggestExtendImport dflags text diag

113140 , suggestFillHole diag

@@ -119,6 +146,7 @@ suggestAction dflags ideOptions parsedModule text diag = concat

119146 ] ++ concat

120147 [ suggestNewDefinition ideOptions pm text diag

121148 ++ suggestRemoveRedundantImport pm text diag

149+ ++ suggestNewImport packageExports pm diag

122150 | Just pm <- [parsedModule]]

123151

124152

@@ -130,6 +158,7 @@ suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmod

130158 , Just c <- contents

131159 , ranges <- map (rangesForBinding impDecl . T.unpack) (T.splitOn ", " bindings)

132160 , ranges' <- extendAllToIncludeCommaIfPossible (indexedByPosition $ T.unpack c) (concat ranges)

161+ , not (null ranges')

133162 = [( "Remove " <> bindings <> " from import" , [ TextEdit r "" | r <- ranges' ] )]

134163

135164-- File.hs:16:1: warning:

@@ -288,9 +317,8 @@ suggestExtendImport (Just dflags) contents Diagnostic{_range=_range,..}

288317 in x{_end = (_end x){_character = succ (_character (_end x))}}

289318 _ -> error "bug in srcspan parser"

290319 importLine = textInRange range c

291− printedName = let rn = rdrNameOcc name in showSDoc dflags $ parenSymOcc rn (ppr rn)

292320 in [("Add " <> binding <> " to the import list of " <> mod

293− , [TextEdit range (addBindingToImportList (T.pack printedName) importLine)])]

321+ , [TextEdit range (addBindingToImportList (T.pack $ printRdrName name) importLine)])]

294322 | otherwise = []

295323suggestExtendImport Nothing _ _ = []

296324

@@ -310,29 +338,103 @@ suggestFixConstructorImport _ Diagnostic{_range=_range,..}

310338

311339suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]

312340suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}

313− | "Top-level binding with no type signature" `T.isInfixOf` _message = let

314− signature = T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message

315− startOfLine = Position (_line _start) 0

316− beforeLine = Range startOfLine startOfLine

317− title = if isQuickFix then "add signature: " <> signature else signature

318− action = TextEdit beforeLine $ signature <> "\n"

319− in [(title, [action])]

320−suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}

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

322343 signature = removeInitialForAll

323344 $ T.takeWhile (\x -> x/='*' && x/='•')

324345 $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message

325− startOfLine = Position (_line _start) (_character _start)

346+ startOfLine = Position (_line _start) startCharacter

326347 beforeLine = Range startOfLine startOfLine

327348 title = if isQuickFix then "add signature: " <> signature else signature

328− action = TextEdit beforeLine $ signature <> "\n" <> T.replicate (_character _start) " "

349+ action = TextEdit beforeLine $ signature <> "\n" <> T.replicate startCharacter " "

329350 in [(title, [action])]

330351 where removeInitialForAll :: T.Text -> T.Text

331352 removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))

332353 | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))

333354 | otherwise = nm <> ty

355+ startCharacter

356+ | "Polymorphic local binding" `T.isPrefixOf` _message

357+ = _character _start

358+ | otherwise

359+ = 0

360+

334361suggestSignature _ _ = []

335362

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+

336438topOfHoleFitsMarker :: T.Text

337439topOfHoleFitsMarker =

338440#if MIN_GHC_API_VERSION(8,6,0)

@@ -343,7 +445,7 @@ topOfHoleFitsMarker =

343445

344446mkRenameEdit :: Maybe T.Text -> Range -> T.Text -> TextEdit

345447mkRenameEdit contents range name =

346− if fromMaybe False maybeIsInfixFunction

448+ if maybeIsInfixFunction == Just True

347449 then TextEdit range ("`" <> name <> "`")

348450 else TextEdit range name

349451 where

@@ -425,7 +527,7 @@ rangesForBinding _ _ = []

425527rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]

426528rangesForBinding' b (L l x@IEVar{}) | showSDocUnsafe (ppr x) == b = [l]

427529rangesForBinding' b (L l x@IEThingAbs{}) | showSDocUnsafe (ppr x) == b = [l]

428−rangesForBinding' b (L l x@IEThingAll{}) | showSDocUnsafe (ppr x) == b = [l]

530+rangesForBinding' b (L l (IEThingAll x)) | showSDocUnsafe (ppr x) == b = [l]

429531rangesForBinding' b (L l (IEThingWith thing _ inners labels))

430532 | showSDocUnsafe (ppr thing) == b = [l]

431533 | otherwise =

@@ -466,51 +568,3 @@ filterNewlines = T.concat . T.lines

466568

467569unifySpaces :: T.Text -> T.Text

468570unifySpaces = T.unwords . T.words

469−

470−--------------------------------------------------------------------------------

471−

472−type PositionIndexedString = [(Position, Char)]

473−

474−indexedByPosition :: String -> PositionIndexedString

475−indexedByPosition = unfoldr f . (Position 0 0,) where

476− f (_, []) = Nothing

477− f (p@(Position l _), '\n' : rest) = Just ((p,'\n'), (Position (l+1) 0, rest))

478− f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c+1), rest))

479−

480−-- | Returns a tuple (before, contents, after)

481−unconsRange :: Range -> PositionIndexedString -> (PositionIndexedString, PositionIndexedString, PositionIndexedString)

482−unconsRange Range {..} indexedString = (before, mid, after)

483− where

484− (before, rest) = span ((/= _start) . fst) indexedString

485− (mid, after) = span ((/= _end) . fst) rest

486−

487−stripRange :: Range -> PositionIndexedString -> PositionIndexedString

488−stripRange r s = case unconsRange r s of

489− (b, _, a) -> b ++ a

490−

491−extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]

492−extendAllToIncludeCommaIfPossible _ [] = []

493−extendAllToIncludeCommaIfPossible indexedString (r : rr) = r' : extendAllToIncludeCommaIfPossible indexedString' rr

494− where

495− r' = case extendToIncludeCommaIfPossible indexedString r of

496− [] -> r

497− r' : _ -> r'

498− indexedString' = stripRange r' indexedString

499−

500−-- | Returns a sorted list of ranges with extended selections includindg preceding or trailing commas

501−extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]

502−extendToIncludeCommaIfPossible indexedString range =

503− -- a, |b|, c ===> a|, b|, c

504− [ range{_start = start'}

505− | (start', ',') : _ <- [before']

506− ]

507− ++

508− -- a, |b|, c ===> a, |b, |c

509− [ range{_end = end'}

510− | (_, ',') : rest <- [after']

511− , let (end', _) : _ = dropWhile (isSpace . snd) rest

512− ]

513− where

514− (before, _, after) = unconsRange range indexedString

515− after' = dropWhile (isSpace . snd) after

516− before' = dropWhile (isSpace . snd) (reverse before)

src/Development/IDE/Plugin/CodeAction/PositionIndexed.hsnew file+112

@@ -0,0 +1,112 @@

1+-- | Position indexed streams of characters

2+module Development.IDE.Plugin.CodeAction.PositionIndexed

3+ ( PositionIndexed

4+ , PositionIndexedString

5+ , indexedByPosition

6+ , indexedByPositionStartingFrom

7+ , extendAllToIncludeCommaIfPossible

8+ , mergeRanges

9+ )

10+where

11+

12+import Data.Char

13+import Data.List

14+import Language.Haskell.LSP.Types

15+

16+type PositionIndexed a = [(Position, a)]

17+

18+type PositionIndexedString = PositionIndexed Char

19+

20+-- | Add position indexing to a String.

21+--

22+-- > indexedByPositionStartingFrom (0,0) "hey\n ho" ≡

23+-- > [ ((0,0),'h')

24+-- > , ((0,1),'e')

25+-- > , ((0,2),'y')

26+-- > , ((0,3),'\n')

27+-- > , ((1,0),' ')

28+-- > , ((1,1),'h')

29+-- > , ((1,2),'o')

30+-- > ]

31+indexedByPositionStartingFrom :: Position -> String -> PositionIndexedString

32+indexedByPositionStartingFrom initialPos = unfoldr f . (initialPos, ) where

33+ f (_, []) = Nothing

34+ f (p@(Position l _), '\n' : rest) =

35+ Just ((p, '\n'), (Position (l + 1) 0, rest))

36+ f (p@(Position l c), x : rest) = Just ((p, x), (Position l (c + 1), rest))

37+

38+-- | Add position indexing to a String.

39+--

40+-- > indexedByPosition = indexedByPositionStartingFrom (Position 0 0)

41+indexedByPosition :: String -> PositionIndexedString

42+indexedByPosition = indexedByPositionStartingFrom (Position 0 0)

43+

44+-- | Returns a tuple (before, contents, after) if the range is present.

45+-- The range is present only if both its start and end positions are present

46+unconsRange

47+ :: Range

48+ -> PositionIndexed a

49+ -> Maybe (PositionIndexed a, PositionIndexed a, PositionIndexed a)

50+unconsRange Range {..} indexedString

51+ | (before, rest@(_ : _)) <- span ((/= _start) . fst) indexedString

52+ , (mid, after@(_ : _)) <- span ((/= _end) . fst) rest

53+ = Just (before, mid, after)

54+ | otherwise

55+ = Nothing

56+

57+-- | Strips out all the positions included in the range.

58+-- Returns 'Nothing' if the start or end of the range are not included in the input.

59+stripRange :: Range -> PositionIndexed a -> Maybe (PositionIndexed a)

60+stripRange r s = case unconsRange r s of

61+ Just (b, _, a) -> Just (b ++ a)

62+ Nothing -> Nothing

63+

64+-- | Returns the smallest possible set of disjoint ranges that is equivalent to the input.

65+-- Assumes input ranges are sorted on the start positions.

66+mergeRanges :: [Range] -> [Range]

67+mergeRanges (r : r' : rest)

68+ |

69+ -- r' is contained in r

70+ _end r > _end r' = mergeRanges (r : rest)

71+ |

72+ -- r and r' are overlapping

73+ _end r > _start r' = mergeRanges (r { _end = _end r' } : rest)

74+

75+ | otherwise = r : mergeRanges (r' : rest)

76+mergeRanges other = other

77+

78+-- | Returns a sorted list of ranges with extended selections including preceding or trailing commas

79+--

80+-- @

81+-- a, |b|, c ===> a|, b|, c

82+-- a, b, |c| ===> a, b|, c|

83+-- a, |b|, |c| ===> a|, b||, c|

84+-- @

85+extendAllToIncludeCommaIfPossible :: PositionIndexedString -> [Range] -> [Range]

86+extendAllToIncludeCommaIfPossible indexedString =

87+ mergeRanges . go indexedString . sortOn _start

88+ where

89+ go _ [] = []

90+ go input (r : rr)

91+ | r' : _ <- extendToIncludeCommaIfPossible input r

92+ , Just input' <- stripRange r' input

93+ = r' : go input' rr

94+ | otherwise

95+ = go input rr

96+

97+extendToIncludeCommaIfPossible :: PositionIndexedString -> Range -> [Range]

98+extendToIncludeCommaIfPossible indexedString range

99+ | Just (before, _, after) <- unconsRange range indexedString

100+ , after' <- dropWhile (isSpace . snd) after

101+ , before' <- dropWhile (isSpace . snd) (reverse before)

102+ =

103+ -- a, |b|, c ===> a|, b|, c

104+ [ range { _start = start' } | (start', ',') : _ <- [before'] ]

105+ ++

106+ -- a, |b|, c ===> a, |b, |c

107+ [ range { _end = end' }

108+ | (_, ',') : rest <- [after']

109+ , let (end', _) : _ = dropWhile (isSpace . snd) rest

110+ ]

111+ | otherwise

112+ = [range]

src/Development/IDE/Plugin/CodeAction/RuleTypes.hsnew file+61

@@ -0,0 +1,61 @@

1+{-# LANGUAGE TypeFamilies #-}

2+module Development.IDE.Plugin.CodeAction.RuleTypes

3+ (PackageExports(..), PackageExportsMap

4+ ,IdentInfo(..)

5+ ,mkIdentInfos

6+ ) where

8+import Avail (AvailInfo(..))

9+import Data.Hashable (Hashable)

10+import Control.DeepSeq (NFData)

11+import Data.Binary (Binary)

12+import Data.Text (pack, Text)

13+import Development.IDE.GHC.Util

14+import Development.Shake (RuleResult)

15+import Data.HashMap.Strict (HashMap)

16+import Data.Typeable (Typeable)

17+import GHC.Generics (Generic)

18+import Name

19+import FieldLabel (flSelector)

20+

21+type Identifier = Text

22+type ModuleName = Text

23+

24+data IdentInfo = IdentInfo

25+ { name :: !Identifier

26+ , rendered :: Text

27+ , parent :: !(Maybe Text)

28+ , isDatacon :: !Bool

29+ }

30+ deriving (Eq, Generic, Show)

31+

32+instance NFData IdentInfo

33+

34+mkIdentInfos :: AvailInfo -> [IdentInfo]

35+mkIdentInfos (Avail n) =

36+ [IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)]

37+mkIdentInfos (AvailTC parent (n:nn) flds)

38+ -- Following the GHC convention that parent == n if parent is exported

39+ | n == parent

40+ = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) True

41+ | n <- nn ++ map flSelector flds

42+ ] ++

43+ [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing False]

44+ where

45+ parentP = pack $ prettyPrint parent

46+

47+mkIdentInfos (AvailTC _ nn flds)

48+ = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing True

49+ | n <- nn ++ map flSelector flds

50+ ]

51+

52+-- Rule type for caching Package Exports

53+type instance RuleResult PackageExports = PackageExportsMap

54+type PackageExportsMap = HashMap Identifier [(IdentInfo,ModuleName)]

55+

56+newtype PackageExports = PackageExports HscEnvEq

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

58+

59+instance Hashable PackageExports

60+instance NFData PackageExports

61+instance Binary PackageExports

src/Development/IDE/Plugin/CodeAction/Rules.hsnew file+61

@@ -0,0 +1,61 @@

1+module Development.IDE.Plugin.CodeAction.Rules

2+ ( rulePackageExports

3+ )

4+where

6+import Data.HashMap.Strict ( fromListWith )

7+import Data.Text ( Text

8+ , pack

9+ )

10+import Data.Traversable ( forM )

11+import Development.IDE.Core.Rules

12+import Development.IDE.GHC.Util

13+import Development.IDE.Plugin.CodeAction.RuleTypes

14+import Development.Shake

15+import GHC ( DynFlags(pkgState) )

16+import HscTypes ( IfaceExport

17+ , hsc_dflags

18+ , mi_exports

19+ )

20+import LoadIface

21+import Maybes

22+import Module ( Module(..)

23+ , ModuleName

24+ , moduleNameString

25+ )

26+import Packages ( explicitPackages

27+ , exposedModules

28+ , packageConfigId

29+ )

30+import TcRnMonad ( WhereFrom(ImportByUser)

31+ , initIfaceLoad

32+ )

33+

34+rulePackageExports :: Rules ()

35+rulePackageExports = defineNoFile $ \(PackageExports session) -> do

36+ let env = hscEnv session

37+ pkgst = pkgState (hsc_dflags env)

38+ depends = explicitPackages pkgst

39+ targets =

40+ [ (pkg, mn)

41+ | d <- depends

42+ , Just pkg <- [lookupPackageConfig d env]

43+ , (mn, _) <- exposedModules pkg

44+ ]

45+

46+ results <- forM targets $ \(pkg, mn) -> do

47+ modIface <- liftIO $ initIfaceLoad env $ loadInterface

48+ ""

49+ (Module (packageConfigId pkg) mn)

50+ (ImportByUser False)

51+ case modIface of

52+ Failed _err -> return mempty

53+ Succeeded mi -> do

54+ let avails = mi_exports mi

55+ return $ concatMap (unpackAvail mn) avails

56+ return $ fromListWith (++) $ concat results

57+

58+unpackAvail :: ModuleName -> IfaceExport -> [(Text, [(IdentInfo, Text)])]

59+unpackAvail mod =

60+ map (\id@IdentInfo {..} -> (name, [(id, pack $ moduleNameString mod)]))

61+ . mkIdentInfos

src/Development/IDE/Plugin/Completions.hs+26−11

@@ -1,7 +1,10 @@

1+{-# LANGUAGE CPP #-}

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,8 +23,11 @@ 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

2832plugin :: Plugin c

2933plugin = Plugin produceCompletions setHandlersCompletion

@@ -31,20 +35,27 @@ plugin = Plugin produceCompletions setHandlersCompletion

3135produceCompletions :: Rules ()

3236produceCompletions =

3337 define $ \ProduceCompletions file -> do

38+

39+-- When possible, rely on the haddocks embedded in our interface files

40+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'

41+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)

42+ let parsedDeps = []

43+#else

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

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

51+ cdata <- liftIO $ cacheDataProducer packageState'

4152 (tmrModule tm') parsedDeps

42− return ([], Just (cdata, tm'))

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)

@@ -66,18 +77,22 @@ 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 [])

src/Development/IDE/Plugin/Completions/Logic.hs+27−47

@@ -11,7 +11,7 @@ module Development.IDE.Plugin.Completions.Logic (

1111import Control.Applicative

1212import Data.Char (isSpace, isUpper)

1313import Data.Generics

14−import Data.List as List hiding (stripPrefix)

14+import Data.List.Extra as List hiding (stripPrefix)

1515import qualified Data.Map as Map

1616import Data.Maybe (fromMaybe, mapMaybe)

1717import qualified Data.Text as T

@@ -132,7 +132,7 @@ occNameToComKind ty oc

132132

133133mkCompl :: IdeOptions -> CompItem -> CompletionItem

134134mkCompl IdeOptions{..} CI{origName,importedFrom,thingType,label,isInfix,docs} =

135− CompletionItem label kind ((colon <>) <$> typeText)

135+ CompletionItem label kind (List []) ((colon <>) <$> typeText)

136136 (Just $ CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator docs')

137137 Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)

138138 Nothing Nothing Nothing Nothing Nothing

@@ -162,7 +162,7 @@ getArgText typ = argText

162162 where

163163 argTypes = getArgs typ

164164 argText :: T.Text

165− argText = mconcat $ List.intersperse " " $ zipWith snippet [1..] argTypes

165+ argText = mconcat $ List.intersperse " " $ zipWithFrom snippet 1 argTypes

166166 snippet :: Int -> Type -> T.Text

167167 snippet i t = T.pack $ "${" <> show i <> ":" <> showGhc t <> "}"

168168 getArgs :: Type -> [Type]

@@ -186,33 +186,34 @@ getArgText typ = argText

186186

187187mkModCompl :: T.Text -> CompletionItem

188188mkModCompl label =

189− CompletionItem label (Just CiModule) Nothing

189+ CompletionItem label (Just CiModule) (List []) Nothing

190190 Nothing Nothing Nothing Nothing Nothing Nothing Nothing

191191 Nothing Nothing Nothing Nothing Nothing

192192

193193mkImportCompl :: T.Text -> T.Text -> CompletionItem

194194mkImportCompl enteredQual label =

195− CompletionItem m (Just CiModule) (Just label)

195+ CompletionItem m (Just CiModule) (List []) (Just label)

196196 Nothing Nothing Nothing Nothing Nothing Nothing Nothing

197197 Nothing Nothing Nothing Nothing Nothing

198− where

198+ where

199199 m = fromMaybe "" (T.stripPrefix enteredQual label)

200200

201201mkExtCompl :: T.Text -> CompletionItem

202202mkExtCompl label =

203− CompletionItem label (Just CiKeyword) Nothing

203+ CompletionItem label (Just CiKeyword) (List []) Nothing

204204 Nothing Nothing Nothing Nothing Nothing Nothing Nothing

205205 Nothing Nothing Nothing Nothing Nothing

206206

207207mkPragmaCompl :: T.Text -> T.Text -> CompletionItem

208208mkPragmaCompl label insertText =

209− CompletionItem label (Just CiKeyword) Nothing

209+ CompletionItem label (Just CiKeyword) (List []) Nothing

210210 Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet)

211211 Nothing Nothing Nothing Nothing Nothing

212212

213−cacheDataProducer :: HscEnv -> DynFlags -> TypecheckedModule -> [ParsedModule] -> IO CachedCompletions

214−cacheDataProducer packageState dflags tm deps = do

213+cacheDataProducer :: HscEnv -> TypecheckedModule -> [ParsedModule] -> IO CachedCompletions

214+cacheDataProducer packageState tm deps = do

215215 let parsedMod = tm_parsed_module tm

216+ dflags = hsc_dflags packageState

216217 curMod = moduleName $ ms_mod $ pm_mod_summary parsedMod

217218 Just (_,limports,_,_) = tm_renamed_source tm

218219

@@ -269,18 +270,18 @@ cacheDataProducer packageState dflags tm deps = do

269270 let typ = Just $ varType var

270271 name = Var.varName var

271272 label = T.pack $ showGhc name

272− docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) name

273+ docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) name

273274 return $ CI name (showModName curMod) typ label Nothing docs

274275

275276 toCompItem :: ModuleName -> Name -> IO CompItem

276277 toCompItem mn n = do

277− docs <- runGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) n

278+ docs <- evalGhcEnv packageState $ getDocumentationTryGhc (tm_parsed_module tm : deps) n

278279-- lookupName uses runInteractiveHsc, i.e., GHCi stuff which does not work with GHCi

279280-- and leads to fun errors like "Cannot continue after interface file error".

280281#ifdef GHC_LIB

281282 let ty = Right Nothing

282283#else

283− ty <- runGhcEnv packageState $ catchSrcErrors "completion" $ do

284+ ty <- evalGhcEnv packageState $ catchSrcErrors "completion" $ do

284285 name' <- lookupName n

285286 return $ name' >>= safeTyThingType

286287#endif

@@ -303,19 +304,16 @@ toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x

303304 | otherwise = x { _insertTextFormat = Just PlainText

304305 , _insertText = Nothing

305306 }

306− where supported = fromMaybe False (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)

307+ where supported = Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)

307308

308309-- | Returns the cached completions for the given module and position.

309−getCompletions :: IdeOptions -> CachedCompletions -> TypecheckedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]

310+getCompletions :: IdeOptions -> CachedCompletions -> ParsedModule -> VFS.PosPrefixInfo -> ClientCapabilities -> WithSnippets -> IO [CompletionItem]

310311getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules }

311− tm prefixInfo caps withSnippets = do

312+ pm prefixInfo caps withSnippets = do

312313 let VFS.PosPrefixInfo { VFS.fullLine, VFS.prefixModule, VFS.prefixText } = prefixInfo

313314 enteredQual = if T.null prefixModule then "" else prefixModule <> "."

314315 fullPrefix = enteredQual <> prefixText

315316

316− -- default to value context if no explicit context

317− context = fromMaybe ValueContext $ getCContext pos (tm_parsed_module tm)

318−

319317 {- correct the position by moving 'foo :: Int -> String -> '

320318 ^

321319 to 'foo :: Int -> String -> '

@@ -344,10 +342,11 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl

344342 where

345343 isTypeCompl = isTcOcc . occName . origName

346344 -- completions specific to the current context

347− ctxCompls' = case context of

348− TypeContext -> filter isTypeCompl compls

349− ValueContext -> filter (not . isTypeCompl) compls

350− _ -> 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

351350 -- Add whether the text to insert has backticks

352351 ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls'

353352

@@ -373,7 +372,9 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl

373372 filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules

374373 filtPragmaCompls = filtListWithSnippet mkPragmaCompl validPragmas

375374 filtOptsCompls = filtListWith mkExtCompl

376− filtKeywordCompls = if T.null prefixModule then filtListWith mkExtCompl keywords else []

375+ filtKeywordCompls

376+ | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)

377+ | otherwise = []

377378

378379 stripLeading :: Char -> String -> String

379380 stripLeading _ [] = []

@@ -394,7 +395,7 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl

394395 = filtModNameCompls ++ map (toggleSnippets caps withSnippets

395396 . mkCompl ideOpts . stripAutoGenerated) filtCompls

396397 ++ filtKeywordCompls

397−

398+

398399 return result

399400

400401-- The supported languages and extensions

@@ -404,7 +405,7 @@ languagesAndExts = map T.pack $ DynFlags.supportedLanguagesAndExtensions ( Platf

404405#else

405406languagesAndExts = map T.pack DynFlags.supportedLanguagesAndExtensions

406407#endif

407−

408+

408409-- ---------------------------------------------------------------------

409410-- helper functions for pragmas

410411-- ---------------------------------------------------------------------

@@ -527,24 +528,3 @@ prefixes =

527528 , "$c"

528529 , "$m"

529530 ]

530−

531−keywords :: [T.Text]

532−keywords =

533− [

534− -- From https://wiki.haskell.org/Keywords

535− "as"

536− , "case", "of"

537− , "class", "instance", "type"

538− , "data", "family", "newtype"

539− , "default"

540− , "deriving"

541− , "do", "mdo", "proc", "rec"

542− , "forall"

543− , "foreign"

544− , "hiding"

545− , "if", "then", "else"

546− , "import", "qualified", "hiding"

547− , "infix", "infixl", "infixr"

548− , "let", "in", "where"

549− , "module"

550− ]

src/Development/IDE/Spans/AtPoint.hs+17−18

@@ -13,15 +13,12 @@ import Development.IDE.GHC.Orphans()

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

@@ -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− -> [ParsedModule]

55+ -> [ParsedModule] -- ^ Dependencies parsed, optional

56+ -> [ModIface] -- ^ Dependencies module interfaces, required

5557 -> IO SpansInfo

56−getSrcSpanInfos env imports tc deps =

57− runGhcEnv env $

58− getSpanInfo imports (tmrModule tc) deps

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

6466 -> [ParsedModule]

67+ -> [ModIface]

6568 -> m SpansInfo

66−getSpanInfo mods tcm deps =

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 = tm_parsed_module tcm : deps

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

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

@@ -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,135 +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− let fp = T.pack $ escapeURIString isUnescapedInURI $ unEscapeString $ T.unpack t

126− in NormalizedUri (hash fp) fp

127−

128− platformAdjustToUriPath :: FilePath -> String

129− platformAdjustToUriPath srcPath

130− | isWindows = '/' : escapedPath

131− | otherwise = escapedPath

132− where

133− (splitDirectories, splitDrive)

134− | isWindows =

135− (FPW.splitDirectories, FPW.splitDrive)

136− | otherwise =

137− (FPP.splitDirectories, FPP.splitDrive)

138− escapedPath =

139− case splitDrive srcPath of

140− (drv, rest) ->

141− convertDrive drv `FPP.joinDrive`

142− FPP.joinPath (map (escapeURIString unescaped) $ splitDirectories rest)

143− -- splitDirectories does not remove the path separator after the drive so

144− -- we do a final replacement of \ to /

145− convertDrive drv

146− | isWindows && FPW.hasTrailingPathSeparator drv =

147− FPP.addTrailingPathSeparator (init drv)

148− | otherwise = drv

149− unescaped c

150− | isWindows = isUnreserved c || c `elem` [':', '\\', '/']

151− | otherwise = isUnreserved c || c == '/'

152−

153−

154−

155−fromUri :: LSP.NormalizedUri -> NormalizedFilePath

156−fromUri = toNormalizedFilePath . fromMaybe noFilePath . uriToFilePath' . fromNormalizedUri

61+filePathToUri' :: LSP.NormalizedFilePath -> LSP.NormalizedUri

62+filePathToUri' = LSP.normalizedFilePathToUri

15763

64+fromUri :: LSP.NormalizedUri -> LSP.NormalizedFilePath

65+fromUri = fromMaybe (toNormalizedFilePath' noFilePath) . LSP.uriToNormalizedFilePath

15866

15967noFilePath :: FilePath

16068noFilePath = "<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.20.0.0

6−- haskell-lsp-types-0.20.0.0

7−- lsp-test-0.10.1.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.20.0.0

6−- haskell-lsp-types-0.20.0.0

7−- lsp-test-0.10.1.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+13−5

@@ -5,13 +5,13 @@ packages:

55extra-deps:

66- aeson-1.4.6.0

77- base-orphans-0.8.2

8−- haskell-lsp-0.20.0.0

9−- haskell-lsp-types-0.20.0.0

10−- lsp-test-0.10.1.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

@@ -20,6 +20,14 @@ extra-deps:

2020- parser-combinators-1.2.1

2121- haddock-library-1.8.0

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

2332nix:

2433 packages: [zlib]

25−allow-newer: true

stack88.yaml+5

@@ -2,5 +2,10 @@ resolver: nightly-2020-02-13

22packages:

33- .

44extra-deps:

5+- haskell-lsp-0.22.0.0

6+- haskell-lsp-types-0.22.0.0

7+- lsp-test-0.11.0.1

8+- ghc-check-0.3.0.1

9+- hie-bios-0.5.0

510nix:

611 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+743−288

@@ -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,34 +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− , watchedFilesTests

67− ]

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

6881

6982initializeResponseTests :: TestTree

7083initializeResponseTests = withResource acquire release tests where

@@ -99,7 +112,7 @@ initializeResponseTests = withResource acquire release tests where

99112 , chk "NO doc link" _documentLinkProvider Nothing

100113 , chk "NO color" _colorProvider (Just $ ColorOptionsStatic False)

101114 , chk "NO folding range" _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)

102− , chk " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

115+ , che " execute command" _executeCommandProvider (Just $ ExecuteCommandOptions $ List ["typesignature.add"])

103116 , chk " workspace" _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))

104117 , chk "NO experimental" _experimental Nothing

105118 ] where

@@ -115,8 +128,17 @@ initializeResponseTests = withResource acquire release tests where

115128 chk title getActual expected =

116129 testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir

117130

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+

118140 innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner

119− innerCaps (ResponseMessage _ _ (Just (InitializeResponseCapabilities c)) _) = c

141+ innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c

120142 innerCaps _ = error "this test only expects inner capabilities"

121143

122144 acquire :: IO InitializeResponse

@@ -130,7 +152,7 @@ diagnosticTests :: TestTree

130152diagnosticTests = testGroup "diagnostics"

131153 [ testSessionWait "fix syntax error" $ do

132154 let content = T.unlines [ "module Testing wher" ]

133− doc <- openDoc' "Testing.hs" "haskell" content

155+ doc <- createDoc "Testing.hs" "haskell" content

134156 expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])]

135157 let change = TextDocumentContentChangeEvent

136158 { _range = Just (Range (Position 0 15) (Position 0 19))

@@ -141,9 +163,9 @@ diagnosticTests = testGroup "diagnostics"

141163 expectDiagnostics [("Testing.hs", [])]

142164 , testSessionWait "introduce syntax error" $ do

143165 let content = T.unlines [ "module Testing where" ]

144− doc <- openDoc' "Testing.hs" "haskell" content

145− void (message :: Session WorkDoneProgressCreateRequest)

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

147169 let change = TextDocumentContentChangeEvent

148170 { _range = Just (Range (Position 0 15) (Position 0 18))

149171 , _rangeLength = Nothing

@@ -159,7 +181,7 @@ diagnosticTests = testGroup "diagnostics"

159181 , "bar :: Int -> Int -> Int"

160182 , "bar a b = cd + b"

161183 ]

162− _ <- openDoc' "Testing.hs" "haskell" content

184+ _ <- createDoc "Testing.hs" "haskell" content

163185 expectDiagnostics

164186 [ ( "Testing.hs"

165187 , [ (DsError, (2, 14), "Variable not in scope: ab")

@@ -173,7 +195,7 @@ diagnosticTests = testGroup "diagnostics"

173195 , "foo :: Int -> String -> Int"

174196 , "foo a b = a + b"

175197 ]

176− _ <- openDoc' "Testing.hs" "haskell" content

198+ _ <- createDoc "Testing.hs" "haskell" content

177199 expectDiagnostics

178200 [ ( "Testing.hs"

179201 , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")]

@@ -185,7 +207,7 @@ diagnosticTests = testGroup "diagnostics"

185207 , "foo :: Int -> String"

186208 , "foo a = _ a"

187209 ]

188− _ <- openDoc' "Testing.hs" "haskell" content

210+ _ <- createDoc "Testing.hs" "haskell" content

189211 expectDiagnostics

190212 [ ( "Testing.hs"

191213 , [(DsError, (2, 8), "Found hole: _ :: Int -> String")]

@@ -207,24 +229,23 @@ diagnosticTests = testGroup "diagnostics"

207229 [ ("A.hs", [(DsError, (2,4), aMessage)])

208230 , ("B.hs", [(DsError, (3,4), bMessage)])]

209231 deferralTest title binding msg = testSessionWait title $ do

210− _ <- openDoc' "A.hs" "haskell" $ sourceA binding

211− _ <- openDoc' "B.hs" "haskell" sourceB

232+ _ <- createDoc "A.hs" "haskell" $ sourceA binding

233+ _ <- createDoc "B.hs" "haskell" sourceB

212234 expectDiagnostics $ expectedDs msg

213235 in

214236 [ deferralTest "type error" "True" "Couldn't match expected type"

215237 , deferralTest "typed hole" "_" "Found hole"

216238 , deferralTest "out of scope var" "unbound" "Variable not in scope"

217− , deferralTest "message shows error" "True" "A.hs:3:5: error:"

218239 ]

219240

220241 , testSessionWait "remove required module" $ do

221242 let contentA = T.unlines [ "module ModuleA where" ]

222− docA <- openDoc' "ModuleA.hs" "haskell" contentA

243+ docA <- createDoc "ModuleA.hs" "haskell" contentA

223244 let contentB = T.unlines

224245 [ "module ModuleB where"

225246 , "import ModuleA"

226247 ]

227− _ <- openDoc' "ModuleB.hs" "haskell" contentB

248+ _ <- createDoc "ModuleB.hs" "haskell" contentB

228249 let change = TextDocumentContentChangeEvent

229250 { _range = Just (Range (Position 0 0) (Position 0 20))

230251 , _rangeLength = Nothing

@@ -237,20 +258,20 @@ diagnosticTests = testGroup "diagnostics"

237258 [ "module ModuleB where"

238259 , "import ModuleA"

239260 ]

240− _ <- openDoc' "ModuleB.hs" "haskell" contentB

261+ _ <- createDoc "ModuleB.hs" "haskell" contentB

241262 expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

242263 let contentA = T.unlines [ "module ModuleA where" ]

243− _ <- openDoc' "ModuleA.hs" "haskell" contentA

264+ _ <- createDoc "ModuleA.hs" "haskell" contentA

244265 expectDiagnostics [("ModuleB.hs", [])]

245266 , testSessionWait "add missing module (non workspace)" $ do

246267 let contentB = T.unlines

247268 [ "module ModuleB where"

248269 , "import ModuleA"

249270 ]

250− _ <- openDoc'' "/tmp/ModuleB.hs" "haskell" contentB

271+ _ <- createDoc "/tmp/ModuleB.hs" "haskell" contentB

251272 expectDiagnostics [("/tmp/ModuleB.hs", [(DsError, (1, 7), "Could not find module")])]

252273 let contentA = T.unlines [ "module ModuleA where" ]

253− _ <- openDoc'' "/tmp/ModuleA.hs" "haskell" contentA

274+ _ <- createDoc "/tmp/ModuleA.hs" "haskell" contentA

254275 expectDiagnostics [("/tmp/ModuleB.hs", [])]

255276 , testSessionWait "cyclic module dependency" $ do

256277 let contentA = T.unlines

@@ -261,8 +282,8 @@ diagnosticTests = testGroup "diagnostics"

261282 [ "module ModuleB where"

262283 , "import ModuleA"

263284 ]

264− _ <- openDoc' "ModuleA.hs" "haskell" contentA

265− _ <- openDoc' "ModuleB.hs" "haskell" contentB

285+ _ <- createDoc "ModuleA.hs" "haskell" contentA

286+ _ <- createDoc "ModuleB.hs" "haskell" contentB

266287 expectDiagnostics

267288 [ ( "ModuleA.hs"

268289 , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]

@@ -283,9 +304,9 @@ diagnosticTests = testGroup "diagnostics"

283304 let contentBboot = T.unlines

284305 [ "module ModuleB where"

285306 ]

286− _ <- openDoc' "ModuleA.hs" "haskell" contentA

287− _ <- openDoc' "ModuleB.hs" "haskell" contentB

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

289310 expectDiagnostics []

290311 , testSessionWait "correct reference used with hs-boot" $ do

291312 let contentB = T.unlines

@@ -307,10 +328,10 @@ diagnosticTests = testGroup "diagnostics"

307328 -- resolved to the hs-boot file

308329 , "y = x"

309330 ]

310− _ <- openDoc' "ModuleB.hs" "haskell" contentB

311− _ <- openDoc' "ModuleA.hs" "haskell" contentA

312− _ <- openDoc' "ModuleA.hs-boot" "haskell" contentAboot

313− _ <- 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

314335 expectDiagnostics []

315336 , testSessionWait "redundant import" $ do

316337 let contentA = T.unlines ["module ModuleA where"]

@@ -319,8 +340,8 @@ diagnosticTests = testGroup "diagnostics"

319340 , "module ModuleB where"

320341 , "import ModuleA"

321342 ]

322− _ <- openDoc' "ModuleA.hs" "haskell" contentA

323− _ <- openDoc' "ModuleB.hs" "haskell" contentB

343+ _ <- createDoc "ModuleA.hs" "haskell" contentA

344+ _ <- createDoc "ModuleB.hs" "haskell" contentB

324345 expectDiagnostics

325346 [ ( "ModuleB.hs"

326347 , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant")]

@@ -342,8 +363,8 @@ diagnosticTests = testGroup "diagnostics"

342363 , "wrong1 = ThisList.map"

343364 , "wrong2 = BaseList.x"

344365 ]

345− _ <- openDoc' "Data/List.hs" "haskell" thisDataListContent

346− _ <- openDoc' "Main.hs" "haskell" mainContent

366+ _ <- createDoc "Data/List.hs" "haskell" thisDataListContent

367+ _ <- createDoc "Main.hs" "haskell" mainContent

347368 expectDiagnostics

348369 [ ( "Main.hs"

349370 , [(DsError, (6, 9), "Not in scope: \8216ThisList.map\8217")

@@ -358,7 +379,7 @@ diagnosticTests = testGroup "diagnostics"

358379 , "foo :: Ord a => a -> Int"

359380 , "foo a = 1"

360381 ]

361− _ <- openDoc' "Foo.hs" "haskell" fooContent

382+ _ <- createDoc "Foo.hs" "haskell" fooContent

362383 expectDiagnostics

363384 [ ( "Foo.hs"

364385 -- The test is to make sure that warnings contain unqualified names

@@ -383,18 +404,18 @@ diagnosticTests = testGroup "diagnostics"

383404 Just pathB <- pure $ uriToFilePath uriB

384405 uriB <- pure $

385406 let (drive, suffix) = splitDrive pathB

386− in filePathToUri (joinDrive (map toLower drive ) suffix)

407+ in filePathToUri (joinDrive (lower drive) suffix)

387408 liftIO $ createDirectoryIfMissing True (takeDirectory pathB)

388409 liftIO $ writeFileUTF8 pathB $ T.unpack bContent

389410 uriA <- getDocUri "A/A.hs"

390411 Just pathA <- pure $ uriToFilePath uriA

391412 uriA <- pure $

392413 let (drive, suffix) = splitDrive pathA

393− in filePathToUri (joinDrive (map toLower drive ) suffix)

414+ in filePathToUri (joinDrive (lower drive) suffix)

394415 let itemA = TextDocumentItem uriA "haskell" 0 aContent

395416 let a = TextDocumentIdentifier uriA

396417 sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)

397− diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification

418+ diagsNot <- skipManyTill anyMessage diagnostic

398419 let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)

399420 -- Check that if we put a lower-case drive in for A.A

400421 -- the diagnostics for A.B will also be lower-case.

@@ -403,6 +424,38 @@ diagnosticTests = testGroup "diagnostics"

403424 liftIO $ unless ("redundant" `T.isInfixOf` msg) $

404425 assertFailure ("Expected redundant import but got " <> T.unpack msg)

405426 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

406459 ]

407460

408461codeActionTests :: TestTree

@@ -411,6 +464,7 @@ codeActionTests = testGroup "code actions"

411464 , typeWildCardActionTests

412465 , removeImportTests

413466 , extendImportTests

467+ , suggestImportTests

414468 , addExtensionTests

415469 , fixConstructorImportTests

416470 , importRenameActionTests

@@ -426,21 +480,28 @@ codeLensesTests = testGroup "code lenses"

426480

427481watchedFilesTests :: TestTree

428482watchedFilesTests = testGroup "watched files"

429− [ testSession "workspace file" $ do

430− _ <- openDoc' "A.hs" "haskell" "module A where"

431− RequestMessage{_params = RegistrationParams (List regs)} <- skipManyTill anyMessage (message @RegisterCapabilityRequest)

432− let watchedFileRegs =

433− [ args | Registration _id WorkspaceDidChangeWatchedFiles args <- regs ]

434− liftIO $ assertBool "watches workspace files" $ not $ null watchedFileRegs

435− , testSession "non workspace file" $ do

436− _ <- openDoc' "/tmp/A.hs" "haskell" "module A where"

437− msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @WorkDoneProgressEndNotification)

438− let watchedFileRegs =

439− [ args

440− | Just (RequestMessage{_params = RegistrationParams (List regs)}) <- msgs

441− , Registration _id WorkspaceDidChangeWatchedFiles args <- regs

442− ]

443− liftIO $ watchedFileRegs @?= []

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+

444505 -- TODO add a test for didChangeWorkspaceFolder

445506 ]

446507

@@ -452,7 +513,7 @@ renameActionTests = testGroup "rename actions"

452513 , "foo :: Int -> Int"

453514 , "foo argName = argNme"

454515 ]

455− doc <- openDoc' "Testing.hs" "haskell" content

516+ doc <- createDoc "Testing.hs" "haskell" content

456517 _ <- waitForDiagnostics

457518 action <- findCodeAction doc (Range (Position 2 14) (Position 2 20)) "Replace with ‘argName’"

458519 executeCodeAction action

@@ -470,7 +531,7 @@ renameActionTests = testGroup "rename actions"

470531 , "foo :: Maybe a -> [a]"

471532 , "foo = maybToList"

472533 ]

473− doc <- openDoc' "Testing.hs" "haskell" content

534+ doc <- createDoc "Testing.hs" "haskell" content

474535 _ <- waitForDiagnostics

475536 action <- findCodeAction doc (Range (Position 3 6) (Position 3 16)) "Replace with ‘maybeToList’"

476537 executeCodeAction action

@@ -488,7 +549,7 @@ renameActionTests = testGroup "rename actions"

488549 , "foo :: Char -> Char -> Char -> Char"

489550 , "foo argument1 argument2 argument3 = argumentX"

490551 ]

491− doc <- openDoc' "Testing.hs" "haskell" content

552+ doc <- createDoc "Testing.hs" "haskell" content

492553 _ <- waitForDiagnostics

493554 _ <- findCodeActions doc (Range (Position 2 36) (Position 2 45))

494555 ["Replace with ‘argument1’", "Replace with ‘argument2’", "Replace with ‘argument3’"]

@@ -500,7 +561,7 @@ renameActionTests = testGroup "rename actions"

500561 , "monus x y = max 0 (x - y)"

501562 , "foo x y = x `monnus` y"

502563 ]

503− doc <- openDoc' "Testing.hs" "haskell" content

564+ doc <- createDoc "Testing.hs" "haskell" content

504565 _ <- waitForDiagnostics

505566 actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))

506567 [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]

@@ -523,7 +584,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

523584 , "func :: _"

524585 , "func x = x"

525586 ]

526− doc <- openDoc' "Testing.hs" "haskell" content

587+ doc <- createDoc "Testing.hs" "haskell" content

527588 _ <- waitForDiagnostics

528589 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

529590 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -543,7 +604,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

543604 , "func :: _"

544605 , "func x y = x + y"

545606 ]

546− doc <- openDoc' "Testing.hs" "haskell" content

607+ doc <- createDoc "Testing.hs" "haskell" content

547608 _ <- waitForDiagnostics

548609 actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))

549610 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -566,7 +627,7 @@ typeWildCardActionTests = testGroup "type wildcard actions"

566627 , " y = x * 2"

567628 , " in y"

568629 ]

569− doc <- openDoc' "Testing.hs" "haskell" content

630+ doc <- createDoc "Testing.hs" "haskell" content

570631 _ <- waitForDiagnostics

571632 actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))

572633 let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands

@@ -591,7 +652,7 @@ removeImportTests = testGroup "remove import actions"

591652 let contentA = T.unlines

592653 [ "module ModuleA where"

593654 ]

594− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

655+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

595656 let contentB = T.unlines

596657 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

597658 , "module ModuleB where"

@@ -599,7 +660,7 @@ removeImportTests = testGroup "remove import actions"

599660 , "stuffB :: Integer"

600661 , "stuffB = 123"

601662 ]

602− docB <- openDoc' "ModuleB.hs" "haskell" contentB

663+ docB <- createDoc "ModuleB.hs" "haskell" contentB

603664 _ <- waitForDiagnostics

604665 [CACodeAction action@CodeAction { _title = actionTitle }]

605666 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -617,7 +678,7 @@ removeImportTests = testGroup "remove import actions"

617678 let contentA = T.unlines

618679 [ "module ModuleA where"

619680 ]

620− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

681+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

621682 let contentB = T.unlines

622683 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

623684 , "module ModuleB where"

@@ -625,7 +686,7 @@ removeImportTests = testGroup "remove import actions"

625686 , "stuffB :: Integer"

626687 , "stuffB = 123"

627688 ]

628− docB <- openDoc' "ModuleB.hs" "haskell" contentB

689+ docB <- createDoc "ModuleB.hs" "haskell" contentB

629690 _ <- waitForDiagnostics

630691 [CACodeAction action@CodeAction { _title = actionTitle }]

631692 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -647,14 +708,14 @@ removeImportTests = testGroup "remove import actions"

647708 , "stuffB = 123"

648709 , "stuffC = ()"

649710 ]

650− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

711+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

651712 let contentB = T.unlines

652713 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

653714 , "module ModuleB where"

654715 , "import ModuleA (stuffA, stuffB, stuffC, stuffA)"

655716 , "main = print stuffB"

656717 ]

657− docB <- openDoc' "ModuleB.hs" "haskell" contentB

718+ docB <- createDoc "ModuleB.hs" "haskell" contentB

658719 _ <- waitForDiagnostics

659720 [CACodeAction action@CodeAction { _title = actionTitle }]

660721 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -668,29 +729,26 @@ removeImportTests = testGroup "remove import actions"

668729 , "main = print stuffB"

669730 ]

670731 liftIO $ expectedContentAfterAction @=? contentAfterAction

671− , testSession "redundant symbol binding" $ do

732+ , testSession "redundant operator" $ do

672733 let contentA = T.unlines

673734 [ "module ModuleA where"

674735 , "a !! b = a"

736+ , "a <?> b = a"

675737 , "stuffB :: Integer"

676738 , "stuffB = 123"

677739 ]

678− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

740+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

679741 let contentB = T.unlines

680742 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

681743 , "module ModuleB where"

682− , "import qualified ModuleA as A ((!!), stuffB, (!!))"

744+ , "import qualified ModuleA as A ((<?>), stuffB, (!!))"

683745 , "main = print A.stuffB"

684746 ]

685− docB <- openDoc' "ModuleB.hs" "haskell" contentB

747+ docB <- createDoc "ModuleB.hs" "haskell" contentB

686748 _ <- waitForDiagnostics

687749 [CACodeAction action@CodeAction { _title = actionTitle }]

688750 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

689−#if MIN_GHC_API_VERSION(8,6,0)

690− liftIO $ "Remove !! from import" @=? actionTitle

691−#else

692− liftIO $ "Remove A.!! from import" @=? actionTitle

693−#endif

751+ liftIO $ "Remove !!, <?> from import" @=? actionTitle

694752 executeCodeAction action

695753 contentAfterAction <- documentContents docB

696754 let expectedContentAfterAction = T.unlines

@@ -700,21 +758,21 @@ removeImportTests = testGroup "remove import actions"

700758 , "main = print A.stuffB"

701759 ]

702760 liftIO $ expectedContentAfterAction @=? contentAfterAction

703− , (`xfail` "known broken (#299)") $ testSession "redundant hierarchical import" $ do

761+ , testSession "redundant all import" $ do

704762 let contentA = T.unlines

705763 [ "module ModuleA where"

706764 , "data A = A"

707765 , "stuffB :: Integer"

708766 , "stuffB = 123"

709767 ]

710− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

768+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

711769 let contentB = T.unlines

712770 [ "{-# OPTIONS_GHC -Wunused-imports #-}"

713771 , "module ModuleB where"

714772 , "import ModuleA (A(..), stuffB)"

715773 , "main = print stuffB"

716774 ]

717− docB <- openDoc' "ModuleB.hs" "haskell" contentB

775+ docB <- createDoc "ModuleB.hs" "haskell" contentB

718776 _ <- waitForDiagnostics

719777 [CACodeAction action@CodeAction { _title = actionTitle }]

720778 <- getCodeActions docB (Range (Position 2 0) (Position 2 5))

@@ -728,6 +786,33 @@ removeImportTests = testGroup "remove import actions"

728786 , "main = print stuffB"

729787 ]

730788 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

731816 ]

732817

733818extendImportTests :: TestTree

@@ -855,8 +940,8 @@ extendImportTests = testGroup "extend import actions"

855940 ]

856941 where

857942 template contentA contentB range expectedAction expectedContentB = do

858− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

859− docB <- openDoc' "ModuleB.hs" "haskell" contentB

943+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

944+ docB <- createDoc "ModuleB.hs" "haskell" contentB

860945 _ <- waitForDiagnostics

861946 CACodeAction action@CodeAction { _title = actionTitle } : _

862947 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -866,6 +951,61 @@ extendImportTests = testGroup "extend import actions"

866951 contentAfterAction <- documentContents docB

867952 liftIO $ expectedContentB @=? contentAfterAction

868953

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+

8691009addExtensionTests :: TestTree

8701010addExtensionTests = testGroup "add language extension actions"

8711011 [ testSession "add NamedFieldPuns language extension" $ template

@@ -911,7 +1051,7 @@ addExtensionTests = testGroup "add language extension actions"

9111051 ]

9121052 where

9131053 template initialContent range expectedAction expectedContents = do

914− doc <- openDoc' "Module.hs" "haskell" initialContent

1054+ doc <- createDoc "Module.hs" "haskell" initialContent

9151055 _ <- waitForDiagnostics

9161056 CACodeAction action@CodeAction { _title = actionTitle } : _

9171057 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -934,7 +1074,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"

9341074 [""

9351075 ,"someOtherCode = ()"

9361076 ]

937− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1077+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

9381078 _ <- waitForDiagnostics

9391079 CACodeAction action@CodeAction { _title = actionTitle } : _

9401080 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -958,7 +1098,7 @@ insertNewDefinitionTests = testGroup "insert new definition actions"

9581098 [""

9591099 ,"someOtherCode = ()"

9601100 ]

961− docB <- openDoc' "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

1101+ docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')

9621102 _ <- waitForDiagnostics

9631103 CACodeAction action@CodeAction { _title = actionTitle } : _

9641104 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -997,8 +1137,8 @@ fixConstructorImportTests = testGroup "fix import actions"

9971137 ]

9981138 where

9991139 template contentA contentB range expectedAction expectedContentB = do

1000− _docA <- openDoc' "ModuleA.hs" "haskell" contentA

1001− docB <- openDoc' "ModuleB.hs" "haskell" contentB

1140+ _docA <- createDoc "ModuleA.hs" "haskell" contentA

1141+ docB <- createDoc "ModuleB.hs" "haskell" contentB

10021142 _diags <- waitForDiagnostics

10031143 CACodeAction action@CodeAction { _title = actionTitle } : _

10041144 <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>

@@ -1017,7 +1157,7 @@ importRenameActionTests = testGroup "import rename actions"

10171157 [ "module Testing where"

10181158 , "import Data.Mape"

10191159 ]

1020− doc <- openDoc' "Testing.hs" "haskell" content

1160+ doc <- createDoc "Testing.hs" "haskell" content

10211161 _ <- waitForDiagnostics

10221162 actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))

10231163 let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]

@@ -1054,10 +1194,10 @@ fillTypedHoleTests = let

10541194 newA newB newC = testSession (T.unpack actionTitle) $ do

10551195 let originalCode = sourceCode oldA oldB oldC

10561196 let expectedCode = sourceCode newA newB newC

1057− doc <- openDoc' "Testing.hs" "haskell" originalCode

1197+ doc <- createDoc "Testing.hs" "haskell" originalCode

10581198 _ <- waitForDiagnostics

10591199 actionsOrCommands <- getCodeActions doc (Range (Position 9 0) (Position 9 maxBound))

1060− let chosenAction = pickActionWithTitle actionTitle actionsOrCommands

1200+ chosenAction <- liftIO $ pickActionWithTitle actionTitle actionsOrCommands

10611201 executeCodeAction chosenAction

10621202 modifiedCode <- documentContents doc

10631203 liftIO $ expectedCode @=? modifiedCode

@@ -1094,36 +1234,37 @@ fillTypedHoleTests = let

10941234

10951235addSigActionTests :: TestTree

10961236addSigActionTests = let

1097− header = "{-# OPTIONS_GHC -Wmissing-signatures #-}"

1098− moduleH = "module Sigs where"

1237+ header = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures #-}"

1238+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"

10991239 before def = T.unlines [header, moduleH, def]

11001240 after' def sig = T.unlines [header, moduleH, sig, def]

11011241

11021242 def >:: sig = testSession (T.unpack def) $ do

11031243 let originalCode = before def

11041244 let expectedCode = after' def sig

1105− doc <- openDoc' "Sigs.hs" "haskell" originalCode

1245+ doc <- createDoc "Sigs.hs" "haskell" originalCode

11061246 _ <- waitForDiagnostics

11071247 actionsOrCommands <- getCodeActions doc (Range (Position 3 1) (Position 3 maxBound))

1108− let chosenAction = pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

1248+ chosenAction <- liftIO $ pickActionWithTitle ("add signature: " <> sig) actionsOrCommands

11091249 executeCodeAction chosenAction

11101250 modifiedCode <- documentContents doc

11111251 liftIO $ expectedCode @=? modifiedCode

11121252 in

11131253 testGroup "add signature"

1114− [ "abc = True" >:: "abc :: Bool"

1115− , "foo a b = a + b" >:: "foo :: Num a => a -> a -> a"

1116− , "bar a b = show $ a + b" >:: "bar :: (Show a, Num a) => a -> a -> String"

1117− , "(!!!) a b = a > b" >:: "(!!!) :: Ord a => a -> a -> Bool"

1118− , "a >>>> b = a + b" >:: "(>>>>) :: Num a => a -> a -> a"

1119− , "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"

11201261 ]

11211262

11221263addSigLensesTests :: TestTree

11231264addSigLensesTests = let

1124− missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wunused-matches #-}"

1265+ missing = "{-# OPTIONS_GHC -Wmissing-signatures -Wmissing-pattern-synonym-signatures -Wunused-matches #-}"

11251266 notMissing = "{-# OPTIONS_GHC -Wunused-matches #-}"

1126− moduleH = "module Sigs where"

1267+ moduleH = "{-# LANGUAGE PatternSynonyms #-}\nmodule Sigs where"

11271268 other = T.unlines ["f :: Integer -> Integer", "f x = 3"]

11281269 before withMissing def

11291270 = T.unlines $ (if withMissing then (missing :) else (notMissing :)) [moduleH, def, other]

@@ -1133,49 +1274,41 @@ addSigLensesTests = let

11331274 sigSession withMissing def sig = testSession (T.unpack def) $ do

11341275 let originalCode = before withMissing def

11351276 let expectedCode = after' withMissing def sig

1136− doc <- openDoc' "Sigs.hs" "haskell" originalCode

1277+ doc <- createDoc "Sigs.hs" "haskell" originalCode

11371278 [CodeLens {_command = Just c}] <- getCodeLenses doc

11381279 executeCommand c

11391280 modifiedCode <- getDocumentEdit doc

11401281 liftIO $ expectedCode @=? modifiedCode

11411282 in

11421283 testGroup "add signature"

1143− [ testGroup "with warnings enabled"

1144− [ sigSession True "abc = True" "abc :: Bool"

1145− , sigSession True "foo a b = a + b" "foo :: Num a => a -> a -> a"

1146− , sigSession True "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"

1147− , sigSession True "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"

1148− , sigSession True "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"

1149− , sigSession True "a `haha` b = a b" "haha :: (t1 -> t2) -> t1 -> t2"

1150− ]

1151− , testGroup "with warnings disabled"

1152− [ sigSession False "abc = True" "abc :: Bool"

1153− , sigSession False "foo a b = a + b" "foo :: Num a => a -> a -> a"

1154− , sigSession False "bar a b = show $ a + b" "bar :: (Show a, Num a) => a -> a -> String"

1155− , sigSession False "(!!!) a b = a > b" "(!!!) :: Ord a => a -> a -> Bool"

1156− , sigSession False "a >>>> b = a + b" "(>>>>) :: Num a => a -> a -> a"

1157− , 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"

11581292 ]

1293+ | (title, enableWarnings) <-

1294+ [("with warnings enabled", True)

1295+ ,("with warnings disabled", False)

1296+ ]

11591297 ]

11601298

1161−findDefinitionAndHoverTests :: TestTree

1162−findDefinitionAndHoverTests = let

1163−

1164− tst (get, check) pos targetRange title = testSession title $ do

1165− doc <- openTestDataDoc sourceFilePath

1166− found <- get doc pos

1167− check found targetRange

1168−

1169− checkDefs :: [Location] -> [Expect] -> Session ()

1170− checkDefs defs expectations = traverse_ check expectations where

1299+checkDefs :: [Location] -> Session [Expect] -> Session ()

1300+checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where

11711301

1172− check (ExpectRange expectedRange) = do

1173− assertNDefinitionsFound 1 defs

1174− assertRangeCorrect (head defs) expectedRange

1175− check ExpectNoDefinitions = do

1176− assertNDefinitionsFound 0 defs

1177− check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"

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

11791312

11801313 assertNDefinitionsFound :: Int -> [a] -> Session ()

11811314 assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)

@@ -1183,8 +1316,19 @@ findDefinitionAndHoverTests = let

11831316 assertRangeCorrect Location{_range = foundRange} expectedRange =

11841317 liftIO $ expectedRange @=? foundRange

11851318

1186− checkHover :: Maybe Hover -> [Expect] -> Session ()

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

11881332

11891333 check expected =

11901334 case hover of

@@ -1227,9 +1371,12 @@ findDefinitionAndHoverTests = let

12271371

12281372 mkFindTests tests = testGroup "get"

12291373 [ testGroup "definition" $ mapMaybe fst tests

1230− , testGroup "hover" $ mapMaybe snd tests ]

1374+ , testGroup "hover" $ mapMaybe snd tests

1375+ , checkFileCompiles sourceFilePath ]

12311376

1232− test runDef runHover look expect title =

1377+ test runDef runHover look expect = testM runDef runHover look (return expect)

1378+

1379+ testM runDef runHover look expect title =

12331380 ( runDef $ tst def look expect title

12341381 , runHover $ tst hover look expect title ) where

12351382 def = (getDefinitions, checkDefs)

@@ -1237,87 +1384,100 @@ findDefinitionAndHoverTests = let

12371384 --type_ = (getTypeDefinitions, checkTDefs) -- getTypeDefinitions always times out

12381385

12391386 -- search locations expectations on results

1240− fffL4 = _start fffR ; fffR = mkRange 4 4 4 7 ; fff = [ExpectRange fffR]

1241− fffL8 = Position 8 4 ;

1242− fffL14 = Position 14 7 ;

1243− aaaL14 = Position 14 20 ; aaa = [mkR 7 0 7 3]

1244− dcL7 = Position 7 11 ; tcDC = [mkR 3 23 5 16]

1245− dcL12 = Position 12 11 ;

1246− xtcL5 = Position 5 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ‘GHC.Types’"]]

1247− tcL6 = Position 6 11 ; tcData = [mkR 3 0 5 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:4:1"]]

1248− vvL16 = Position 16 12 ; vv = [mkR 16 4 16 6]

1249− opL16 = Position 16 15 ; op = [mkR 17 2 17 4]

1250− opL18 = Position 18 22 ; opp = [mkR 18 13 18 17]

1251− aL18 = Position 18 20 ; apmp = [mkR 18 10 18 11]

1252− b'L19 = Position 19 13 ; bp = [mkR 19 6 19 7]

1253− xvL20 = Position 20 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["Data.Text.pack", ":: String -> Text"]]

1254− clL23 = Position 23 11 ; cls = [mkR 21 0 22 20, ExpectHoverText ["MyClass", "GotoHover.hs:22:1"]]

1255− clL25 = Position 25 9

1256− eclL15 = Position 15 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ‘GHC.Num’"]]

1257− dnbL29 = Position 29 18 ; dnb = [ExpectHoverText [":: ()"], mkR 29 12 29 21]

1258− dnbL30 = Position 30 23

1259− lcbL33 = Position 33 26 ; lcb = [ExpectHoverText [":: Char"], mkR 33 26 33 27]

1260− lclL33 = Position 33 22

1261− mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14]

1262− mclL37 = Position 37 1

1263− spaceL37 = Position 37 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]

1264− 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"]]

12651412 ; constr = [ExpectHoverText ["Monad m"]]

1266− eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]

1267− intL40 = Position 40 34 ; kindI = [ExpectHoverText [":: *\n"]]

1268− tvrL40 = Position 40 37 ; kindV = [ExpectHoverText [":: * -> *\n"]]

1269− intL41 = Position 41 20 ; litI = [ExpectHoverText ["7518"]]

1270− chrL36 = Position 37 24 ; litC = [ExpectHoverText ["'f'"]]

1271− txtL8 = Position 8 14 ; litT = [ExpectHoverText ["\"dfgy\""]]

1272− lstL43 = Position 43 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]]

1273− outL45 = Position 45 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]

1274− 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]

12751424 in

12761425 mkFindTests

1277− -- def hover look expect

1278− [ test yes yes fffL4 fff "field in record definition"

1279− , test broken broken fffL8 fff "field in record construction #71"

1280− , test yes yes fffL14 fff "field name used as accessor" -- 120 in Calculate.hs

1281− , test yes yes aaaL14 aaa "top-level name" -- 120

1282− , test yes yes dcL7 tcDC "data constructor record #247"

1283− , test yes yes dcL12 tcDC "data constructor plain" -- 121

1284− , test yes yes tcL6 tcData "type constructor #248" -- 147

1285− , test broken yes xtcL5 xtc "type constructor external #248,249"

1286− , test broken yes xvL20 xvMsg "value external package #249" -- 120

1287− , test yes yes vvL16 vv "plain parameter" -- 120

1288− , test yes yes aL18 apmp "pattern match name" -- 120

1289− , test yes yes opL16 op "top-level operator" -- 120, 123

1290− , test yes yes opL18 opp "parameter operator" -- 120

1291− , test yes yes b'L19 bp "name in backticks" -- 120

1292− , test yes yes clL23 cls "class in instance declaration #250"

1293− , test yes yes clL25 cls "class in signature #250" -- 147

1294− , test broken yes eclL15 ecls "external class in signature #249,250"

1295− , test yes yes dnbL29 dnb "do-notation bind" -- 137

1296− , test yes yes dnbL30 dnb "do-notation lookup"

1297− , test yes yes lcbL33 lcb "listcomp bind" -- 137

1298− , test yes yes lclL33 lcb "listcomp lookup"

1299− , test yes yes mclL36 mcl "top-level fn 1st clause"

1300− , test yes yes mclL37 mcl "top-level fn 2nd clause #246"

1301− , test yes yes spaceL37 space "top-level fn on space #315"

1302− , test no broken docL41 doc "documentation #7"

1303− , test no yes eitL40 kindE "kind of Either #273"

1304− , test no yes intL40 kindI "kind of Int #273"

1305− , test no broken tvrL40 kindV "kind of (* -> *) type variable #273"

1306− , test no yes intL41 litI "literal Int in hover info #274"

1307− , test no yes chrL36 litC "literal Char in hover info #274"

1308− , test no yes txtL8 litT "literal Text in hover info #274"

1309− , test no yes lstL43 litL "literal List in hover info #274"

1310− , test no yes docL41 constr "type constraint in hover info #283"

1311− , test broken broken outL45 outSig "top-level signature #310"

1312− , 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)"

13131464 ]

13141465 where yes, broken :: (TestTree -> Maybe TestTree)

13151466 yes = Just -- test should run and pass

13161467 broken = Just . (`xfail` "known broken")

13171468 no = const Nothing -- don't run this test at all

13181469

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+

13191478pluginTests :: TestTree

1320−pluginTests = testSessionWait "plugins" $ do

1479+pluginTests = (`xfail8101` "known broken (#556)")

1480+ $ testSessionWait "plugins" $ do

13211481 let content =

13221482 T.unlines

13231483 [ "{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}"

@@ -1331,7 +1491,7 @@ pluginTests = testSessionWait "plugins" $ do

13311491 , "foo :: Int -> Int -> Int"

13321492 , "foo a b = a + c"

13331493 ]

1334− _ <- openDoc' "Testing.hs" "haskell" content

1494+ _ <- createDoc "Testing.hs" "haskell" content

13351495 expectDiagnostics

13361496 [ ( "Testing.hs",

13371497 [(DsError, (8, 14), "Variable not in scope: c")]

@@ -1358,7 +1518,7 @@ cppTests =

13581518 run $ expectError content (2, 1)

13591519 )

13601520 , testSessionWait "cpp-ghcide" $ do

1361− _ <- openDoc' "A.hs" "haskell" $ T.unlines

1521+ _ <- createDoc "A.hs" "haskell" $ T.unlines

13621522 ["{-# LANGUAGE CPP #-}"

13631523 ,"main ="

13641524 ,"#ifdef __GHCIDE__"

@@ -1372,7 +1532,7 @@ cppTests =

13721532 where

13731533 expectError :: T.Text -> Cursor -> Session ()

13741534 expectError content cursor = do

1375− _ <- openDoc' "Testing.hs" "haskell" content

1535+ _ <- createDoc "Testing.hs" "haskell" content

13761536 expectDiagnostics

13771537 [ ( "Testing.hs",

13781538 [(DsError, cursor, "error: unterminated")]

@@ -1388,13 +1548,43 @@ preprocessorTests = testSessionWait "preprocessor" $ do

13881548 , "module Testing where"

13891549 , "y = x + z" -- plugin replaces x with y, making this have only one diagnostic

13901550 ]

1391− _ <- openDoc' "Testing.hs" "haskell" content

1551+ _ <- createDoc "Testing.hs" "haskell" content

13921552 expectDiagnostics

13931553 [ ( "Testing.hs",

13941554 [(DsError, (2, 8), "Variable not in scope: z")]

13951555 )

13961556 ]

13971557

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+

13981588thTests :: TestTree

13991589thTests =

14001590 testGroup

@@ -1420,8 +1610,8 @@ thTests =

14201610 "b :: Integer",

14211611 "b = $(litE $ IntegerL $ a) + n"

14221612 ]

1423− _ <- openDoc' "A.hs" "haskell" sourceA

1424− _ <- openDoc' "B.hs" "haskell" sourceB

1613+ _ <- createDoc "A.hs" "haskell" sourceA

1614+ _ <- createDoc "B.hs" "haskell" sourceB

14251615 expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ]

14261616 , testSessionWait "newtype-closure" $ do

14271617 let sourceA =

@@ -1441,8 +1631,8 @@ thTests =

14411631 ,"import A"

14421632 ,"b :: Int"

14431633 ,"b = $( a )" ]

1444− _ <- openDoc' "A.hs" "haskell" sourceA

1445− _ <- openDoc' "B.hs" "haskell" sourceB

1634+ _ <- createDoc "A.hs" "haskell" sourceA

1635+ _ <- createDoc "B.hs" "haskell" sourceB

14461636 return ()

14471637 ]

14481638

@@ -1451,7 +1641,7 @@ completionTests

14511641 = testGroup "completion"

14521642 [ testSessionWait "variable" $ do

14531643 let source = T.unlines ["module A where", "f = hea"]

1454− docId <- openDoc' "A.hs" "haskell" source

1644+ docId <- createDoc "A.hs" "haskell" source

14551645 compls <- getCompletions docId (Position 1 7)

14561646 liftIO $ map dropDocs compls @?=

14571647 [complItem "head" (Just CiFunction) (Just "[a] -> a")]

@@ -1463,7 +1653,7 @@ completionTests

14631653 ]

14641654 , testSessionWait "constructor" $ do

14651655 let source = T.unlines ["module A where", "f = Tru"]

1466− docId <- openDoc' "A.hs" "haskell" source

1656+ docId <- createDoc "A.hs" "haskell" source

14671657 compls <- getCompletions docId (Position 1 7)

14681658 liftIO $ map dropDocs compls @?=

14691659 [ complItem "True" (Just CiConstructor) (Just "Bool")

@@ -1475,7 +1665,7 @@ completionTests

14751665 ]

14761666 , testSessionWait "type" $ do

14771667 let source = T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: ()", "f = ()"]

1478− docId <- openDoc' "A.hs" "haskell" source

1668+ docId <- createDoc "A.hs" "haskell" source

14791669 expectDiagnostics [ ("A.hs", [(DsWarning, (3,0), "not used")]) ]

14801670 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]]

14811671 compls <- getCompletions docId (Position 2 7)

@@ -1492,7 +1682,7 @@ completionTests

14921682 checkDocText "Bool" boolDocs [ "Defined in 'Prelude'" ]

14931683 , testSessionWait "qualified" $ do

14941684 let source = T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = ()"]

1495− docId <- openDoc' "A.hs" "haskell" source

1685+ docId <- createDoc "A.hs" "haskell" source

14961686 expectDiagnostics [ ("A.hs", [(DsWarning, (2, 0), "not used")]) ]

14971687 changeDoc docId [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]]

14981688 compls <- getCompletions docId (Position 2 15)

@@ -1506,9 +1696,30 @@ completionTests

15061696 ]

15071697 , testSessionWait "keyword" $ do

15081698 let source = T.unlines ["module A where", "f = newty"]

1509− docId <- openDoc' "A.hs" "haskell" source

1699+ docId <- createDoc "A.hs" "haskell" source

15101700 compls <- getCompletions docId (Position 1 9)

15111701 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 "*")]

15121723 ]

15131724 where

15141725 dropDocs :: CompletionItem -> CompletionItem

@@ -1516,6 +1727,7 @@ completionTests

15161727 complItem label kind ty = CompletionItem

15171728 { _label = label

15181729 , _kind = kind

1730+ , _tags = List []

15191731 , _detail = (":: " <>) <$> ty

15201732 , _documentation = Nothing

15211733 , _deprecated = Nothing

@@ -1533,6 +1745,7 @@ completionTests

15331745 keywordItem label = CompletionItem

15341746 { _label = label

15351747 , _kind = Just CiKeyword

1748+ , _tags = List []

15361749 , _detail = Nothing

15371750 , _documentation = Nothing

15381751 , _deprecated = Nothing

@@ -1560,7 +1773,7 @@ outlineTests = testGroup

15601773 "outline"

15611774 [ testSessionWait "type class" $ do

15621775 let source = T.unlines ["module A where", "class A a where a :: a -> Bool"]

1563− docId <- openDoc' "A.hs" "haskell" source

1776+ docId <- createDoc "A.hs" "haskell" source

15641777 symbols <- getDocumentSymbols docId

15651778 liftIO $ symbols @?= Left

15661779 [ moduleSymbol

@@ -1573,7 +1786,7 @@ outlineTests = testGroup

15731786 ]

15741787 , testSessionWait "type class instance " $ do

15751788 let source = T.unlines ["class A a where", "instance A () where"]

1576− docId <- openDoc' "A.hs" "haskell" source

1789+ docId <- createDoc "A.hs" "haskell" source

15771790 symbols <- getDocumentSymbols docId

15781791 liftIO $ symbols @?= Left

15791792 [ classSymbol "A a" (R 0 0 0 15) []

@@ -1581,7 +1794,7 @@ outlineTests = testGroup

15811794 ]

15821795 , testSessionWait "type family" $ do

15831796 let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"]

1584− docId <- openDoc' "A.hs" "haskell" source

1797+ docId <- createDoc "A.hs" "haskell" source

15851798 symbols <- getDocumentSymbols docId

15861799 liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkClass (R 1 0 1 13)]

15871800 , testSessionWait "type family instance " $ do

@@ -1590,7 +1803,7 @@ outlineTests = testGroup

15901803 , "type family A a"

15911804 , "type instance A () = ()"

15921805 ]

1593− docId <- openDoc' "A.hs" "haskell" source

1806+ docId <- createDoc "A.hs" "haskell" source

15941807 symbols <- getDocumentSymbols docId

15951808 liftIO $ symbols @?= Left

15961809 [ docSymbolD "A a" "type family" SkClass (R 1 0 1 15)

@@ -1598,7 +1811,7 @@ outlineTests = testGroup

15981811 ]

15991812 , testSessionWait "data family" $ do

16001813 let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"]

1601− docId <- openDoc' "A.hs" "haskell" source

1814+ docId <- createDoc "A.hs" "haskell" source

16021815 symbols <- getDocumentSymbols docId

16031816 liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkClass (R 1 0 1 11)]

16041817 , testSessionWait "data family instance " $ do

@@ -1607,7 +1820,7 @@ outlineTests = testGroup

16071820 , "data family A a"

16081821 , "data instance A () = A ()"

16091822 ]

1610− docId <- openDoc' "A.hs" "haskell" source

1823+ docId <- createDoc "A.hs" "haskell" source

16111824 symbols <- getDocumentSymbols docId

16121825 liftIO $ symbols @?= Left

16131826 [ docSymbolD "A a" "data family" SkClass (R 1 0 1 11)

@@ -1615,36 +1828,36 @@ outlineTests = testGroup

16151828 ]

16161829 , testSessionWait "constant" $ do

16171830 let source = T.unlines ["a = ()"]

1618− docId <- openDoc' "A.hs" "haskell" source

1831+ docId <- createDoc "A.hs" "haskell" source

16191832 symbols <- getDocumentSymbols docId

16201833 liftIO $ symbols @?= Left

16211834 [docSymbol "a" SkFunction (R 0 0 0 6)]

16221835 , testSessionWait "pattern" $ do

16231836 let source = T.unlines ["Just foo = Just 21"]

1624− docId <- openDoc' "A.hs" "haskell" source

1837+ docId <- createDoc "A.hs" "haskell" source

16251838 symbols <- getDocumentSymbols docId

16261839 liftIO $ symbols @?= Left

16271840 [docSymbol "Just foo" SkFunction (R 0 0 0 18)]

16281841 , testSessionWait "pattern with type signature" $ do

16291842 let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"]

1630− docId <- openDoc' "A.hs" "haskell" source

1843+ docId <- createDoc "A.hs" "haskell" source

16311844 symbols <- getDocumentSymbols docId

16321845 liftIO $ symbols @?= Left

16331846 [docSymbol "a :: ()" SkFunction (R 1 0 1 12)]

16341847 , testSessionWait "function" $ do

16351848 let source = T.unlines ["a x = ()"]

1636− docId <- openDoc' "A.hs" "haskell" source

1849+ docId <- createDoc "A.hs" "haskell" source

16371850 symbols <- getDocumentSymbols docId

16381851 liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 8)]

16391852 , testSessionWait "type synonym" $ do

16401853 let source = T.unlines ["type A = Bool"]

1641− docId <- openDoc' "A.hs" "haskell" source

1854+ docId <- createDoc "A.hs" "haskell" source

16421855 symbols <- getDocumentSymbols docId

16431856 liftIO $ symbols @?= Left

16441857 [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)]

16451858 , testSessionWait "datatype" $ do

16461859 let source = T.unlines ["data A = C"]

1647− docId <- openDoc' "A.hs" "haskell" source

1860+ docId <- createDoc "A.hs" "haskell" source

16481861 symbols <- getDocumentSymbols docId

16491862 liftIO $ symbols @?= Left

16501863 [ docSymbolWithChildren "A"

@@ -1652,18 +1865,47 @@ outlineTests = testGroup

16521865 (R 0 0 0 10)

16531866 [docSymbol "C" SkConstructor (R 0 9 0 10)]

16541867 ]

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

16551880 , testSessionWait "import" $ do

16561881 let source = T.unlines ["import Data.Maybe"]

1657− docId <- openDoc' "A.hs" "haskell" source

1882+ docId <- createDoc "A.hs" "haskell" source

16581883 symbols <- getDocumentSymbols docId

16591884 liftIO $ symbols @?= Left

1660− [docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)]

1885+ [docSymbolWithChildren "imports"

1886+ SkModule

1887+ (R 0 0 0 17)

1888+ [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 17)

1889+ ]

1890+ ]

1891+ , testSessionWait "multiple import" $ do

1892+ let source = T.unlines ["", "import Data.Maybe", "", "import Control.Exception", ""]

1893+ docId <- createDoc "A.hs" "haskell" source

1894+ symbols <- getDocumentSymbols docId

1895+ liftIO $ symbols @?= Left

1896+ [docSymbolWithChildren "imports"

1897+ SkModule

1898+ (R 1 0 3 24)

1899+ [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 17)

1900+ , docSymbol "import Control.Exception" SkModule (R 3 0 3 24)

1901+ ]

1902+ ]

16611903 , testSessionWait "foreign import" $ do

16621904 let source = T.unlines

16631905 [ "{-# language ForeignFunctionInterface #-}"

16641906 , "foreign import ccall \"a\" a :: Int"

16651907 ]

1666− docId <- openDoc' "A.hs" "haskell" source

1908+ docId <- createDoc "A.hs" "haskell" source

16671909 symbols <- getDocumentSymbols docId

16681910 liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)]

16691911 , testSessionWait "foreign export" $ do

@@ -1671,7 +1913,7 @@ outlineTests = testGroup

16711913 [ "{-# language ForeignFunctionInterface #-}"

16721914 , "foreign export ccall odd :: Int -> Bool"

16731915 ]

1674− docId <- openDoc' "A.hs" "haskell" source

1916+ docId <- createDoc "A.hs" "haskell" source

16751917 symbols <- getDocumentSymbols docId

16761918 liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)]

16771919 ]

@@ -1684,6 +1926,8 @@ outlineTests = testGroup

16841926 DocumentSymbol name (Just detail) kind Nothing loc loc Nothing

16851927 docSymbolWithChildren name kind loc cc =

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

16871931 moduleSymbol name loc cc = DocumentSymbol name

16881932 Nothing

16891933 SkFile

@@ -1705,8 +1949,16 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')

17051949xfail :: TestTree -> String -> TestTree

17061950xfail = flip expectFailBecause

17071951

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+

17081959data Expect

17091960 = ExpectRange Range -- Both gotoDef and hover should report this range

1961+ | ExpectLocation Location

17101962-- | ExpectDefRange Range -- Only gotoDef should report this range

17111963 | ExpectHoverRange Range -- Only hover should report this range

17121964 | ExpectHoverText [T.Text] -- the hover message must contain these snippets

@@ -1719,6 +1971,9 @@ data Expect

17191971mkR :: Int -> Int -> Int -> Int -> Expect

17201972mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn

17211973

1974+mkL :: Uri -> Int -> Int -> Int -> Int -> Expect

1975+mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn

1976+

17221977haddockTests :: TestTree

17231978haddockTests

17241979 = testGroup "haddock"

@@ -1774,6 +2029,167 @@ haddockTests

17742029 where

17752030 checkHaddock s txt = spanDocToMarkdownForTest s @?= txt

17762031

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+

17772193----------------------------------------------------------------------

17782194-- Utils

17792195

@@ -1781,6 +2197,12 @@ haddockTests

17812197testSession :: String -> Session () -> TestTree

17822198testSession name = testCase name . run

17832199

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+

17842206testSessionWait :: String -> Session () -> TestTree

17852207testSessionWait name = testSession name .

17862208 -- Check that any diagnostics produced were already consumed by the test case.

@@ -1791,24 +2213,53 @@ testSessionWait name = testSession name .

17912213 -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.

17922214 ( >> expectNoMoreDiagnostics 0.5)

17932215

1794−pickActionWithTitle :: T.Text -> [CAResult] -> CodeAction

1795−pickActionWithTitle title actions = head

1796− [ action

1797− | CACodeAction action@CodeAction{ _title = actionTitle } <- actions

1798− , 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+ ]

17992230

18002231mkRange :: Int -> Int -> Int -> Int -> Range

18012232mkRange a b c d = Range (Position a b) (Position c d)

18022233

18032234run :: Session a -> IO a

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

18052255 ghcideExe <- locateGhcideExecutable

18062256

18072257 -- Temporarily hack around https://github.com/mpickering/hie-bios/pull/56

18082258 -- since the package import test creates "Data/List.hs", which otherwise has no physical home

18092259 createDirectoryIfMissing True $ dir ++ "/Data"

18102260

1811− let cmd = unwords [ghcideExe, "--lsp", "--cwd", dir]

2261+

2262+ let cmd = unwords [ghcideExe, "--lsp", "--test", "--cwd", dir]

18122263 -- HIE calls getXgdDirectory which assumes that HOME is set.

18132264 -- Only sets HOME if it wasn't already set.

18142265 setEnv "HOME" "/homeless-shelter" False

@@ -1825,7 +2276,7 @@ run s = withTempDir $ \dir -> do

18252276openTestDataDoc :: FilePath -> Session TextDocumentIdentifier

18262277openTestDataDoc path = do

18272278 source <- liftIO $ readFileUtf8 $ "test/data" </> path

1828− openDoc' path "haskell" source

2279+ createDoc path "haskell" source

18292280

18302281findCodeActions :: TextDocumentIdentifier -> Range -> [T.Text] -> Session [CodeAction]

18312282findCodeActions doc range expectedTitles = do

@@ -1840,7 +2291,7 @@ findCodeActions doc range expectedTitles = do

18402291 [ actionTitle

18412292 | CACodeAction CodeAction { _title = actionTitle } <- actions

18422293 ]

1843− ++ "is not a superset of "

2294+ ++ " is not a superset of "

18442295 ++ show expectedTitles

18452296 liftIO $ case matches of

18462297 Nothing -> assertFailure msg

@@ -1853,24 +2304,19 @@ findCodeAction doc range t = head <$> findCodeActions doc range [t]

18532304unitTests :: TestTree

18542305unitTests = do

18552306 testGroup "Unit"

1856− [ testCase "empty file path" $

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

18582318 ]

18592319

1860−-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events

1861−openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier

1862−openDoc' fp name contents = do

1863− res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents

1864− -- Needed as ghcide sets up and relies on WatchedFiles but lsp-test does not track them

1865− sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])

1866− return res

1867−

1868−-- | Version of 'LSPTest.openDoc'' that does not send WatchedFiles events for files outside the workspace

1869−openDoc'' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier

1870−-- At the moment this is just LSPTest.openDoc' but it may change in the future

1871−-- when/if lsp-test implements WatchedFiles

1872−openDoc'' = LSPTest.openDoc'

1873−

18742320positionMappingTests :: TestTree

18752321positionMappingTests =

18762322 testGroup "position mapping"

@@ -2039,3 +2485,12 @@ nthLine i r

20392485 | i == 0 && Rope.rows r == 0 = r

20402486 | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)

20412487 | 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 '‘' = '\''